1;;; vms-patch.el --- override parts of files.el for VMS 2 3;; Copyright (C) 1986, 1992, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: FSF 7;; Keywords: vms 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;;; Code: 29 30(setq auto-mode-alist (cons '(("\\.com\\'" . dcl-mode)) auto-mode-alist)) 31 32;;; Functions that need redefinition 33 34;;; VMS file names are upper case, but buffer names are more 35;;; convenient in lower case. 36 37(defun create-file-buffer (filename) 38 "Create a suitably named buffer for visiting FILENAME, and return it. 39FILENAME (sans directory) is used unchanged if that name is free; 40otherwise a string <2> or <3> or ... is appended to get an unused name." 41 (generate-new-buffer (downcase (file-name-nondirectory filename)))) 42 43;;; Given a string FN, return a similar name which is a legal VMS filename. 44;;; This is used to avoid invalid auto save file names. 45(defun make-legal-file-name (fn) 46 (setq fn (copy-sequence fn)) 47 (let ((dot nil) (indx 0) (len (length fn)) chr) 48 (while (< indx len) 49 (setq chr (aref fn indx)) 50 (cond 51 ((eq chr ?.) (if dot (aset fn indx ?_) (setq dot t))) 52 ((not (or (and (>= chr ?a) (<= chr ?z)) (and (>= chr ?A) (<= chr ?Z)) 53 (and (>= chr ?0) (<= chr ?9)) 54 (eq chr ?$) (eq chr ?_) (and (eq chr ?-) (> indx 0)))) 55 (aset fn indx ?_))) 56 (setq indx (1+ indx)))) 57 fn) 58 59;;; Auto save filesnames start with _$ and end with $. 60 61(defun make-auto-save-file-name () 62 "Return file name to use for auto-saves of current buffer. 63This function does not consider `auto-save-visited-file-name'; 64the caller should check that before calling this function. 65This is a separate function so that your `.emacs' file or the site's 66`site-init.el' can redefine it. 67See also `auto-save-file-name-p'." 68 (if buffer-file-name 69 (concat (file-name-directory buffer-file-name) 70 "_$" 71 (file-name-nondirectory buffer-file-name) 72 "$") 73 (expand-file-name (concat "_$_" (make-legal-file-name (buffer-name)) "$")))) 74 75(defun auto-save-file-name-p (filename) 76 "Return t if FILENAME can be yielded by `make-auto-save-file-name'. 77FILENAME should lack slashes. 78This is a separate function so that your `.emacs' file or the site's 79`site-init.el' can redefine it." 80 (string-match "^_\\$.*\\$" filename)) 81 82;;; 83;;; This goes along with kepteditor.com which defines these logicals 84;;; If EMACS_COMMAND_ARGS is defined, it supersedes EMACS_FILE_NAME, 85;;; which is probably set up incorrectly anyway. 86;;; The function command-line-again is a kludge, but it does the job. 87;;; 88(defun vms-suspend-resume-hook () 89 "When resuming suspended Emacs, check for file to be found. 90If the logical name `EMACS_FILE_NAME' is defined, `find-file' that file." 91 (let ((file (vms-system-info "LOGICAL" "EMACS_FILE_NAME")) 92 (args (vms-system-info "LOGICAL" "EMACS_COMMAND_ARGS")) 93 (line (vms-system-info "LOGICAL" "EMACS_FILE_LINE"))) 94 (if (not args) 95 (if file 96 (progn (find-file file) 97 (if line (goto-line (string-to-number line))))) 98 (cd (file-name-directory file)) 99 (vms-command-line-again)))) 100 101(setq suspend-resume-hook 'vms-suspend-resume-hook) 102 103(defun vms-suspend-hook () 104 "Don't allow suspending if logical name `DONT_SUSPEND_EMACS' is defined." 105 (if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS") 106 (error "Can't suspend this emacs")) 107 nil) 108 109(setq suspend-hook 'vms-suspend-hook) 110 111;;; 112;;; A kludge that allows reprocessing of the command line. This is mostly 113;;; to allow a spawned VMS mail process to do something reasonable when 114;;; used in conjunction with the modifications to sysdep.c that allow 115;;; Emacs to attach to a "foster" parent. 116;;; 117(defun vms-command-line-again () 118 "Reprocess command line arguments. VMS specific. 119Command line arguments are initialized from the logical EMACS_COMMAND_ARGS 120which is defined by kepteditor.com. On VMS this allows attaching to a 121spawned Emacs and doing things like \"emacs -l myfile.el -f doit\"" 122 (let* ((args (downcase (vms-system-info "LOGICAL" "EMACS_COMMAND_ARGS"))) 123 (command-line-args (list "emacs")) 124 (beg 0) 125 (end 0) 126 (len (length args)) 127 this-char) 128 (if args 129 (progn 130;;; replace non-printable stuff with spaces 131 (while (< beg (length args)) 132 (if (or (> 33 (setq this-char (aref args beg))) 133 (< 127 this-char)) 134 (aset args beg 32)) 135 (setq beg (1+ beg))) 136 (setq beg (1- (length args))) 137 (while (= 32 (aref args beg)) (setq beg (1- beg))) 138 (setq args (substring args 0 (1+ beg))) 139 (setq beg 0) 140;;; now start parsing args 141 (while (< beg (length args)) 142 (while (and (< beg (length args)) 143 (or (> 33 (setq this-char (aref args beg))) 144 (< 127 this-char)) 145 (setq beg (1+ beg)))) 146 (setq end (1+ beg)) 147 (while (and (< end (length args)) 148 (< 32 (setq this-char (aref args end))) 149 (> 127 this-char)) 150 (setq end (1+ end))) 151 (setq command-line-args (append 152 command-line-args 153 (list (substring args beg end)))) 154 (setq beg (1+ end))) 155 (command-line))))) 156 157(defun vms-read-directory (dirname switches buffer) 158 (save-excursion 159 (set-buffer buffer) 160 (subprocess-command-to-buffer 161 (concat "DIRECTORY " switches " " dirname) 162 buffer) 163 (goto-char (point-min)) 164 ;; Remove all the trailing blanks. 165 (while (search-forward " \n") 166 (forward-char -1) 167 (delete-horizontal-space)) 168 (goto-char (point-min)))) 169 170(setq dired-listing-switches 171 "/SIZE/DATE/OWNER/WIDTH=(FILENAME=32,SIZE=5)") 172 173(setq print-region-function 174 (lambda (start end command ign1 ign2 ign3 &rest switches) 175 (write-region start end "sys$login:delete-me.txt") 176 (send-command-to-subprocess 177 1 178 (concat command 179 " sys$login:delete-me.txt/name=\"GNUprintbuffer\" " 180 (mapconcat 'identity switches " ")) 181 nil nil nil))) 182 183;;; 184;;; Fuctions for using Emacs as a VMS Mail editor 185;;; 186(autoload 'vms-pmail-setup "vms-pmail" 187 "Set up file assuming use by VMS Mail utility. 188The buffer is put into text-mode, auto-save is turned off and the 189following bindings are established. 190 191\\[vms-pmail-save-and-exit] vms-pmail-save-and-exit 192\\[vms-pmail-abort] vms-pmail-abort 193 194All other Emacs commands are still available." 195 t) 196 197;;; 198;;; Filename handling in the minibuffer 199;;; 200(defun vms-magic-right-square-brace () 201 "\ 202Insert a right square brace, but do other things first depending on context. 203During filename completion, when point is at the end of the line and the 204character before is not a right square brace, do one of three things before 205inserting the brace: 206 - If there are already two left square braces preceding, do nothing special. 207 - If there is a previous right-square-brace, convert it to dot. 208 - If the character before is dot, delete it. 209Additionally, if the preceding chars are right-square-brace followed by 210either \"-\" or \"..\", strip one level of directory hierarchy." 211 (interactive) 212 (when (and minibuffer-completing-file-name 213 (= (point) (point-max)) 214 (not (= 93 (char-before)))) 215 (cond 216 ;; Avoid clobbering: user:[one.path][another.path 217 ((search-backward "[" (field-beginning) t 2)) 218 ((search-backward "]" (field-beginning) t) 219 (delete-char 1) 220 (insert ".") 221 (goto-char (point-max))) 222 ((= ?. (char-before)) 223 (delete-char -1))) 224 (goto-char (point-max)) 225 (let ((specs '(".." "-")) 226 (pmax (point-max))) 227 (while specs 228 (let* ((up (car specs)) 229 (len (length up)) 230 (cut (- (point) len))) 231 (when (and (< (1+ len) pmax) 232 (= ?. (char-before cut)) 233 (string= up (buffer-substring cut (point)))) 234 (delete-char (- (1+ len))) 235 (while (not (let ((c (char-before))) 236 (or (= ?. c) (= 91 c)))) 237 (delete-char -1)) 238 (when (= ?. (char-before)) (delete-char -1)) 239 (setq specs nil))) 240 (setq specs (cdr specs))))) 241 (insert "]")) 242 243(defun vms-magic-colon () 244 "\ 245Insert a colon, but do other things first depending on context. 246During filename completion, when point is at the end of the line 247and the line contains a right square brace, remove all characters 248from the beginning of the line up to and including such brace. 249This enables one to type a new filespec without having to delete 250the old one." 251 (interactive) 252 (when (and minibuffer-completing-file-name 253 (= (point) (point-max)) 254 (search-backward "]" (field-beginning) t)) 255 (delete-region (field-beginning) (1+ (point))) 256 (goto-char (point-max))) 257 (insert ":")) 258 259(let ((m minibuffer-local-completion-map)) 260 (define-key m "]" 'vms-magic-right-square-brace) 261 (define-key m "/" 'vms-magic-right-square-brace) 262 (define-key m ":" 'vms-magic-colon)) 263 264;;; arch-tag: c178494e-2c37-4d02-99b7-e47e615656cf 265;;; vms-patch.el ends here 266