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