rsalz@uunet.uu.net (Rich Salz) (06/07/89)
Submitted-by: Axel Mahler <unido!coma!axel>
Posting-number: Volume 19, Issue 40
Archive-name: shape/part27
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 27 (of 33)."
# Contents: interface/shapetools.el
# Wrapped by rsalz@papaya.bbn.com on Thu Jun 1 19:27:17 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'interface/shapetools.el' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'interface/shapetools.el'\"
else
echo shar: Extracting \"'interface/shapetools.el'\" \(33526 characters\)
sed "s/^X//" >'interface/shapetools.el' <<'END_OF_FILE'
X; LAST EDIT: Fri Nov 4 11:16:33 1988 by Shape - New Horizons in Software Engineering (chaos!shape)
X; LAST EDIT: Thu Nov 3 14:16:48 1988 by Shape - New Horizons in Software Engineering (chaos!shape)
X; LAST EDIT: Tue Nov 1 12:46:34 1988 by Uli Pralle (coma!uli)
X;;; This file is not part of the GNU Emacs distribution (yet).
X
X;; SHAPE commands for Emacs
X;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
X
X;; This file is part of GNU Emacs.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY. No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing. Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License. A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities. It should be in a
X;; file named COPYING. Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X;In loaddefs.el
X(defvar shape-listing-switches "-al"
X "Switches passed to ls for shape. MUST contain the 'l' option.
X CANNOT contain the 'F' option.")
X(defvar shape-compare-file1 nil)
X
X(defun shape-readin (dirname buffer)
X (save-excursion
X (set-buffer buffer)
X (let ((buffer-read-only nil))
X (widen)
X (erase-buffer)
X (setq dirname (expand-file-name dirname))
X (if (file-directory-p dirname)
X (call-process "vl" nil buffer nil
X shape-listing-switches dirname)
X (let ((default-directory (file-name-directory dirname)))
X (call-process shell-file-name nil buffer nil
X "-c" (concat "vl " shape-listing-switches " "
X (file-name-nondirectory dirname)))))
X (goto-char (point-min))
X (while (not (eobp))
X (insert " ")
X (forward-line 1))
X (goto-char (point-min)))))
X
X(defun shape-find-buffer (dirname)
X (let ((blist (buffer-list))
X found)
X (while blist
X (save-excursion
X (set-buffer (car blist))
X (if (and (eq major-mode 'shape-mode)
X (equal shape-directory dirname))
X (setq found (car blist)
X blist nil)
X (setq blist (cdr blist)))))
X (or found
X (progn (if (string-match "/$" dirname)
X (setq dirname (substring dirname 0 -1)))
X (create-file-buffer (file-name-nondirectory dirname))))))
X
X(defun shapetools(&optional dirname)
X "\"Edit\" directory DIRNAME. Delete some files in it.
X Shape displays a list of files in DIRNAME.
X You can move around in it with the usual commands.
X You can flag files for deletion with C-d
X and then delete them by typing `x'.
X Type `h' after entering shape for more info."
X (interactive)
X (if (equal dirname nil)
X (setq dirname (shape-get-filename nil t))
X nil)
X (if (equal dirname nil)
X (setq dirname (read-file-name "Shapetools (directory): "
X nil default-directory nil))
X nil)
X
X (switch-to-buffer (shape-noselect dirname)))
X
X(defun shape-other-window (dirname)
X "\"Edit\" directory DIRNAME. Like M-x shape but selects in another window."
X (interactive (list (read-file-name "Shapetools in other window (directory): "
X nil default-directory nil)))
X (switch-to-buffer-other-window (shape-noselect dirname)))
X
X(defun shape-noselect (dirname)
X "Like M-x shape but returns the shape buffer as value, does not select it."
X (or dirname (setq dirname default-directory))
X (if (string-match "./$" dirname)
X (setq dirname (substring dirname 0 -1)))
X (setq dirname (expand-file-name dirname))
X (and (not (string-match "/$" dirname))
X (file-directory-p dirname)
X (setq dirname (concat dirname "/")))
X (let ((buffer (shape-find-buffer dirname)))
X (save-excursion
X (set-buffer buffer)
X (shape-readin dirname buffer)
X (shape-move-to-filename)
X (shape-mode dirname))
X buffer))
X
X(defun shape-revert (&optional arg noconfirm)
X (let ((opoint (point))
X (ofile (shape-get-filename t t))
X (buffer-read-only nil))
X (erase-buffer)
X (shape-readin shape-directory (current-buffer))
X (or (and ofile (re-search-forward (concat " " (regexp-quote ofile) "$")
X nil t))
X (goto-char opoint))
X (beginning-of-line)))
X
X(defvar shape-mode-map nil "Local keymap for shape-mode buffers.")
X(if shape-mode-map
X nil
X (setq shape-mode-map (make-keymap))
X (suppress-keymap shape-mode-map)
X (define-key shape-mode-map "r" 'shape-rename-file)
X (define-key shape-mode-map "\C-d" 'shape-flag-file-deleted)
X (define-key shape-mode-map "d" 'shape-flag-file-deleted)
X (define-key shape-mode-map "l" 'shape-vlog)
X (define-key shape-mode-map "v" 'shape-view-file)
X (define-key shape-mode-map "e" 'shape-find-file)
X (define-key shape-mode-map "f" 'shape-find-file)
X (define-key shape-mode-map "o" 'shape-find-file-other-window)
X (define-key shape-mode-map "q" '(lambda () (interactive) (kill-buffer (current-buffer))))
X (define-key shape-mode-map "u" 'shape-unflag)
X (define-key shape-mode-map "x" 'shape-do-deletions)
X (define-key shape-mode-map "\177" 'shape-backup-unflag)
X (define-key shape-mode-map "?" 'shape-summary)
X (define-key shape-mode-map "c" 'shape-copy-file)
X (define-key shape-mode-map "h" 'describe-mode)
X (define-key shape-mode-map " " 'shape-next-line)
X (define-key shape-mode-map "\C-n" 'shape-next-line)
X (define-key shape-mode-map "\C-p" 'shape-previous-line)
X (define-key shape-mode-map "n" 'shape-next-line)
X (define-key shape-mode-map "p" 'shape-previous-line)
X (define-key shape-mode-map "g" 'revert-buffer)
X (define-key shape-mode-map "R" 'shape-retrv)
X (define-key shape-mode-map "O" 'shape-vadm-change-owner)
X (define-key shape-mode-map "P" 'shape-vadm-promote)
X (define-key shape-mode-map "U" 'shape-vadm-unpromote)
X (define-key shape-mode-map "M" 'shape-vadm-change-mode)
X (define-key shape-mode-map "A" 'shape-vadm-change-author)
X (define-key shape-mode-map "S" 'shape-save)
X (define-key shape-mode-map "V" 'shape-vadm)
X (define-key shape-mode-map "C" 'shape-compare)
X (define-key shape-mode-map "F" 'shape-fold)
X (define-key shape-mode-map "X" 'shape-unfold)
X (define-key shape-mode-map "W" 'shape-mail-wishes)
X (define-key shape-mode-map "B" 'shape-mail-bugs)
X (define-key shape-mode-map "E" 'shape-execute))
X
X
X;; Shape mode is suitable only for specially formatted data.
X(put 'shape-mode 'mode-class 'special)
X
X(defun shape-mode (dirname)
X"- M change file's mode. - d flag a file for Deletion.
X- G change group. - u unflag a file (remove its D flag).
X- O change owner. - x execute the deletions requested.
X- A change author. - e edit file or list directory.
X- P promote a saved version. - o find file/directory other window.
X- U unpromote a saved version. - W mail wishes (B to mail a bug).
X- C compare two files. - c copy a file.
X- S save a busy version. - v view a file in View mode.
X- F fold directory - g read the directory again.
X- X unfold file or directory - E execute shape
X- l show logentry
XSpace and Rubout can be used to move down and up by lines.
X\\{shape-mode-map}"
X (kill-all-local-variables)
X (make-local-variable 'revert-buffer-function)
X (setq revert-buffer-function 'shape-revert)
X (setq major-mode 'shape-mode)
X (setq mode-name "Shape")
X (make-local-variable 'shape-directory)
X (setq shape-directory dirname)
X (setq default-directory
X (if (file-directory-p dirname)
X dirname (file-name-directory dirname)))
X (setq mode-line-buffer-identification '("Shape Tools: %17b"))
X (setq case-fold-search nil)
X (setq buffer-read-only t)
X (use-local-map shape-mode-map)
X (run-hooks 'shape-mode-hook))
X
X(defun shape-repeat-over-lines (arg function)
X (beginning-of-line)
X (while (and (> arg 0) (not (eobp)))
X (setq arg (1- arg))
X (save-excursion
X (beginning-of-line)
X (and (bobp) (looking-at " total")
X (error "No file on this line"))
X (funcall function))
X (forward-line 1)
X (shape-move-to-filename))
X (while (and (< arg 0) (not (bobp)))
X (setq arg (1+ arg))
X (forward-line -1)
X (shape-move-to-filename)
X (save-excursion
X (beginning-of-line)
X (funcall function))))
X
X(defun shape-flag-file-deleted (&optional arg)
X "In shape, flag the current line's file for deletion.
XWith arg, repeat over several lines."
X (interactive "p")
X (shape-repeat-over-lines (or arg 1)
X '(lambda ()
X (let ((buffer-read-only nil))
X (if (looking-at " d")
X nil
X (if (or (looking-at " .......... s ")
X (looking-at " .......... b "))
X (progn
X (delete-char 1)
X (insert "D"))
X (message "Only saved or busy versions may be deleted")))))))
X
X(defun shape-summary ()
X (interactive)
X ;>> this should check the key-bindings and use substitute-command-keys if non-standard
X (message
X "Commands: ACFGMOPSUX cdegoruvx \(h for more help\)"))
X
X(defun shape-unflag (arg)
X "In shape, remove the current line's delete flag then move to next line."
X (interactive "p")
X (shape-repeat-over-lines arg
X '(lambda ()
X (let ((buffer-read-only nil))
X (delete-char 1)
X (insert " ")
X (forward-char -1)))))
X
X(defun shape-backup-unflag (arg)
X "In shape, move up a line and remove deletion flag there."
X (interactive "p")
X (shape-unflag (- arg)))
X
X(defun shape-next-line (arg)
X "Move down ARG lines then position at filename."
X (interactive "p")
X (next-line arg)
X (shape-move-to-filename))
X
X(defun shape-previous-line (arg)
X "Move up ARG lines then position at filename."
X (interactive "p")
X (previous-line arg)
X (shape-move-to-filename))
X
X(defun shape-find-file ()
X "In shape, visit the file or directory named on this line."
X (interactive)
X (if (file-folded-p (shape-get-filename))
X (shapetools (substring (shape-get-filename) 0 -3))
X (if (file-AFS-p (shape-get-filename))
X (message "Can't edit a version or folded file")
X (find-file (shape-get-filename)))))
X
X(defun shape-view-file ()
X "In shape, examine a file in view mode, returning to shape when done."
X (interactive)
X (if (file-directory-p (shape-get-filename))
X (shapetools (shape-get-filename))
X (if (file-folded-p (shape-get-filename))
X (shapetools (substring (shape-get-filename) 0 -3))
X (if (file-AFS-p (shape-get-filename))
X (shape-vcat)
X (view-file (shape-get-filename))))))
X
X(defun shape-find-file-other-window ()
X "In shape, visit this file or directory in another window."
X (interactive)
X (if (file-folded-p (shape-get-filename))
X (shape-other-window (substring (shape-get-filename) 0 -3))
X (if (file-AFS-p (shape-get-filename))
X (message "Can't edit a version")
X (if (file-DIR-p)
X (shape-othe-window (shape-get-filename))
X (find-file-other-window (shape-get-filename))))))
X
X(defun shape-get-filename (&optional localp no-error-if-not-filep)
X "In shape, return name of file mentioned on this line.
XValue returned normally includes the directory name.
XA non-nil 1st argument means do not include it. A non-nil 2nd argument
Xsays return nil if no filename on this line, otherwise an error occurs."
X (let (eol)
X (save-excursion
X (end-of-line)
X (setq eol (point))
X (beginning-of-line)
X (if (re-search-forward
X "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
X eol t)
X (progn (skip-chars-forward " ")
X (skip-chars-forward "^ " eol)
X (skip-chars-forward " " eol)
X (skip-chars-forward "^ " eol)
X (skip-chars-forward " " eol)
X (let ((beg (point)))
X (skip-chars-forward "^ \n")
X (if localp
X (buffer-substring beg (point))
X ;; >> uses default-directory, could lose on cd, multiple.
X (concat default-directory (buffer-substring beg (point))))))
X (if no-error-if-not-filep nil
X (error "No file on this line"))))))
X
X(defun shape-move-to-filename ()
X "In shape, move to first char of filename on this line.
XReturns position (point) or nil if no filename on this line."
X (let ((eol (progn (end-of-line) (point))))
X (beginning-of-line)
X (if (re-search-forward
X "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
X eol t)
X (progn
X (skip-chars-forward " ")
X (skip-chars-forward "^ " eol)
X (skip-chars-forward " " eol)
X (skip-chars-forward "^ " eol)
X (skip-chars-forward " " eol)
X (point)))))
X
X(defun shape-map-shape-file-lines (fn)
X "perform fn with point at the end of each non-directory line:
Xarguments are the short and long filename"
X (save-excursion
X (let (filename longfilename (buffer-read-only nil))
X (goto-char (point-min))
X (while (not (eobp))
X (save-excursion
X (and (not (looking-at " d"))
X (not (eolp))
X (setq filename (shape-get-filename t t)
X longfilename (shape-get-filename nil t))
X (progn (end-of-line)
X (funcall fn filename longfilename))))
X (forward-line 1)))))
X
X
X(defun shape-collect-file-versions (ignore fn)
X "If it looks like fn has versions, we make a list of the versions.
XWe may want to flag some for deletion."
X (let* ((base-versions
X (concat (file-name-nondirectory fn) ".~"))
X (bv-length (length base-versions))
X (possibilities (file-name-all-completions
X base-versions
X (file-name-directory fn)))
X (versions (mapcar 'backup-extract-version possibilities)))
X (if versions
X (setq file-version-assoc-list (cons (cons fn versions)
X file-version-assoc-list)))))
X
X(defun shape-trample-file-versions (ignore fn)
X (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
X base-version-list)
X (and start-vn
X (setq base-version-list ; there was a base version to which
X (assoc (substring fn 0 start-vn) ; this looks like a
X file-version-assoc-list)) ; subversion
X (not (memq (string-to-int (substring fn (+ 2 start-vn)))
X base-version-list)) ; this one doesn't make the cut
X (shape-flag-this-line-for-DEATH))))
X
X(defun shape-flag-this-line-for-DEATH ()
X (beginning-of-line)
X (delete-char 1)
X (insert "D"))
X
X(defun shape-rename-file (to-file)
X "Rename this file to TO-FILE."
X (interactive "FRename to: ")
X (setq to-file (expand-file-name to-file))
X (rename-file (shape-get-filename) to-file)
X (let ((buffer-read-only nil))
X (beginning-of-line)
X (delete-region (point) (progn (forward-line 1) (point)))
X (setq to-file (expand-file-name to-file))
X (shape-add-entry (file-name-directory to-file)
X (file-name-nondirectory to-file))))
X
X(defun shape-copy-file ()
X "Copy this file to TO-FILE."
X (interactive)
X (let ((from-file (shape-get-filename t)))
X (if (file-AFS-p (shape-get-filename t))
X (message "Can't copy saved files")
X (setq to-file (read-string (concat "Copy " from-file " to: ")))
X (copy-file (shape-get-filename) to-file)
X (setq to-file (expand-file-name to-file))
X (shape-add-entry (file-name-directory to-file)
X (file-name-nondirectory to-file)))))
X
X(defun shape-add-entry (directory filename)
X ;; If tree shape is implemented, this function will have to do
X ;; something smarter with the directory. Currently, just check
X ;; default directory, if same, add the new entry at point. With tree
X ;; shape, should call 'shape-current-directory' or similar. Note
X ;; that this adds the entry 'out of order' if files sorted by time,
X ;; etc.
X (if (string-equal directory default-directory)
X (let ((buffer-read-only nil))
X (beginning-of-line)
X (if (file-AFS-p filename)
X (call-process "vl" nil t nil
X shape-listing-switches
X (concat directory filename))
X (call-process "vl" nil t nil shape-listing-switches
X "-sb" (concat directory filename)))
X (forward-line -1)
X (insert " ")
X (shape-move-to-filename)
X (let* ((beg (point))
X (end (progn (end-of-line) (point))))
X (setq filename (buffer-substring beg end))
X (delete-region beg end)
X (insert (file-name-nondirectory filename)))
X (beginning-of-line))))
X
X(defun shape-chgrp (group)
X "Change group of this file."
X (interactive "sChange to Group: ")
X (let ((buffer-read-only nil)
X (file (shape-get-filename)))
X (call-process "/bin/chgrp" nil nil nil group file)
X (shape-redisplay file)))
X
X(defun shape-redisplay (file)
X "Redisplay this line."
X (beginning-of-line)
X (delete-region (point) (progn (forward-line 1) (point)))
X (if file (shape-add-entry (file-name-directory file)
X (file-name-nondirectory file)))
X (shape-move-to-filename))
X
X(defun shape-do-deletions ()
X "In shape, delete the files flagged for deletion."
X (interactive)
X (let (delete-list answer)
X (save-excursion
X (goto-char 1)
X (while (re-search-forward "^D" nil t)
X (setq delete-list
X (cons (cons (shape-get-filename t) (1- (point)))
X delete-list))))
X (if (null delete-list)
X (message "(No deletions requested)")
X (save-window-excursion
X (switch-to-buffer " *Deletions*")
X (erase-buffer)
X (setq fill-column 70)
X (let ((l (reverse delete-list)))
X ;; Files should be in forward order for this loop.
X (while l
X (if (> (current-column) 59)
X (insert ?\n)
X (or (bobp)
X (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
X (insert (car (car l)))
X (setq l (cdr l))))
X (goto-char (point-min))
X (setq answer (yes-or-no-p "Delete these files? ")))
X (if answer
X (let ((l delete-list)
X failures)
X ;; Files better be in reverse order for this loop!
X ;; That way as changes are made in the buffer
X ;; they do not shift the lines still to be changed.
X (while l
X (goto-char (cdr (car l)))
X (let ((buffer-read-only nil))
X (condition-case ()
X (progn (shape-delete-file (concat default-directory
X (car (car l))))
X (delete-region (point)
X (progn (forward-line 1) (point))))
X
X (error (delete-char 1)
X (insert " ")
X (setq failures (cons (car (car l)) failures)))))
X (setq l (cdr l)))
X (if failures
X (message "Deletions failed: %s"
X (prin1-to-string failures))))))))
X
X
X(defun shape-vcat()
X "retrieve and old version and display it."
X (interactive)
X (setq vcat-buffer (create-file-buffer (shape-get-filename)))
X (call-process shape-vcat-command nil vcat-buffer nil "-q" (shape-get-filename))
X (message "Restoring %s ..." (shape-get-filename t))
X (view-buffer vcat-buffer)
X (kill-buffer vcat-buffer)
X)
X
X(defun shape-vlog()
X "Display logentry for a particular version or entire history."
X (interactive)
X (if (file-directory-p (shape-get-filename))
X (error "Directories don't have any log-entries")
X (if (file-folded-p (shape-get-filename))
X (progn
X (setq history-filename (substring (shape-get-filename) 0 -3))
X (setq msg-string
X (concat "History log for " history-filename)))
X (if (file-AFS-p (shape-get-filename))
X (progn (setq history-filename (shape-get-filename))
X (setq msg-string (concat "Log entry for " history-filename)))
X (setq history-filename (shape-get-filename))
X (setq msg-string (concat "History log for " history-filename))))
X
X (setq vlog-buffer (create-file-buffer msg-string))
X (call-process shape-vlog-command nil vlog-buffer
X nil history-filename)
X (message (concat "Viewing " msg-string))
X (sit-for 2)
X (setq old-view-hook view-hook view-hook '(beginning-of-buffer))
X (view-buffer vlog-buffer)
X (setq view-hook old-view-hook)
X (kill-buffer vlog-buffer))
X )
X
X(defun shape-vadm (vadm-input)
X "Perform vadm features."
X (interactive "svadm: ")
X (let ((buffer-read-only nil)
X (file (shape-get-filename)))
X (call-process shape-vadm-command nil nil nil "-q" vadm-input file)
X (shape-redisplay file)))
X
X(defun shape-vadm-promote()
X "Performs vadm -promote."
X (interactive)
X (let ((buffer-read-only nil)
X (file (shape-get-filename t))
X (file2 (shape-get-filename)))
X (if (not (file-AFS-p file))
X (message "Can't promote busy file or directory %s" file)
X (message "Promoting %s ..." file)
X (call-process shape-vadm-command nil nil nil "-q" "-promote" file2)
X (sit-for 1 t)
X (shape-redisplay file2)
X (message "Done."))))
X
X(defun shape-vadm-unpromote()
X "Performs vadm -unpromote."
X (interactive)
X (let ((buffer-read-only nil)
X (file (shape-get-filename t))
X (file2 (shape-get-filename)))
X (if (not (file-AFS-p file))
X (message "Can't unpromote busy file or directory %s" file)
X (message "Unpromoting %s ..." file)
X (call-process shape-vadm-command nil nil nil "-q" "-unpromote" file2)
X (sit-for 1 t)
X (shape-redisplay file2)
X (message "Done."))))
X
X(defun shape-vadm-change-mode()
X "Performs vadm -chmod."
X (interactive)
X (let ((buffer-read-only nil)
X (file (shape-get-filename t))
X (file2 (shape-get-filename)))
X (setq input (read-string (concat "Change mode of " file " to: ")))
X (if (file-AFS-p file2)
X (call-process shape-vadm-command nil nil nil "-q" "-chmod" input file2)
X (call-process "/bin/chmod" nil nil nil input file2))
X (shape-redisplay file2)
X (message "Done.")))
X
X(defun shape-vadm-change-author()
X "Performs vadm -chaut."
X (interactive)
X (let ((buffer-read-only nil)
X (file (shape-get-filename t))
X (file2 (shape-get-filename)))
X (setq input (read-string (concat "Change author of " file " to: ")))
X (call-process shape-vadm-command nil nil nil "-q" "-chaut" input file2)
X (shape-redisplay file2)
X (message "Done.")))
X
X
X(defun shape-vadm-change-owner()
X "Performs vadm -chown."
X (interactive)
X (let ((buffer-read-only nil)
X (file (shape-get-filename t))
X (file2 (shape-get-filename)))
X (setq input (read-string (concat "Change owner of " file " to: ")))
X (call-process shape-vadm-command nil nil nil "-q" "-chown" input file2)
X (shape-redisplay file2)
X (message "Done.")))
X
X
X(defun shape-save ()
X "saves a file via the save command."
X (interactive)
X (save-excursion
X (let ((buffer-read-only nil)
X (file (shape-get-filename))
X (file2 (shape-get-filename t)))
X (if (or (file-AFS-p file) (file-DIR-p))
X (message "This file not a busy file or a directory")
X (if (y-or-n-p "Describe this document or changes? ")
X (progn
X (setq descfile (make-temp-name "/tmp/save"))
X (shape-get-description descfile)
X (message "Saving file %s" file2)
X (call-process shape-save-command nil t nil "-f" "-q" "-t"
X descfile file)
X (delete-file descfile)
X (shape-insert-new-version file2))
X (message "Saving file %s" file2)
X (call-process shape-save-command nil t nil "-f" "-q" file)
X (shape-insert-new-version file2)
X (while (search-forward file2 nil t)))))))
X
X(defun shape-submit ()
X "submit a file via the submit command."
X (interactive)
X (save-excursion
X (let ((buffer-read-only nil)
X (file (shape-get-filename))
X (file2 (shape-get-filename t)))
X (if (or (file-AFS-p file) (file-DIR-p))
X (message "This file not a busy file or a directory")
X (if (y-or-n-p "Describe this document or changes? ")
X (progn
X (setq descfile (make-temp-name "/tmp/save"))
X (shape-get-description descfile)
X (message "Submitting file %s" file2)
X (call-process shape-submit-command nil t nil "-f" "-q" "-t"
X descfile file)
X (delete-file descfile)
X (revert-buffer))
X (message "Submitting file %s" file2)
X (call-process shape-submit-command nil t nil "-f" "-q" file)
X (revert-buffer)
X )))))
X
X(defun shape-retrv()
X "retrieves a version via the rtrv command."
X (interactive)
X (save-excursion
X (let ((buffer-read-only nil))
X (setq file (shape-get-filename t))
X (setq file2 (substring file 0 (string-match "\\\[" file)))
X (if (not (file-AFS-p file))
X (message "This file is not saved file")
X (if (file-exists-p file2)
X (progn
X (if (y-or-n-p (concat "Writable busy version of "
X file2
X " exists! Overwrite it?"))
X (progn
X (call-process shape-retrv-command nil nil "-f" "-q" file)
X (shape-redisplay file2)))))))))
X
X(defun shape-compare()
X "compares two versions with diff and puts output into a view buffer."
X (interactive)
X (save-excursion
X; (local-set-key "^X^@" 'shape-compare)
X (setq shape-buffer1 nil)
X (setq shape-buffer2 nil)
X (if (eq shape-compare-file1 nil)
X (progn
X (if (or (file-DIR-p) (file-folded-p (shape-get-filename t)))
X (message "Cant't compare directories or folded files")
X (defvar shape-compare-file1 nil)
X (setq shape-compare-file1 (shape-get-filename t))
X (message "Compare %s with ? \(goto file2 and hit C again\)"
X shape-compare-file1)
X (shape-flag-file-compare "<")))
X
X (setq shape-compare-file2 (shape-get-filename t))
X (if (or (file-DIR-p) (file-folded-p shape-compare-file2))
X (message "Cant't compare directories or folded files")
X (shape-flag-file-compare ">")
X (if (file-AFS-p shape-compare-file1)
X (progn
X (setq shape-buffer1 (create-file-buffer shape-compare-file1))
X (call-process shape-vcat-command nil shape-buffer1 nil
X "-q" shape-compare-file1)
X (setq shape-compare-file1 (concat "/tmp/" shape-compare-file1)))
X nil)
X
X (if (file-AFS-p shape-compare-file2)
X (progn
X (setq shape-buffer2 (create-file-buffer shape-compare-file2))
X (call-process shape-vcat-command nil shape-buffer2 nil
X "-q" shape-compare-file2)
X (setq shape-compare-file2 (concat "/tmp/" shape-compare-file2)))
X nil)
X (setq diff-buffer (create-file-buffer "diff"))
X (if shape-buffer1
X (progn
X (save-excursion
X (set-buffer shape-buffer1)
X (write-file (concat "/tmp/" shape-compare-file1))))
X nil)
X (if shape-buffer2
X (progn
X (save-excursion
X (set-buffer shape-buffer2)
X (write-file (concat "/tmp/" shape-compare-file2))))
X nil)
X (message "Comparing %s with %s" shape-compare-file1
X shape-compare-file2)
X (sit-for 3 t)
X (call-process "diff" nil diff-buffer nil shape-compare-file1
X shape-compare-file2)
X (view-buffer diff-buffer)
X (if (file-AFS-p shape-compare-file1)
X (progn
X (delete-file shape-compare-file1)
X (kill-buffer shape-buffer1))
X nil)
X (if (file-AFS-p shape-compare-file2)
X (progn
X (delete-file shape-compare-file2)
X (kill-buffer shape-buffer2))
X nil)
X (kill-buffer diff-buffer)
X (setq shape-compare-file1 nil)
X (shape-unflag-file-compare)
X ;(local-unset-key "^X^@")
X ))))
X
X
X(defun shape-fold()
X "Compresses output; files with versions are displayed with <name>[*]."
X (interactive)
X (save-excursion
X (let ((buffer-read-only nil))
X (if (y-or-n-p "Fold whole directory? ")
X (progn
X (message "Folding directory ...")
X (goto-char (point-min))
X (while (search-forward "[" nil t)
X (setq filename (shape-get-filename t t))
X (kill-line 1)
X (insert "*]")
X (newline)
X (setq filename2 (substring
X filename 0 (string-match "\\\[" filename)))
X (setq filename2 (concat filename2 "\\\["))
X (delete-matching-lines filename2))
X (message "Done."))
X (setq filename (shape-get-filename t))
X (if (file-AFS-p filename)
X (progn
X (setq filename2 (substring
X filename 0 (string-match "\\\[" filename)))
X (goto-char (point-min))
X (search-forward (concat filename2 "["))
X (beginning-of-line)
X (search-forward "[" nil t)
X (kill-line 1)
X (insert "*]")
X (newline)
X (delete-matching-lines filename2)
X (sit-for 0)
X (message "Done."))
X (message "No version: %s" filename))))))
X
X(defun shape-unfold()
X "Expands folded entries."
X (interactive)
X (save-excursion
X (let ((buffer-read-only nil))
X (if (y-or-n-p "Unfold whole directory? ")
X (progn
X (message "Unfolding directory ...")
X (revert-buffer)
X (message "Done."))
X (if (equal (substring (shape-get-filename t)
X -3 (length (shape-get-filename t))) "[*]")
X (progn
X (setq filename (substring (shape-get-filename t) 0 -3))
X (message "Unfolding %s ..." filename)
X (beginning-of-line)
X (kill-line 1)
X (call-process shape-vl-command nil t nil shape-listing-switches
X "-ss" "-sp" "-sP" "-sa" "-sf" filename)
X (shape-update-buffer)
X (sit-for 0)
X (message "Done."))
X (message "File not folded."))))))
X
X
X(defun file-AFS-p(name)
X "decides whether a file is an AFS file or not (']' as last char)."
X (if (string-match "]" name) t nil))
X
X(defun file-DIR-p()
X (beginning-of-line)
X (looking-at " d"))
X
X(defun file-folded-p(file)
X (if (equal (substring file -3 (length file)) "[*]")
X t
X nil))
X
X(defun shape-insert-new-version (file)
X "update buffer after save command."
X (interactive)
X (let ((buffer-read-only nil))
X (while (search-forward file nil t))
X (forward-line)
X (beginning-of-line)
X (call-process shape-vl-command nil t nil shape-listing-switches "-y"
X (concat default-directory file))
X (forward-line -1)
X (insert " ")))
X
X
X(defun shape-get-description (descfile)
X "read the description for the save command."
X (save-excursion
X (find-file descfile)
X (switch-to-buffer descfile)
X (message "To stop type CNTL-C CNTL-C")
X (local-set-key "^C^C" 'shape-finish-edit)
X (recursive-edit)
X (write-file descfile)
X (kill-buffer (current-buffer))))
X
X(defun shape-finish-edit ()
X (interactive)
X (throw 'exit nil))
X
X
X(defun shape-delete-file (file)
X (if (file-AFS-p file)
X (call-process shape-vadm-command nil nil nil "-delete" file)
X (delete-file file)))
X
X(defun shape-flag-file-compare(mark)
X (let ((buffer-read-only nil))
X (save-excursion
X (beginning-of-line)
X (delete-char 1)
X (insert mark)
X (sit-for 0))))
X
X(defun shape-unflag-file-compare()
X (let ((buffer-read-only nil))
X (save-excursion
X (beginning-of-buffer)
X (re-search-forward "^[><]")
X (beginning-of-line)
X (delete-char 1)
X (insert " ")
X (re-search-forward "^[><]")
X (beginning-of-line)
X (delete-char 1)
X (insert " "))))
X
X(defun shape-update-buffer()
X "Updates buffer after unfold."
X (interactive)
X (save-excursion
X (goto-char (point-min))
X (while (re-search-forward "^-" nil t)
X (beginning-of-line)
X (insert " "))))
X
X(defun shape-execute()
X "sets compile command to shape -k."
X (interactive)
X (save-excursion
X (setq filename (shape-get-filename t t))
X (setq shapefile nil)
X (setq promptstring nil)
X (setq basename (substring
X filename 0 (string-match "\\\[" filename)))
X (if (or (equal basename "Shapefile")
X (equal basename "shapefile")
X (equal basename "Makefile")
X (equal basename "makefile")
X (equal filename "Shapefile")
X (equal filename "shapefile")
X (equal filename "Makefile")
X (equal filename "makefile"))
X (setq shapefile filename)
X (setq shapefile nil))
X (if (file-folded-p filename)
X (setq shapefile nil)
X nil)
X (if (equal shapefile nil)
X (setq promptstring "shape -k ")
X (if (file-AFS-p filename)
X (setq promptstring (concat "vcat " "\""
X filename
X "\"" " | shape -f - "))
X (setq promptstring (concat "shape -k -f " filename " "))))
X (setq input (read-string "shape: " promptstring))
X (if (equal input nil)
X (compile promptstring)
X (compile input))))
X
X(defvar shape-wish-address "shape-wishes@coma.UUCP" "The mail address to report a wish.")
X(defvar shape-bug-address "shape-bugs@coma.UUCP" "The mail address to report a bug.")
X(defvar shape-bug-description "Description:\n\nRepeat-By:\n\nFix:\n\nShape Toolkit version:\n\n"
X "Formular to report a bug")
X
X(defun shape-mail-bugs ()
X (interactive)
X (mail nil shape-bug-address)
X (goto-char (point-min))
X (beginning-of-next-line)
X (insert "Index: <tool>/<source> <confid>\n")
X (goto-char (point-max))
X (insert shape-bug-description "\n")
X (mail-position-on-field "Subject")
X (message (substitute-command-keys "Type \\[mail-send] to send bug report.")))
X
X(defun shape-mail-wishes ()
X (interactive)
X (mail nil shape-wish-address)
X (mail-position-on-field "Subject")
X (message (substitute-command-keys "Type \\[mail-send] to send wish report.")))
X
X
X(defun shape-execute-vl()
X "executes vl reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "vl: "))
X (shell-command (concat shape-vl-command " " input)))
X
X(defun shape-execute-save()
X "executes save reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "save: "))
X (shell-command (concat shape-save-command " " input)))
X
X(defun shape-execute-submit()
X "executes submit reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "sbmt: "))
X (shell-command (concat shape-submit-command " " input)))
X
X(defun shape-execute-retrv()
X"executes retrv reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "retrv: "))
X (shell-command (concat shape-retrv-command " " input)))
X
X(defun shape-execute-vadm()
X"executes vadm reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "vadm: "))
X (shell-command (concat shape-vadm-command " " input)))
X
X(defun shape-execute-vcat()
X"executes vcat reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "vcat: "))
X (shell-command (concat shape-vcat-command " " input)))
X
X
X(defun shape-execute-vlog()
X"executes vlog reading parameters from the minibuffer."
X (interactive)
X (setq input (read-string "vlog: "))
X (shell-command (concat shape-vlog-command " " input)))
X
END_OF_FILE
if test 33526 -ne `wc -c <'interface/shapetools.el'`; then
echo shar: \"'interface/shapetools.el'\" unpacked with wrong size!
fi
# end of 'interface/shapetools.el'
fi
echo shar: End of archive 27 \(of 33\).
cp /dev/null ark27isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 33 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Please send comp.sources.unix-related mail to rsalz@uunet.uu.net.