;;; vms-patch.el --- override parts of files.el for VMS

;; Copyright (C) 1986, 1992 Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: vms

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; 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, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Redefined functions:
;;   create-file-buffer
;;   file-newest-backup
;;   backup-file-name-p
;;   backup-extract-version
;;   find-backup-file-name
;;   write-region
;;   make-auto-save-file-name
;;   auto-save-file-name-p
;;
;; New functions:
;;   old-write-region
;;   vms-suspend-resume-hook
;;   vms-suspend-hook
;;   vms-command-line-again
;;   vms-read-directory
;;
;; Modified variables:
;;   suspend-resume-hook
;;   suspend-hook
;;   dired-listing-switches

;;; Code:

;; VMS file names are upper case, but buffer names are more
;; convenient in lower case.

(defun create-file-buffer (filename)
  "Create a suitably named buffer for visiting FILENAME, and return it.
FILENAME (sans directory) is used unchanged if that name is free;
otherwise a string <2> or <3> or ... is appended to get an unused name."
  (generate-new-buffer (downcase (file-name-nondirectory filename))))

;;; On VMS, backup files are represented a whole different way than on UNIX,
;;; So let's provide a function that does things right.

(defun file-newest-backup (filename)
  "Return most recent backup file for FILENAME or nil if no backups exist."
  (let* ((filename (expand-file-name filename))
	 (file (file-name-nondirectory filename))
	 (dir  (file-name-directory    filename))
	 (comp (file-name-all-completions-with-versions file dir))
	 newest)
    (while comp
      (setq file (concat dir (car comp))
	    comp (cdr comp))
      (if (and (string= (file-name-sans-versions file) filename)
	       (or (null newest) (file-newer-than-file-p file newest)))
	  (setq newest file)))
    newest))

(defun backup-file-name-p (file)
  "Return non-nil if file is a backup file name.  This is a separate
function so you can redefine it for customization.
You may need to redefine `file-name-sans-versions' as well."
  (string-match "\\(\\.[^.]\\.\\|;\\)\\([0-9]+\\)$" file))

(defun backup-extract-version (fn)
  "Given the name of a numeric backup file, return the backup number."
  (if (backup-file-name-p fn)
      (string-to-int (substring fn (match-beginning 2) (match-end 2)))
    0))

(defun find-backup-file-name (fn)
  "Find a file name for a backup file, and suggestions for deletions.
Value is a list whose car is the name for the backup file
and whose cdr is a list of old versions to consider deleting now."
  (if (eq version-control 'never)
      (list (make-backup-file-name fn))
    (let* ((base-version (file-name-nondirectory (file-name-sans-versions fn)))
	   possibilities number-to-delete)
      (condition-case ()
	  (setq possibilities
		(file-name-all-versions base-version
					(file-name-directory fn))
		number-to-delete
		(- (length possibilities)
		   kept-old-versions (max 1 kept-new-versions)))
	(file-error
	 (setq possibilities nil)))
      (if nil ;(not version-control)
	  (list fn)
	(cons fn
	      (if (and (> number-to-delete 0)
		       (>= (+ (max 1 kept-new-versions) kept-old-versions) 0))
		  (let ((v (nthcdr kept-old-versions possibilities)))
		    (rplacd (nthcdr (1- number-to-delete) v) ())
		    v)))))))

;;; We might get stupid errors from write-region because of some variants
;;; of search-paths... Let's fix that.

(if (not (fboundp 'old-write-region))
    (fset 'old-write-region (symbol-function 'write-region)))

(defun write-region (start end filename &optional app visit lockname mustbenew)
  (interactive "r\nFWrite region to file: ")
  (condition-case error
      (old-write-region start end filename app visit lockname mustbenew)
    (error (old-write-region start end
			     (concat 
			      (file-name-directory
			       (file-truename
				(directory-file-name filename)))
			      (file-name-nondirectory filename))
			     app visit lockname mustbenew))))

(defun make-auto-save-file-name ()
  "Return file name to use for auto-saves of current buffer.
This function does not consider `auto-save-visited-file-name';
the caller should check that before calling this function.
This is a separate function so that your `.emacs' file or the site's
`site-init.el' can redefine it.
See also `auto-save-file-name-p'."
  (if buffer-file-name
      (concat (file-name-directory buffer-file-name)
	      "_$"
	      (file-name-nondirectory buffer-file-name)
	      "$")
    (expand-file-name
     (concat
      "_$_"
      ;; Convert the buffer name into a legal file name fragment.
      (let* ((fn (buffer-name))
	     (dot nil) (indx 0) (len (length fn)) chr)
	(while (< indx len)
	  (setq chr (aref fn indx))
	  (cond
	   ((eq chr ?.) (if dot (aset fn indx ?_) (setq dot t)))
	   ((not (or (and (>= chr ?a) (<= chr ?z)) (and (>= chr ?A) (<= chr ?Z))
		     (and (>= chr ?0) (<= chr ?9))
		     (eq chr ?$) (eq chr ?_) (and (eq chr ?-) (> indx 0))))
	    (aset fn indx ?_)))
	  (setq indx (1+ indx)))
	fn)
      "$"))))

(defun auto-save-file-name-p (filename)
  "Return t if FILENAME can be yielded by `make-auto-save-file-name'.
FILENAME should lack slashes.
This is a separate function so that your `.emacs' file or the site's
`site-init.el' can redefine it."
  (string-match "^_\\$.*\\$" filename))

;;;
;;; This goes along with kepteditor.com which defines these logicals
;;; If EMACS_COMMAND_ARGS is defined, it supersedes EMACS_FILE_NAME,
;;;   which is probably set up incorrectly anyway.
;;; The function command-line-again is a kludge, but it does the job.
;;;
(defun vms-suspend-resume-hook ()
  "When resuming suspended Emacs, check for file to be found.
If the logical name `EMACS_FILE_NAME' is defined, `find-file' that file."
  (let ((file (vms-system-info "LOGICAL" "EMACS_FILE_NAME"))
	(args (vms-system-info "LOGICAL" "EMACS_COMMAND_ARGS"))
	(line (vms-system-info "LOGICAL" "EMACS_FILE_LINE")))
    (if (not args)
	(if file
	    (progn (find-file file)
		   (if line (goto-line (string-to-int line)))))
      (cd (file-name-directory file))
      (vms-command-line-again))))

(setq suspend-resume-hook 'vms-suspend-resume-hook)

(defun vms-suspend-hook ()
  "Don't allow suspending if logical name `DONT_SUSPEND_EMACS' is defined."
  (if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS")
      (error "Can't suspend this emacs"))
  nil)

(setq suspend-hook 'vms-suspend-hook)

;;;
;;; A kludge that allows reprocessing of the command line.  This is mostly
;;;   to allow a spawned VMS mail process to do something reasonable when
;;;   used in conjunction with the modifications to sysdep.c that allow
;;;   Emacs to attach to a "foster" parent.
;;;
(defun vms-command-line-again ()
  "Reprocess command line arguments.  VMS specific.
Command line arguments are initialized from the logical EMACS_COMMAND_ARGS
which is defined by kepteditor.com.  On VMS this allows attaching to a
spawned Emacs and doing things like \"emacs -l myfile.el -f doit\""
  (let* ((args (downcase (vms-system-info "LOGICAL" "EMACS_COMMAND_ARGS")))
	 (command-line-args (list "emacs"))
	 (beg 0)
	 (end 0)
	 (len (length args))
	 this-char)
    (if args
	(progn
	  ;; replace non-printable stuff with spaces
	  (while (< beg (length args))
	    (if (or (> 33 (setq this-char (aref args beg)))
		    (< 127 this-char))
		(aset args beg 32))
	    (setq beg (1+ beg)))
	  (setq beg (1- (length args)))
	  (while (= 32 (aref args beg)) (setq beg (1- beg)))
	  (setq args (substring args 0 (1+ beg)))
	  (setq beg 0)
	  ;; now start parsing args
	  (while (< beg (length args))
	    (while (and (< beg (length args))
			(or (> 33 (setq this-char (aref args beg)))
			    (< 127 this-char))
			(setq beg (1+ beg))))
	    (setq end (1+ beg))
	    (while (and (< end (length args))
			(< 32 (setq this-char (aref args end)))
			(> 127 this-char))
	      (setq end (1+ end)))
	    (setq command-line-args (append 
				     command-line-args
				     (list (substring args beg end))))
	    (setq beg (1+ end)))
	  (command-line)))))

(defun vms-read-directory (dirname switches buffer)
  (save-excursion
    (set-buffer buffer)
    (let ((ls (split-string (concat "DIRECTORY " switches " " dirname))))
      (apply 'call-process (car ls) nil buffer nil (cdr ls)))
    (goto-char (point-min))
    ;; Remove trailing whitespace.
    (while (re-search-forward "\\s-+$" (point-max) t)
      (delete-region (match-beginning 0) (match-end 0)))
    (goto-char (point-min))))

(setq dired-listing-switches
      "/SIZE/DATE/OWNER/WIDTH=(FILENAME=32,SIZE=5)")

;;; vms-patch.el ends here
