home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / public / GNU / emacs.inst / emacs19.idb / usr / gnu / lib / emacs / site-lisp / shapetools.el.z / shapetools.el
Encoding:
Text File  |  1994-08-02  |  32.7 KB  |  985 lines
  1. ; LAST EDIT: Fri Nov  4 11:16:33 1988 by Shape - New Horizons in Software Engineering (chaos!shape) 
  2. ; LAST EDIT: Thu Nov  3 14:16:48 1988 by Shape - New Horizons in Software Engineering (chaos!shape) 
  3. ; LAST EDIT: Tue Nov  1 12:46:34 1988 by Uli Pralle (coma!uli) 
  4. ;;; This file is not part of the GNU Emacs distribution (yet).
  5.  
  6. ;; SHAPE commands for Emacs
  7. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  13. ;; accepts responsibility to anyone for the consequences of using it
  14. ;; or for whether it serves any particular purpose or works at all,
  15. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  16. ;; License for full details.
  17.  
  18. ;; Everyone is granted permission to copy, modify and redistribute
  19. ;; GNU Emacs, but only under the conditions described in the
  20. ;; GNU Emacs General Public License.   A copy of this license is
  21. ;; supposed to have been given to you along with GNU Emacs so you
  22. ;; can know your rights and responsibilities.  It should be in a
  23. ;; file named COPYING.  Among other things, the copyright notice
  24. ;; and this notice must be preserved on all copies.
  25.  
  26. ;In loaddefs.el
  27. (defvar shape-listing-switches "-al"
  28.   "Switches passed to ls for shape. MUST contain the 'l' option.
  29.     CANNOT contain the 'F' option.")
  30. (defvar shape-compare-file1 nil)
  31.  
  32. (defun shape-readin (dirname buffer)
  33.   (save-excursion
  34.     (set-buffer buffer)
  35.     (let ((buffer-read-only nil))
  36.       (widen)
  37.       (erase-buffer)
  38.       (setq dirname (expand-file-name dirname))
  39.       (if (file-directory-p dirname)
  40.       (call-process "vl" nil buffer nil
  41.             shape-listing-switches dirname)
  42.     (let ((default-directory (file-name-directory dirname)))
  43.       (call-process shell-file-name nil buffer nil
  44.             "-c" (concat "vl " shape-listing-switches " "
  45.                      (file-name-nondirectory dirname)))))
  46.       (goto-char (point-min))
  47.       (while (not (eobp))
  48.     (insert "  ")
  49.     (forward-line 1))
  50.       (goto-char (point-min)))))
  51.  
  52. (defun shape-find-buffer (dirname)
  53.   (let ((blist (buffer-list))
  54.     found)
  55.     (while blist
  56.       (save-excursion
  57.         (set-buffer (car blist))
  58.     (if (and (eq major-mode 'shape-mode)
  59.          (equal shape-directory dirname))
  60.         (setq found (car blist)
  61.           blist nil)
  62.       (setq blist (cdr blist)))))
  63.     (or found
  64.     (progn (if (string-match "/$" dirname)
  65.            (setq dirname (substring dirname 0 -1)))
  66.            (create-file-buffer (file-name-nondirectory dirname))))))
  67.  
  68. (defun shapetools(&optional dirname)
  69.   "\"Edit\" directory DIRNAME.  Delete some files in it.
  70.        Shape displays a list of files in DIRNAME.
  71.        You can move around in it with the usual commands.
  72.        You can flag files for deletion with C-d
  73.        and then delete them by typing `x'.
  74.        Type `h' after entering shape for more info."
  75.   (interactive)
  76.   (if (equal dirname nil)
  77.       (setq dirname (shape-get-filename nil t))
  78.     nil)
  79.   (if (equal dirname nil)
  80.       (setq dirname (read-file-name "Shapetools (directory): "
  81.                     nil default-directory nil))
  82.     nil)
  83.  
  84.   (switch-to-buffer (shape-noselect dirname)))
  85.  
  86. (defun shape-other-window (dirname)
  87.   "\"Edit\" directory DIRNAME.  Like M-x shape but selects in another window."
  88.   (interactive (list (read-file-name "Shapetools in other window (directory): "
  89.                      nil default-directory nil)))
  90.   (switch-to-buffer-other-window (shape-noselect dirname)))
  91.  
  92. (defun shape-noselect (dirname)
  93.   "Like M-x shape but returns the shape buffer as value, does not select it."
  94.   (or dirname (setq dirname default-directory))
  95.   (if (string-match "./$" dirname)
  96.       (setq dirname (substring dirname 0 -1)))
  97.   (setq dirname (expand-file-name dirname))
  98.   (and (not (string-match "/$" dirname))
  99.        (file-directory-p dirname)
  100.        (setq dirname (concat dirname "/")))
  101.   (let ((buffer (shape-find-buffer dirname)))
  102.     (save-excursion
  103.       (set-buffer buffer)
  104.       (shape-readin dirname buffer)
  105.       (shape-move-to-filename)
  106.       (shape-mode dirname))
  107.     buffer))
  108.  
  109. (defun shape-revert (&optional arg noconfirm)
  110.   (let ((opoint (point))
  111.     (ofile (shape-get-filename t t))
  112.     (buffer-read-only nil))
  113.     (erase-buffer)
  114.     (shape-readin shape-directory (current-buffer))
  115.     (or (and ofile (re-search-forward (concat " " (regexp-quote ofile) "$")
  116.                       nil t))
  117.     (goto-char opoint))
  118.     (beginning-of-line)))
  119.  
  120. (defvar shape-mode-map nil "Local keymap for shape-mode buffers.")
  121. (if shape-mode-map
  122.     nil
  123.   (setq shape-mode-map (make-keymap))
  124.   (suppress-keymap shape-mode-map)
  125.   (define-key shape-mode-map "r" 'shape-rename-file)
  126.   (define-key shape-mode-map "\C-d" 'shape-flag-file-deleted)
  127.   (define-key shape-mode-map "d" 'shape-flag-file-deleted)
  128.   (define-key shape-mode-map "l" 'shape-vlog)
  129.   (define-key shape-mode-map "v" 'shape-view-file)
  130.   (define-key shape-mode-map "e" 'shape-find-file)
  131.   (define-key shape-mode-map "f" 'shape-find-file)
  132.   (define-key shape-mode-map "o" 'shape-find-file-other-window)
  133.   (define-key shape-mode-map "q" '(lambda () (interactive) (kill-buffer (current-buffer))))
  134.   (define-key shape-mode-map "u" 'shape-unflag)
  135.   (define-key shape-mode-map "x" 'shape-do-deletions)
  136.   (define-key shape-mode-map "\177" 'shape-backup-unflag)
  137.   (define-key shape-mode-map "?" 'shape-summary)
  138.   (define-key shape-mode-map "c" 'shape-copy-file)
  139.   (define-key shape-mode-map "h" 'describe-mode)
  140.   (define-key shape-mode-map " "  'shape-next-line)
  141.   (define-key shape-mode-map "\C-n" 'shape-next-line)
  142.   (define-key shape-mode-map "\C-p" 'shape-previous-line)
  143.   (define-key shape-mode-map "n" 'shape-next-line)
  144.   (define-key shape-mode-map "p" 'shape-previous-line)
  145.   (define-key shape-mode-map "g" 'revert-buffer)
  146.   (define-key shape-mode-map "R" 'shape-retrv)
  147.   (define-key shape-mode-map "O" 'shape-vadm-change-owner)
  148.   (define-key shape-mode-map "P" 'shape-vadm-promote)
  149.   (define-key shape-mode-map "U" 'shape-vadm-unpromote)
  150.   (define-key shape-mode-map "M" 'shape-vadm-change-mode)
  151.   (define-key shape-mode-map "A" 'shape-vadm-change-author)
  152.   (define-key shape-mode-map "S" 'shape-save)
  153.   (define-key shape-mode-map "V" 'shape-vadm)
  154.   (define-key shape-mode-map "C" 'shape-compare)
  155.   (define-key shape-mode-map "F" 'shape-fold)
  156.   (define-key shape-mode-map "X" 'shape-unfold)
  157.   (define-key shape-mode-map "W" 'shape-mail-wishes)
  158.   (define-key shape-mode-map "B" 'shape-mail-bugs)
  159.   (define-key shape-mode-map "E" 'shape-execute))
  160.  
  161.  
  162. ;; Shape mode is suitable only for specially formatted data.
  163. (put 'shape-mode 'mode-class 'special)
  164.  
  165. (defun shape-mode (dirname)
  166. "- M change file's mode.                  - d flag a file for Deletion.
  167. - G change group.                        - u unflag a file (remove its D flag).
  168. - O change owner.                        - x execute the deletions requested.
  169. - A change author.                       - e edit file or list directory.
  170. - P promote a saved version.             - o find file/directory other window.
  171. - U unpromote a saved version.           - W mail wishes (B to mail a bug).
  172. - C compare two files.                   - c copy a file.
  173. - S save a busy version.                 - v view a file in View mode.
  174. - F fold directory                       - g read the directory again.
  175. - X unfold file or directory             - E execute shape
  176. - l show logentry
  177. Space and Rubout can be used to move down and up by lines.
  178. \\{shape-mode-map}"
  179.   (kill-all-local-variables)    
  180.   (make-local-variable 'revert-buffer-function)
  181.   (setq revert-buffer-function 'shape-revert)
  182.   (setq major-mode 'shape-mode)
  183.   (setq mode-name "Shape")
  184.   (make-local-variable 'shape-directory)
  185.   (setq shape-directory dirname)
  186.   (setq default-directory 
  187.     (if (file-directory-p dirname)
  188.         dirname (file-name-directory dirname)))
  189.   (setq mode-line-buffer-identification '("Shape Tools: %17b"))
  190.   (setq case-fold-search nil)
  191.   (setq buffer-read-only t)
  192.   (use-local-map shape-mode-map)
  193.   (run-hooks 'shape-mode-hook))
  194.  
  195. (defun shape-repeat-over-lines (arg function)
  196.   (beginning-of-line)
  197.   (while (and (> arg 0) (not (eobp)))
  198.     (setq arg (1- arg))
  199.     (save-excursion
  200.       (beginning-of-line)
  201.       (and (bobp) (looking-at "  total")
  202.        (error "No file on this line"))
  203.       (funcall function))
  204.     (forward-line 1)
  205.     (shape-move-to-filename))
  206.   (while (and (< arg 0) (not (bobp)))
  207.     (setq arg (1+ arg))
  208.     (forward-line -1)
  209.     (shape-move-to-filename)
  210.     (save-excursion
  211.       (beginning-of-line)
  212.       (funcall function))))
  213.  
  214. (defun shape-flag-file-deleted (&optional arg)
  215.   "In shape, flag the current line's file for deletion.
  216. With arg, repeat over several lines."
  217.   (interactive "p")
  218.   (shape-repeat-over-lines (or arg 1)
  219.     '(lambda ()
  220.        (let ((buffer-read-only nil))
  221.      (if (looking-at "  d")
  222.          nil
  223.        (if (or (looking-at "  .......... s ")
  224.            (looking-at "  .......... b "))
  225.            (progn
  226.          (delete-char 1)
  227.          (insert "D"))
  228.          (message "Only saved or busy versions may be deleted")))))))
  229.  
  230. (defun shape-summary ()
  231.   (interactive)
  232.   ;>> this should check the key-bindings and use substitute-command-keys if non-standard
  233.   (message
  234.    "Commands: ACFGMOPSUX cdegoruvx \(h for more help\)"))
  235.  
  236. (defun shape-unflag (arg)
  237.   "In shape, remove the current line's delete flag then move to next line."
  238.   (interactive "p")
  239.   (shape-repeat-over-lines arg
  240.     '(lambda ()
  241.        (let ((buffer-read-only nil))
  242.      (delete-char 1)
  243.      (insert " ")
  244.      (forward-char -1)))))
  245.  
  246. (defun shape-backup-unflag (arg)
  247.   "In shape, move up a line and remove deletion flag there."
  248.   (interactive "p")
  249.   (shape-unflag (- arg)))
  250.  
  251. (defun shape-next-line (arg)
  252.   "Move down ARG lines then position at filename."
  253.   (interactive "p")
  254.   (next-line arg)
  255.   (shape-move-to-filename))
  256.  
  257. (defun shape-previous-line (arg)
  258.   "Move up ARG lines then position at filename."
  259.   (interactive "p")
  260.   (previous-line arg)
  261.   (shape-move-to-filename))
  262.  
  263. (defun shape-find-file ()
  264.   "In shape, visit the file or directory named on this line."
  265.   (interactive)
  266.   (if (file-folded-p (shape-get-filename))
  267.       (shapetools (substring (shape-get-filename) 0 -3))
  268.     (if (file-AFS-p (shape-get-filename))
  269.     (message "Can't edit a version or folded file")
  270.       (find-file (shape-get-filename)))))
  271.  
  272. (defun shape-view-file ()
  273.   "In shape, examine a file in view mode, returning to shape when done."
  274.   (interactive)
  275.   (if (file-directory-p (shape-get-filename))
  276.       (shapetools (shape-get-filename))
  277.     (if (file-folded-p (shape-get-filename))
  278.     (shapetools (substring (shape-get-filename) 0 -3))
  279.       (if (file-AFS-p (shape-get-filename))
  280.       (shape-vcat)
  281.     (view-file (shape-get-filename))))))
  282.         
  283. (defun shape-find-file-other-window ()
  284.   "In shape, visit this file or directory in another window."
  285.   (interactive)
  286.   (if (file-folded-p (shape-get-filename))
  287.       (shape-other-window (substring (shape-get-filename) 0 -3))
  288.     (if (file-AFS-p (shape-get-filename))
  289.     (message "Can't edit a version")
  290.       (if (file-DIR-p)
  291.       (shape-othe-window (shape-get-filename))
  292.     (find-file-other-window (shape-get-filename))))))
  293.  
  294. (defun shape-get-filename (&optional localp no-error-if-not-filep)
  295.   "In shape, return name of file mentioned on this line.
  296. Value returned normally includes the directory name.
  297. A non-nil 1st argument means do not include it.  A non-nil 2nd argument
  298. says return nil if no filename on this line, otherwise an error occurs."
  299.   (let (eol)
  300.     (save-excursion
  301.       (end-of-line)
  302.       (setq eol (point))
  303.       (beginning-of-line)
  304.       (if (re-search-forward
  305.        "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
  306.        eol t)
  307.       (progn (skip-chars-forward " ")
  308.          (skip-chars-forward "^ " eol)
  309.          (skip-chars-forward " " eol)
  310.          (skip-chars-forward "^ " eol)
  311.          (skip-chars-forward " " eol)
  312.          (let ((beg (point)))
  313.            (skip-chars-forward "^ \n")
  314.            (if localp
  315.                (buffer-substring beg (point))
  316.              ;; >> uses default-directory, could lose on cd, multiple.
  317.              (concat default-directory (buffer-substring beg (point))))))
  318.     (if no-error-if-not-filep nil
  319.       (error "No file on this line"))))))
  320.  
  321. (defun shape-move-to-filename ()
  322.   "In shape, move to first char of filename on this line.
  323. Returns position (point) or nil if no filename on this line."
  324.   (let ((eol (progn (end-of-line) (point))))
  325.     (beginning-of-line)
  326.     (if (re-search-forward
  327.      "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
  328.      eol t)
  329.     (progn
  330.       (skip-chars-forward " ")
  331.       (skip-chars-forward "^ " eol)
  332.       (skip-chars-forward " " eol)
  333.       (skip-chars-forward "^ " eol)
  334.       (skip-chars-forward " " eol)
  335.       (point)))))
  336.  
  337. (defun shape-map-shape-file-lines (fn)
  338.   "perform fn with point at the end of each non-directory line:
  339. arguments are the short and long filename"
  340.   (save-excursion
  341.     (let (filename longfilename (buffer-read-only nil))
  342.       (goto-char (point-min))
  343.       (while (not (eobp))
  344.     (save-excursion
  345.       (and (not (looking-at "  d"))
  346.            (not (eolp))
  347.            (setq filename (shape-get-filename t t)
  348.              longfilename (shape-get-filename nil t))
  349.            (progn (end-of-line)
  350.               (funcall fn filename longfilename))))
  351.     (forward-line 1)))))
  352.  
  353.  
  354. (defun shape-collect-file-versions (ignore fn)
  355.   "If it looks like fn has versions, we make a list of the versions.
  356. We may want to flag some for deletion."
  357.     (let* ((base-versions
  358.         (concat (file-name-nondirectory fn) ".~"))
  359.        (bv-length (length base-versions))
  360.        (possibilities (file-name-all-completions
  361.                base-versions
  362.                (file-name-directory fn)))
  363.        (versions (mapcar 'backup-extract-version possibilities)))
  364.       (if versions
  365.       (setq file-version-assoc-list (cons (cons fn versions)
  366.                           file-version-assoc-list)))))
  367.  
  368. (defun shape-trample-file-versions (ignore fn)
  369.   (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
  370.      base-version-list)
  371.     (and start-vn
  372.      (setq base-version-list    ; there was a base version to which 
  373.            (assoc (substring fn 0 start-vn)    ; this looks like a 
  374.               file-version-assoc-list))    ; subversion
  375.      (not (memq (string-to-int (substring fn (+ 2 start-vn)))
  376.             base-version-list))    ; this one doesn't make the cut
  377.      (shape-flag-this-line-for-DEATH))))
  378.  
  379. (defun shape-flag-this-line-for-DEATH ()
  380.   (beginning-of-line)
  381.   (delete-char 1)
  382.   (insert "D"))
  383.  
  384. (defun shape-rename-file (to-file)
  385.   "Rename this file to TO-FILE."
  386.   (interactive "FRename to: ")
  387.   (setq to-file (expand-file-name to-file))
  388.   (rename-file (shape-get-filename) to-file)
  389.   (let ((buffer-read-only nil))
  390.     (beginning-of-line)
  391.     (delete-region (point) (progn (forward-line 1) (point)))
  392.     (setq to-file (expand-file-name to-file))
  393.     (shape-add-entry (file-name-directory to-file)
  394.              (file-name-nondirectory to-file))))
  395.  
  396. (defun shape-copy-file ()
  397.   "Copy this file to TO-FILE."
  398.   (interactive)
  399.   (let ((from-file (shape-get-filename t)))
  400.   (if (file-AFS-p (shape-get-filename t))
  401.       (message "Can't copy saved files")
  402.     (setq to-file (read-string (concat "Copy " from-file " to: ")))
  403.     (copy-file (shape-get-filename) to-file)
  404.     (setq to-file (expand-file-name to-file))
  405.     (shape-add-entry (file-name-directory to-file)
  406.              (file-name-nondirectory to-file)))))
  407.  
  408. (defun shape-add-entry (directory filename)
  409.   ;; If tree shape is implemented, this function will have to do
  410.   ;; something smarter with the directory.  Currently, just check
  411.   ;; default directory, if same, add the new entry at point.  With tree
  412.   ;; shape, should call 'shape-current-directory' or similar.  Note
  413.   ;; that this adds the entry 'out of order' if files sorted by time,
  414.   ;; etc.
  415.   (if (string-equal directory default-directory)
  416.       (let ((buffer-read-only nil))
  417.     (beginning-of-line)
  418.     (if (file-AFS-p filename)
  419.         (call-process "vl" nil t nil
  420.               shape-listing-switches
  421.               (concat directory filename))
  422.       (call-process "vl" nil t nil shape-listing-switches
  423.             "-sb" (concat directory filename)))
  424.     (forward-line -1)
  425.     (insert "  ")
  426.     (shape-move-to-filename)
  427.     (let* ((beg (point))
  428.            (end (progn (end-of-line) (point))))
  429.       (setq filename (buffer-substring beg end))
  430.       (delete-region beg end)
  431.       (insert (file-name-nondirectory filename)))
  432.     (beginning-of-line))))
  433.  
  434. (defun shape-chgrp (group)
  435.   "Change group of this file."
  436.   (interactive "sChange to Group: ")
  437.   (let ((buffer-read-only nil)
  438.     (file (shape-get-filename)))
  439.     (call-process "/bin/chgrp" nil nil nil group file)
  440.     (shape-redisplay file)))
  441.  
  442. (defun shape-redisplay (file)
  443.   "Redisplay this line."
  444.   (beginning-of-line)
  445.   (delete-region (point) (progn (forward-line 1) (point)))
  446.   (if file (shape-add-entry (file-name-directory    file)
  447.                 (file-name-nondirectory file)))
  448.   (shape-move-to-filename))
  449.  
  450. (defun shape-do-deletions ()
  451.   "In shape, delete the files flagged for deletion."
  452.   (interactive)
  453.   (let (delete-list answer)
  454.     (save-excursion
  455.      (goto-char 1)
  456.      (while (re-search-forward "^D" nil t)
  457.        (setq delete-list
  458.          (cons (cons (shape-get-filename t) (1- (point)))
  459.            delete-list))))
  460.     (if (null delete-list)
  461.     (message "(No deletions requested)")
  462.       (save-window-excursion
  463.        (switch-to-buffer " *Deletions*")
  464.        (erase-buffer)
  465.        (setq fill-column 70)
  466.        (let ((l (reverse delete-list)))
  467.      ;; Files should be in forward order for this loop.
  468.      (while l
  469.        (if (> (current-column) 59)
  470.            (insert ?\n)
  471.          (or (bobp)
  472.          (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
  473.        (insert (car (car l)))
  474.        (setq l (cdr l))))
  475.        (goto-char (point-min))
  476.        (setq answer (yes-or-no-p "Delete these files? ")))
  477.       (if answer
  478.       (let ((l delete-list)
  479.         failures)
  480.         ;; Files better be in reverse order for this loop!
  481.         ;; That way as changes are made in the buffer
  482.         ;; they do not shift the lines still to be changed.
  483.         (while l
  484.           (goto-char (cdr (car l)))
  485.           (let ((buffer-read-only nil))
  486.         (condition-case ()
  487.             (progn (shape-delete-file (concat default-directory
  488.                               (car (car l))))
  489.                (delete-region (point)
  490.                       (progn (forward-line 1) (point))))
  491.           
  492.           (error (delete-char 1)
  493.              (insert " ")
  494.              (setq failures (cons (car (car l)) failures)))))
  495.           (setq l (cdr l)))
  496.         (if failures
  497.         (message "Deletions failed: %s"
  498.              (prin1-to-string failures))))))))
  499.  
  500.  
  501. (defun shape-vcat()
  502.   "retrieve and old version and display it."
  503.   (interactive)
  504.   (setq vcat-buffer (create-file-buffer (shape-get-filename)))
  505.   (call-process shape-vcat-command nil vcat-buffer nil "-q" (shape-get-filename))
  506.   (message "Restoring %s ..." (shape-get-filename t))
  507.   (view-buffer vcat-buffer)
  508.   (kill-buffer vcat-buffer)
  509. )
  510.  
  511. (defun shape-vlog()
  512.   "Display logentry for a particular version or entire history."
  513.   (interactive)
  514.   (if (file-directory-p (shape-get-filename))
  515.       (error "Directories don't have any log-entries")
  516.     (if (file-folded-p (shape-get-filename))
  517.     (progn 
  518.       (setq history-filename (substring (shape-get-filename) 0 -3))
  519.       (setq msg-string 
  520.         (concat "History log for " history-filename)))
  521.       (if (file-AFS-p (shape-get-filename))
  522.       (progn (setq history-filename (shape-get-filename))
  523.          (setq msg-string (concat "Log entry for " history-filename)))
  524.     (setq history-filename (shape-get-filename))
  525.     (setq msg-string (concat "History log for " history-filename))))
  526.  
  527.     (setq vlog-buffer (create-file-buffer msg-string))
  528.     (call-process shape-vlog-command nil vlog-buffer 
  529.           nil history-filename)
  530.     (message (concat "Viewing " msg-string))
  531.     (sit-for 2)
  532.     (setq old-view-hook view-hook view-hook '(beginning-of-buffer))
  533.     (view-buffer vlog-buffer)
  534.     (setq view-hook old-view-hook)
  535.     (kill-buffer vlog-buffer))
  536.   )
  537.  
  538. (defun shape-vadm (vadm-input)
  539.   "Perform vadm features."
  540.   (interactive "svadm: ")
  541.   (let ((buffer-read-only nil)
  542.     (file (shape-get-filename)))
  543.     (call-process shape-vadm-command nil nil nil "-q" vadm-input file)
  544.     (shape-redisplay file)))
  545.  
  546. (defun shape-vadm-promote()
  547.   "Performs vadm -promote."
  548.   (interactive)
  549.   (let ((buffer-read-only nil)
  550.     (file (shape-get-filename t))
  551.     (file2 (shape-get-filename)))
  552.     (if (not (file-AFS-p file))
  553.     (message "Can't promote busy file or directory %s" file)
  554.       (message "Promoting %s ..." file)
  555.       (call-process shape-vadm-command nil nil nil "-q" "-promote" file2)
  556.       (sit-for 1 t)
  557.       (shape-redisplay file2)
  558.       (message "Done."))))
  559.  
  560. (defun shape-vadm-unpromote()
  561.   "Performs vadm -unpromote."
  562.   (interactive)
  563.   (let ((buffer-read-only nil)
  564.     (file (shape-get-filename t))
  565.     (file2 (shape-get-filename)))
  566.     (if (not (file-AFS-p file))
  567.     (message "Can't unpromote busy file or directory %s" file)
  568.       (message "Unpromoting %s ..." file)
  569.       (call-process shape-vadm-command nil nil nil "-q" "-unpromote" file2)
  570.       (sit-for 1 t)
  571.       (shape-redisplay file2)
  572.       (message "Done."))))
  573.  
  574. (defun shape-vadm-change-mode()
  575.   "Performs vadm -chmod."
  576.   (interactive)
  577.   (let ((buffer-read-only nil)
  578.     (file (shape-get-filename t))
  579.     (file2 (shape-get-filename)))
  580.     (setq input (read-string (concat "Change mode of " file " to: ")))
  581.     (if (file-AFS-p file2)
  582.     (call-process shape-vadm-command nil nil nil "-q" "-chmod" input file2)
  583.       (call-process "/bin/chmod" nil nil nil input file2))
  584.     (shape-redisplay file2)
  585.     (message "Done.")))
  586.  
  587. (defun shape-vadm-change-author()
  588.   "Performs vadm -chaut."
  589.   (interactive)
  590.   (let ((buffer-read-only nil)
  591.     (file (shape-get-filename t))
  592.     (file2 (shape-get-filename)))
  593.     (setq input (read-string (concat "Change author of " file " to: ")))
  594.     (call-process shape-vadm-command nil nil nil "-q" "-chaut" input file2)
  595.     (shape-redisplay file2)
  596.     (message "Done.")))
  597.  
  598.  
  599. (defun shape-vadm-change-owner()
  600.   "Performs vadm -chown."
  601.   (interactive)
  602.   (let ((buffer-read-only nil)
  603.     (file (shape-get-filename t))
  604.     (file2 (shape-get-filename)))
  605.     (setq input (read-string (concat "Change owner of " file " to: ")))
  606.     (call-process shape-vadm-command nil nil nil "-q" "-chown" input file2)
  607.     (shape-redisplay file2)
  608.     (message "Done.")))
  609.  
  610.  
  611. (defun shape-save ()
  612.   "saves a file via the save command."
  613.   (interactive)
  614.   (save-excursion
  615.   (let ((buffer-read-only nil)
  616.     (file (shape-get-filename))
  617.     (file2 (shape-get-filename t)))
  618.   (if (or (file-AFS-p file) (file-DIR-p))
  619.       (message "This file not a busy file or a directory")
  620.     (if (y-or-n-p "Describe this document or changes? ")
  621.     (progn 
  622.       (setq descfile (make-temp-name "/tmp/save"))
  623.       (shape-get-description descfile)
  624.       (message "Saving file %s" file2)
  625.       (call-process shape-save-command nil t nil "-f" "-q" "-t"
  626.             descfile file)
  627.       (delete-file descfile)
  628.       (shape-insert-new-version file2))
  629.       (message "Saving file %s" file2)
  630.       (call-process shape-save-command nil t nil "-f" "-q" file)
  631.       (shape-insert-new-version file2)
  632.       (while (search-forward file2 nil t)))))))
  633.  
  634. (defun shape-submit ()
  635.   "submit a file via the submit command."
  636.   (interactive)
  637.   (save-excursion
  638.   (let ((buffer-read-only nil)
  639.     (file (shape-get-filename))
  640.     (file2 (shape-get-filename t)))
  641.   (if (or (file-AFS-p file) (file-DIR-p))
  642.       (message "This file not a busy file or a directory")
  643.     (if (y-or-n-p "Describe this document or changes? ")
  644.     (progn 
  645.       (setq descfile (make-temp-name "/tmp/save"))
  646.       (shape-get-description descfile)
  647.       (message "Submitting file %s" file2)
  648.       (call-process shape-submit-command nil t nil "-f" "-q" "-t"
  649.             descfile file)
  650.       (delete-file descfile)
  651.       (revert-buffer))
  652.       (message "Submitting file %s" file2)
  653.       (call-process shape-submit-command nil t nil "-f" "-q" file)
  654.       (revert-buffer)
  655.       )))))
  656.  
  657. (defun shape-retrv()
  658.   "retrieves a version via the rtrv command."
  659.   (interactive)
  660.   (save-excursion
  661.     (let ((buffer-read-only nil))
  662.       (setq file (shape-get-filename t))
  663.       (setq file2 (substring file 0 (string-match "\\\[" file)))
  664.       (if (not (file-AFS-p file))
  665.       (message "This file is not saved file")
  666.     (if (file-exists-p file2)
  667.         (progn
  668.           (if (y-or-n-p (concat "Writable busy version of "
  669.                     file2
  670.                     " exists! Overwrite it?"))
  671.           (progn
  672.             (call-process shape-retrv-command nil nil "-f" "-q" file)
  673.             (shape-redisplay file2)))))))))
  674.  
  675. (defun shape-compare()
  676.   "compares two versions with diff and puts output into a view buffer."
  677.   (interactive)
  678.   (save-excursion
  679. ;    (local-set-key "^X^@" 'shape-compare)
  680.     (setq shape-buffer1 nil)
  681.     (setq shape-buffer2 nil)
  682.     (if (eq shape-compare-file1 nil)
  683.     (progn
  684.       (if (or (file-DIR-p) (file-folded-p (shape-get-filename t)))
  685.           (message "Cant't compare directories or folded files")
  686.         (defvar shape-compare-file1 nil)
  687.         (setq shape-compare-file1 (shape-get-filename t))
  688.         (message "Compare %s with ? \(goto file2 and hit C again\)"
  689.              shape-compare-file1)
  690.         (shape-flag-file-compare "<")))
  691.       
  692.       (setq shape-compare-file2 (shape-get-filename t))
  693.       (if (or (file-DIR-p) (file-folded-p shape-compare-file2))
  694.       (message "Cant't compare directories or folded files")
  695.     (shape-flag-file-compare ">")
  696.     (if (file-AFS-p shape-compare-file1)
  697.         (progn
  698.           (setq shape-buffer1 (create-file-buffer shape-compare-file1))
  699.           (call-process shape-vcat-command nil shape-buffer1 nil
  700.                 "-q" shape-compare-file1)
  701.           (setq shape-compare-file1 (concat "/tmp/" shape-compare-file1)))
  702.       nil)
  703.  
  704.     (if (file-AFS-p shape-compare-file2)
  705.         (progn
  706.           (setq shape-buffer2 (create-file-buffer shape-compare-file2))
  707.           (call-process shape-vcat-command nil shape-buffer2 nil
  708.                 "-q" shape-compare-file2)
  709.           (setq shape-compare-file2 (concat "/tmp/" shape-compare-file2)))
  710.       nil)
  711.     (setq diff-buffer (create-file-buffer "diff"))
  712.     (if shape-buffer1
  713.         (progn
  714.           (save-excursion
  715.         (set-buffer shape-buffer1)
  716.         (write-file (concat "/tmp/" shape-compare-file1))))
  717.       nil)
  718.     (if shape-buffer2
  719.         (progn
  720.           (save-excursion
  721.         (set-buffer shape-buffer2)
  722.         (write-file (concat "/tmp/" shape-compare-file2))))
  723.       nil)
  724.     (message "Comparing %s with %s" shape-compare-file1
  725.          shape-compare-file2)
  726.     (sit-for 3 t)
  727.     (call-process "diff" nil diff-buffer nil shape-compare-file1
  728.               shape-compare-file2)
  729.     (view-buffer diff-buffer)
  730.     (if (file-AFS-p shape-compare-file1)
  731.         (progn
  732.           (delete-file shape-compare-file1)
  733.           (kill-buffer shape-buffer1))
  734.       nil)
  735.     (if (file-AFS-p shape-compare-file2)
  736.         (progn
  737.           (delete-file shape-compare-file2)
  738.           (kill-buffer shape-buffer2))
  739.       nil)
  740.     (kill-buffer diff-buffer)
  741.     (setq shape-compare-file1 nil)
  742.     (shape-unflag-file-compare)
  743.     ;(local-unset-key "^X^@")
  744.     ))))
  745.  
  746.  
  747. (defun shape-fold()
  748.   "Compresses output; files with versions are displayed with <name>[*]."
  749.   (interactive)
  750.   (save-excursion
  751.     (let ((buffer-read-only nil))
  752.       (if (y-or-n-p "Fold whole directory? ")
  753.       (progn
  754.         (message "Folding directory ...")
  755.         (goto-char (point-min))
  756.         (while (search-forward "[" nil t)
  757.           (setq filename (shape-get-filename t t))
  758.           (kill-line 1)
  759.           (insert "*]")
  760.           (newline)
  761.           (setq filename2 (substring
  762.                 filename 0 (string-match "\\\[" filename)))
  763.           (setq filename2 (concat filename2 "\\\["))
  764.           (delete-matching-lines filename2))
  765.         (message "Done."))
  766.     (setq filename (shape-get-filename t))
  767.     (if (file-AFS-p filename)
  768.         (progn
  769.           (setq filename2 (substring
  770.                    filename 0 (string-match "\\\[" filename)))
  771.           (goto-char (point-min))
  772.           (search-forward (concat filename2 "["))
  773.           (beginning-of-line)
  774.           (search-forward "[" nil t)
  775.           (kill-line 1)
  776.           (insert "*]")
  777.           (newline)
  778.           (delete-matching-lines filename2)
  779.           (sit-for 0)
  780.           (message "Done."))
  781.       (message "No version: %s" filename))))))
  782.  
  783. (defun shape-unfold()
  784.   "Expands folded entries."
  785.   (interactive)
  786.   (save-excursion
  787.     (let ((buffer-read-only nil))
  788.       (if (y-or-n-p "Unfold whole directory? ")
  789.       (progn
  790.         (message "Unfolding directory ...")
  791.         (revert-buffer)
  792.         (message "Done."))
  793.     (if (equal (substring (shape-get-filename t)
  794.                   -3 (length (shape-get-filename t))) "[*]")
  795.         (progn
  796.           (setq filename (substring (shape-get-filename t) 0 -3))
  797.           (message "Unfolding %s ..." filename)
  798.           (beginning-of-line)
  799.           (kill-line 1)
  800.           (call-process shape-vl-command nil t nil shape-listing-switches
  801.                 "-ss" "-sp" "-sP" "-sa" "-sf" filename)
  802.           (shape-update-buffer)
  803.           (sit-for 0)
  804.           (message "Done."))
  805.       (message "File not folded."))))))
  806.           
  807.  
  808. (defun file-AFS-p(name)
  809.   "decides whether a file is an AFS file or not (']' as last char)."
  810.   (if (string-match "]" name) t nil))
  811.  
  812. (defun file-DIR-p()
  813.   (beginning-of-line)
  814.   (looking-at "  d"))
  815.  
  816. (defun file-folded-p(file)
  817.   (if (equal (substring file -3 (length file)) "[*]")
  818.       t
  819.     nil))
  820.  
  821. (defun shape-insert-new-version (file)
  822.   "update buffer after save command."
  823.   (interactive)
  824.   (let ((buffer-read-only nil))
  825.     (while (search-forward file nil t))
  826.     (forward-line)
  827.     (beginning-of-line)
  828.     (call-process shape-vl-command nil t nil shape-listing-switches "-y"
  829.           (concat default-directory file))
  830.     (forward-line -1)
  831.     (insert "  ")))
  832.  
  833.  
  834. (defun shape-get-description (descfile)
  835.   "read the description for the save command."
  836.   (save-excursion
  837.   (find-file descfile)
  838.   (switch-to-buffer descfile)
  839.   (message "To stop type CNTL-C CNTL-C")
  840.   (local-set-key "^C^C" 'shape-finish-edit)
  841.   (recursive-edit)
  842.   (write-file descfile)
  843.   (kill-buffer (current-buffer))))
  844.  
  845. (defun shape-finish-edit ()
  846.   (interactive)
  847.   (throw 'exit nil))
  848.    
  849.  
  850. (defun shape-delete-file (file)
  851.   (if (file-AFS-p file)
  852.       (call-process shape-vadm-command nil nil nil "-delete" file)
  853.     (delete-file file)))
  854.  
  855. (defun shape-flag-file-compare(mark)
  856.   (let ((buffer-read-only nil))
  857.     (save-excursion
  858.       (beginning-of-line)
  859.       (delete-char 1)
  860.       (insert mark)
  861.       (sit-for 0))))
  862.  
  863. (defun shape-unflag-file-compare()
  864.   (let ((buffer-read-only nil))
  865.     (save-excursion
  866.       (beginning-of-buffer)
  867.       (re-search-forward "^[><]")
  868.       (beginning-of-line)
  869.       (delete-char 1)
  870.       (insert " ")
  871.       (re-search-forward "^[><]")
  872.       (beginning-of-line)
  873.       (delete-char 1)
  874.       (insert " "))))
  875.       
  876. (defun shape-update-buffer()
  877.   "Updates buffer after unfold."
  878.   (interactive)
  879.   (save-excursion
  880.   (goto-char (point-min))
  881.   (while (re-search-forward "^-" nil t)
  882.     (beginning-of-line)
  883.     (insert "  "))))
  884.  
  885. (defun shape-execute()
  886.   "sets compile command to shape -k."
  887.   (interactive)
  888.   (save-excursion
  889.     (setq filename (shape-get-filename t t))
  890.     (setq shapefile nil)
  891.     (setq promptstring nil)
  892.     (setq basename (substring
  893.              filename 0 (string-match "\\\[" filename)))
  894.     (if (or (equal basename "Shapefile")
  895.         (equal basename "shapefile")
  896.         (equal basename "Makefile")
  897.         (equal basename "makefile")
  898.         (equal filename "Shapefile")
  899.         (equal filename "shapefile")
  900.         (equal filename "Makefile")
  901.         (equal filename "makefile"))
  902.     (setq shapefile filename)
  903.       (setq shapefile nil))
  904.     (if (file-folded-p filename)
  905.     (setq shapefile nil)
  906.       nil)
  907.     (if (equal shapefile nil)
  908.     (setq promptstring "shape -k ")
  909.       (if (file-AFS-p filename)
  910.         (setq promptstring (concat "vcat " "\""
  911.                        filename
  912.                        "\"" " | shape -f - "))
  913.     (setq promptstring (concat "shape -k -f " filename " "))))
  914.     (setq input (read-string "shape: " promptstring))
  915.     (if (equal input nil)
  916.     (compile promptstring)
  917.       (compile input))))
  918.  
  919. (defvar shape-wish-address "shape-wishes@coma.UUCP" "The mail address to report a wish.")
  920. (defvar shape-bug-address "shape-bugs@coma.UUCP" "The mail address to report a bug.")
  921. (defvar shape-bug-description "Description:\n\nRepeat-By:\n\nFix:\n\nShape Toolkit version:\n\n" 
  922.   "Formular to report a bug")
  923.  
  924. (defun shape-mail-bugs () 
  925.   (interactive)
  926.   (mail nil shape-bug-address)
  927.   (goto-char (point-min))
  928.   (beginning-of-next-line)
  929.   (insert "Index: <tool>/<source> <confid>\n")
  930.   (goto-char (point-max))
  931.   (insert shape-bug-description "\n")
  932.   (mail-position-on-field "Subject")
  933.   (message (substitute-command-keys "Type \\[mail-send] to send bug report.")))
  934.  
  935. (defun shape-mail-wishes ()
  936.   (interactive)
  937.   (mail nil shape-wish-address)
  938.   (mail-position-on-field "Subject")
  939.   (message (substitute-command-keys "Type \\[mail-send] to send wish report.")))
  940.  
  941.  
  942. (defun shape-execute-vl()
  943.   "executes vl reading parameters from the minibuffer."
  944.   (interactive)
  945.   (setq input (read-string "vl: "))
  946.   (shell-command (concat shape-vl-command " " input)))
  947.   
  948. (defun shape-execute-save()
  949.   "executes save reading parameters from the minibuffer."
  950.   (interactive)
  951.   (setq input (read-string "save: "))
  952.   (shell-command (concat shape-save-command " " input)))
  953.  
  954. (defun shape-execute-submit()
  955.   "executes submit reading parameters from the minibuffer."
  956.   (interactive)
  957.   (setq input (read-string "sbmt: "))
  958.   (shell-command (concat shape-submit-command " " input)))
  959.  
  960. (defun shape-execute-retrv()
  961. "executes retrv reading parameters from the minibuffer."
  962.   (interactive)
  963.   (setq input (read-string "retrv: "))
  964.   (shell-command (concat shape-retrv-command " " input)))
  965.   
  966. (defun shape-execute-vadm()
  967. "executes vadm reading parameters from the minibuffer."
  968.   (interactive)
  969.   (setq input (read-string "vadm: "))
  970.   (shell-command (concat shape-vadm-command " " input)))
  971.  
  972. (defun shape-execute-vcat()
  973. "executes vcat reading parameters from the minibuffer."
  974.   (interactive)
  975.   (setq input (read-string "vcat: "))
  976.   (shell-command (concat shape-vcat-command " " input)))
  977.  
  978.  
  979. (defun shape-execute-vlog()
  980. "executes vlog reading parameters from the minibuffer."
  981.   (interactive)
  982.   (setq input (read-string "vlog: "))
  983.   (shell-command (concat shape-vlog-command " " input)))
  984.  
  985.