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