|
0
|
1 ;; sccs.el -- easy-to-use SCCS control from within Emacs
|
|
|
2 ;; @(#)sccs.el 3.5
|
|
|
3
|
|
|
4 ;; This file is part of GNU Emacs.
|
|
|
5
|
|
|
6 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
7 ;; but WITHOUT ANY WARRANTY. No author or distributor
|
|
|
8 ;; accepts responsibility to anyone for the consequences of using it
|
|
|
9 ;; or for whether it serves any particular purpose or works at all,
|
|
|
10 ;; unless he says so in writing. Refer to the GNU Emacs General Public
|
|
|
11 ;; License for full details.
|
|
|
12
|
|
|
13 ;; Everyone is granted permission to copy, modify and redistribute
|
|
|
14 ;; GNU Emacs, but only under the conditions described in the
|
|
|
15 ;; GNU Emacs General Public License. A copy of this license is
|
|
|
16 ;; supposed to have been given to you along with GNU Emacs so you
|
|
|
17 ;; can know your rights and responsibilities. It should be in a
|
|
|
18 ;; file named COPYING. Among other things, the copyright notice
|
|
|
19 ;; and this notice must be preserved on all copies.
|
|
|
20 ;;;
|
|
|
21 ;;; Synched up with: Not in FSF.
|
|
|
22 ;;; #### Chuck -- I say remove this piece of crap! Use VC instead.
|
|
|
23
|
|
|
24 ;;; Author: Eric S. Raymond (eric@snark.thyrsus.com).
|
|
|
25 ;;;
|
|
|
26 ;;; It is distantly derived from an rcs mode written by Ed Simpson
|
|
|
27 ;;; ({decvax, seismo}!mcnc!duke!dukecdu!evs) in years gone by
|
|
|
28 ;;; and revised at MIT's Project Athena.
|
|
|
29 ;;;
|
|
|
30 ;;; Modified: Made to work for Lucid Emacs by persons who don't know SCCS.
|
|
|
31 ;;; Modified: Ben Wing (Ben.Wing@eng.sun.com) -- fixed up and redid menus
|
|
|
32 ;;;
|
|
|
33
|
|
|
34 ;; User options
|
|
|
35
|
|
|
36 (defvar sccs-bin-directory nil
|
|
|
37 "*Directory that holds the SCCS executables.
|
|
|
38 Initialized automatically the first time you execute an SCCS command,
|
|
|
39 if not already set.")
|
|
|
40
|
|
|
41 (defvar sccs-max-log-size 510
|
|
|
42 "*Maximum allowable size of an SCCS log message.")
|
|
|
43 (defvar sccs-diff-command '("diff" "-c")
|
|
|
44 "*The command/flags list to be used in constructing SCCS diff commands.")
|
|
|
45 (defvar sccs-headers-wanted '("\%\W\%")
|
|
|
46 "*SCCS header keywords to be inserted when sccs-insert-header is executed.")
|
|
|
47 (defvar sccs-insert-static t
|
|
|
48 "*Insert a static character string when inserting SCCS headers in C mode.")
|
|
|
49 (defvar sccs-mode-expert nil
|
|
|
50 "*Treat user as expert; suppress yes-no prompts on some things.")
|
|
|
51
|
|
|
52 ;; Vars the user doesn't need to know about.
|
|
|
53
|
|
|
54 (defvar sccs-log-entry-mode nil)
|
|
|
55 (defvar sccs-current-major-version nil)
|
|
|
56
|
|
|
57 ;; Some helper functions
|
|
|
58
|
|
|
59 (defun sccs-name (file &optional letter)
|
|
|
60 "Return the sccs-file name corresponding to a given file."
|
|
|
61 (format "%sSCCS/%s.%s"
|
|
|
62 (concat (file-name-directory (expand-file-name file)))
|
|
|
63 (or letter "s")
|
|
|
64 (concat (file-name-nondirectory (expand-file-name file)))))
|
|
|
65
|
|
|
66 (defun sccs-lock-info (file index)
|
|
|
67 "Return the nth token in a file's SCCS-lock information."
|
|
|
68 (let
|
|
|
69 ((pfile (sccs-name file "p")))
|
|
|
70 (and (file-exists-p pfile)
|
|
|
71 (save-excursion
|
|
|
72 (find-file pfile)
|
|
|
73 (auto-save-mode nil)
|
|
|
74 (goto-char (point-min))
|
|
|
75 (replace-string " " "\n")
|
|
|
76 (goto-char (point-min))
|
|
|
77 (forward-line index)
|
|
|
78 (prog1
|
|
|
79 (buffer-substring (point) (progn (end-of-line) (point)))
|
|
|
80 (set-buffer-modified-p nil)
|
|
|
81 (kill-buffer (current-buffer)))
|
|
|
82 )
|
|
|
83 )
|
|
|
84 )
|
|
|
85 )
|
|
|
86
|
|
|
87 (defun sccs-locking-user (file)
|
|
|
88 "Return the name of the person currently holding a lock on FILE.
|
|
|
89 Return nil if there is no such person."
|
|
|
90 (sccs-lock-info file 2)
|
|
|
91 )
|
|
|
92
|
|
|
93 (defun sccs-locked-revision (file)
|
|
|
94 "Return the revision number currently locked for FILE, nil if none such."
|
|
|
95 (sccs-lock-info file 1)
|
|
|
96 )
|
|
|
97
|
|
|
98 (defmacro error-occurred (&rest body)
|
|
|
99 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
|
|
|
100
|
|
|
101 ;; There has *got* to be a better way to do this...
|
|
|
102 (defmacro chmod (perms file)
|
|
|
103 (list 'call-process "chmod" nil nil nil perms file))
|
|
|
104
|
|
|
105 (defun sccs-save-vars (sid)
|
|
|
106 (save-excursion
|
|
|
107 (find-file "SCCS/emacs-vars.el")
|
|
|
108 (erase-buffer)
|
|
|
109 (insert "(setq sccs-current-major-version \"" sid "\")")
|
|
|
110 (basic-save-buffer)
|
|
|
111 )
|
|
|
112 )
|
|
|
113
|
|
|
114 (defun sccs-load-vars ()
|
|
|
115 (if (error-occurred (load-file "SCCS/emacs-vars.el"))
|
|
|
116 (setq sccs-current-major-version "1"))
|
|
|
117 )
|
|
|
118
|
|
|
119 (defun sccs-init-bin-directory ()
|
|
|
120 (setq sccs-bin-directory
|
|
|
121 (cond ((file-executable-p "/usr/sccs/unget") "/usr/sccs")
|
|
|
122 ((file-executable-p "/usr/bin/unget") "/usr/bin")
|
|
|
123 ((file-directory-p "/usr/sccs") "/usr/sccs")
|
|
|
124 ((file-directory-p "/usr/bin/sccs") "/usr/bin/sccs")
|
|
|
125 (t "/usr/bin"))))
|
|
|
126
|
|
|
127 ;; The following functions do most of the real work
|
|
|
128
|
|
|
129 (defun sccs-get-version (file sid)
|
|
|
130 "For the given FILE, retrieve a copy of the version with given SID.
|
|
|
131 The text is retrieved into a tempfile. Return the tempfile name, or nil
|
|
|
132 if no such version exists."
|
|
|
133 (let (oldversion vbuf)
|
|
|
134 (setq oldversion (sccs-name file (or sid "new")))
|
|
|
135 (setq vbuf (create-file-buffer oldversion))
|
|
|
136 (prog1
|
|
|
137 (if (not (error-occurred
|
|
|
138 (sccs-do-command vbuf "get" file
|
|
|
139 (and sid (concat "-r" sid))
|
|
|
140 "-p" "-s")))
|
|
|
141 (save-excursion
|
|
|
142 (set-buffer vbuf)
|
|
|
143 (write-region (point-min) (point-max) oldversion t 0)
|
|
|
144 oldversion)
|
|
|
145 )
|
|
|
146 (kill-buffer vbuf)
|
|
|
147 )
|
|
|
148 )
|
|
|
149 )
|
|
|
150
|
|
|
151 (defun sccs-mode-line (file)
|
|
|
152 "Set the mode line for an SCCS buffer.
|
|
|
153 FILE is the file being visited to put in the modeline."
|
|
|
154 (setq mode-line-process
|
|
|
155 (if (file-exists-p (sccs-name file "p"))
|
|
|
156 (format " <SCCS: %s>" (sccs-locked-revision file))
|
|
|
157 ""))
|
|
|
158
|
|
|
159 ; force update of frame
|
|
|
160 (save-excursion (set-buffer (other-buffer)))
|
|
|
161 (sit-for 0)
|
|
|
162 )
|
|
|
163
|
|
|
164 (defun sccs-do-command (buffer command file &rest flags)
|
|
|
165 " Execute an SCCS command, notifying the user and checking for errors."
|
|
|
166 (setq file (expand-file-name file))
|
|
|
167 (message (format "Running %s on %s..." command file))
|
|
|
168 (or sccs-bin-directory (sccs-init-bin-directory))
|
|
|
169 (let ((status
|
|
|
170 (save-window-excursion
|
|
|
171 (set-buffer (get-buffer-create buffer))
|
|
|
172 (erase-buffer)
|
|
|
173 (while (and flags (not (car flags)))
|
|
|
174 (setq flags (cdr flags)))
|
|
|
175 (setq flags (append flags (and file (list (sccs-name file)))))
|
|
|
176 (let ((default-directory (file-name-directory (or file "./")))
|
|
|
177 (exec-path (cons sccs-bin-directory exec-path)))
|
|
|
178 (apply 'call-process command nil t nil flags)
|
|
|
179 )
|
|
|
180 (goto-char (point-max))
|
|
|
181 (previous-line 1)
|
|
|
182 (if (looking-at "ERROR")
|
|
|
183 (progn
|
|
|
184 (previous-line 1)
|
|
|
185 (print (cons command flags))
|
|
|
186 (next-line 1)
|
|
|
187 nil)
|
|
|
188 t))))
|
|
|
189 (if status
|
|
|
190 (message (format "Running %s...OK" command))
|
|
|
191 (pop-to-buffer buffer)
|
|
|
192 (error (format "Running %s...FAILED" command))))
|
|
|
193 (if file (sccs-mode-line file)))
|
|
|
194
|
|
|
195 (defun sccs-shell-command (command)
|
|
|
196 "Like shell-command except that the *Shell Command Output*buffer
|
|
|
197 is created even if the command does not output anything"
|
|
|
198 (shell-command command)
|
|
|
199 (get-buffer-create "*Shell Command Output*"))
|
|
|
200
|
|
|
201 (defun sccs-tree-walk (func &rest optargs)
|
|
|
202 "Apply FUNC to each SCCS file under the default directory.
|
|
|
203 If present, OPTARGS are also passed."
|
|
|
204 (sccs-shell-command (concat "/bin/ls -1 " default-directory "SCCS/s.*"))
|
|
|
205 (set-buffer "*Shell Command Output*")
|
|
|
206 (goto-char (point-min))
|
|
|
207 (replace-string "SCCS/s." "")
|
|
|
208 (goto-char (point-min))
|
|
|
209 (if (eobp)
|
|
|
210 (error "No SCCS files under %s" default-directory))
|
|
|
211 (while (not (eobp))
|
|
|
212 (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
|
|
|
213 (apply func file optargs)
|
|
|
214 )
|
|
|
215 (forward-line 1)
|
|
|
216 )
|
|
|
217 )
|
|
|
218
|
|
|
219 (defun sccs-init ()
|
|
|
220 (or (current-local-map) (use-local-map (make-sparse-keymap)))
|
|
|
221 (condition-case nil
|
|
|
222 ;; If C-c s is already defined by another mode, then we
|
|
|
223 ;; will get an error. In that case, just don't do anything.
|
|
|
224 (progn
|
|
|
225 (define-key (current-local-map) "\C-cs?" 'describe-mode)
|
|
|
226 (define-key (current-local-map) "\C-csn" 'sccs)
|
|
|
227 (define-key (current-local-map) "\C-csm" 'sccs-register-file)
|
|
|
228 (define-key (current-local-map) "\C-csh" 'sccs-insert-headers)
|
|
|
229 (define-key (current-local-map) "\C-csd" 'sccs-revert-diff)
|
|
|
230 (define-key (current-local-map) "\C-csp" 'sccs-prs)
|
|
|
231 (define-key (current-local-map) "\C-csr" 'sccs-revert-buffer)
|
|
|
232 (define-key (current-local-map) "\C-cs\C-d" 'sccs-version-diff)
|
|
|
233 (define-key (current-local-map) "\C-cs\C-p" 'sccs-pending)
|
|
|
234 (define-key (current-local-map) "\C-cs\C-r" 'sccs-registered)
|
|
|
235 )
|
|
|
236 (error nil)))
|
|
|
237
|
|
|
238 ;; Here's the major entry point
|
|
|
239
|
|
|
240 (defun sccs (verbose)
|
|
|
241 "*Do the next logical SCCS operation on the file in the current buffer.
|
|
|
242 You must have an SCCS subdirectory in the same directory as the file being
|
|
|
243 operated on.
|
|
|
244 If the file is not already registered with SCCS, this does an admin -i
|
|
|
245 followed by a get -e.
|
|
|
246 If the file is registered and not locked by anyone, this does a get -e.
|
|
|
247 If the file is registered and locked by the calling user, this pops up a
|
|
|
248 buffer for creation of a log message, then does a delta -n on the file.
|
|
|
249 A read-only copy of the changed file is left in place afterwards.
|
|
|
250 If the file is registered and locked by someone else, an error message is
|
|
|
251 returned indicating who has locked it."
|
|
|
252 (interactive "P")
|
|
|
253 (sccs-init)
|
|
|
254 (if (buffer-file-name)
|
|
|
255 (let
|
|
|
256 (do-update revision owner
|
|
|
257 (file (buffer-file-name))
|
|
|
258 (sccs-file (sccs-name (buffer-file-name)))
|
|
|
259 (sccs-log-buf (get-buffer-create "*SCCS-Log*"))
|
|
|
260 (err-msg nil))
|
|
|
261
|
|
|
262 ;; if there is no SCCS file corresponding, create one
|
|
|
263 (if (not (file-exists-p sccs-file))
|
|
|
264 (progn
|
|
|
265 (sccs-load-vars)
|
|
|
266 (sccs-admin
|
|
|
267 file
|
|
|
268 (cond
|
|
|
269 (verbose (read-string "Initial SID: "))
|
|
|
270 ((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
|
|
|
271 (t sccs-current-major-version))
|
|
|
272 )
|
|
|
273 )
|
|
|
274 )
|
|
|
275
|
|
|
276 (cond
|
|
|
277
|
|
|
278 ;; if there is no lock on the file, assert one and get it
|
|
|
279 ((not (file-exists-p (sccs-name file "p")))
|
|
|
280 (progn
|
|
|
281 (sccs-get file t)
|
|
|
282 (revert-buffer nil t)
|
|
|
283 (sccs-mode-line file)
|
|
|
284 ))
|
|
|
285
|
|
|
286 ;; a checked-out version exists, but the user may not own the lock
|
|
|
287 ((not (string-equal
|
|
|
288 (setq owner (sccs-locking-user file)) (user-login-name)))
|
|
|
289 (error "Sorry, %s has that file checked out" owner))
|
|
|
290
|
|
|
291 ;; OK, user owns the lock on the file
|
|
|
292 (t (progn
|
|
|
293
|
|
|
294 ;; if so, give luser a chance to save before delta-ing.
|
|
|
295 (if (and (buffer-modified-p)
|
|
|
296 (or
|
|
|
297 sccs-mode-expert
|
|
|
298 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
299 (buffer-name)))))
|
|
|
300 (save-buffer))
|
|
|
301
|
|
|
302 (setq revision (sccs-locked-revision file))
|
|
|
303
|
|
|
304 ;; user may want to set nonstandard parameters
|
|
|
305 (if verbose
|
|
|
306 (if (or sccs-mode-expert (y-or-n-p
|
|
|
307 (format "SID: %s Change revision level? " revision)))
|
|
|
308 (setq revision (read-string "New revision level: "))))
|
|
|
309
|
|
|
310 ;; OK, let's do the delta
|
|
|
311 (if
|
|
|
312 ;; this excursion returns t if the new version was saved OK
|
|
|
313 (save-window-excursion
|
|
|
314 (pop-to-buffer (get-buffer-create "*SCCS*"))
|
|
|
315 (erase-buffer)
|
|
|
316 (set-buffer-modified-p nil)
|
|
|
317 (sccs-mode)
|
|
|
318 (message
|
|
|
319 "Enter log message. Type C-c C-c when done, C-c ? for help.")
|
|
|
320 (prog1
|
|
|
321 (and (not (error-occurred (recursive-edit)))
|
|
|
322 (not (error-occurred (sccs-delta file revision))))
|
|
|
323 (setq buffer-file-name nil)
|
|
|
324 (bury-buffer "*SCCS*")))
|
|
|
325
|
|
|
326 ;; if the save went OK do some post-checking
|
|
|
327 (if (buffer-modified-p)
|
|
|
328 (error
|
|
|
329 "Delta-ed version of file does not match buffer!")
|
|
|
330 (progn
|
|
|
331 ;; sccs-delta already turned off write-privileges on the
|
|
|
332 ;; file, let's not re-fetch it unless there's something
|
|
|
333 ;; in it that get would expand
|
|
|
334 ;;
|
|
|
335 ;; fooey on this. You always need to refetch the
|
|
|
336 ;; file; otherwise weirdness will ensue when you're
|
|
|
337 ;; trying to do a make. --bpw
|
|
|
338 ; (if (sccs-check-headers)
|
|
|
339 (sccs-get file nil)
|
|
|
340 (revert-buffer nil t)
|
|
|
341 (sccs-mode-line file)
|
|
|
342 (run-hooks 'sccs-delta-ok)
|
|
|
343 )
|
|
|
344 ))))))
|
|
|
345 (error "There is no file associated with buffer %s" (buffer-name))))
|
|
|
346
|
|
|
347 (defun sccs-insert-last-log ()
|
|
|
348 "*Insert the log message of the last SCCS check in at point."
|
|
|
349 (interactive)
|
|
|
350 (insert-buffer sccs-log-buf))
|
|
|
351
|
|
|
352 ;;; These functions help the sccs entry point
|
|
|
353
|
|
|
354 (defun sccs-get (file writeable)
|
|
|
355 "Retrieve a copy of the latest delta of the given file."
|
|
|
356 (sccs-do-command "*SCCS*" "get" file (if writeable "-e")))
|
|
|
357
|
|
|
358 (defun sccs-admin (file sid)
|
|
|
359 "Checks a file into sccs.
|
|
|
360 FILE is the unmodified name of the file. SID should be the base-level sid to
|
|
|
361 check it in under."
|
|
|
362 ; give a change to save the file if it's modified
|
|
|
363 (if (and (buffer-modified-p)
|
|
|
364 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
365 (buffer-name))))
|
|
|
366 (save-buffer))
|
|
|
367 (sccs-do-command "*SCCS*" "admin" file
|
|
|
368 (concat "-i" file) (concat "-r" sid))
|
|
|
369 (chmod "-w" file)
|
|
|
370 (if (sccs-check-headers)
|
|
|
371 (sccs-get file nil)) ;; expand SCCS headers
|
|
|
372 (revert-buffer nil t)
|
|
|
373 (sccs-mode-line file)
|
|
|
374 )
|
|
|
375
|
|
|
376 (defun sccs-delta (file &optional rev comment)
|
|
|
377 "Delta the file specified by FILE.
|
|
|
378 The optional argument REV may be a string specifying the new revision level
|
|
|
379 \(if nil increment the current level). The file is retained with write
|
|
|
380 permissions zeroed. COMMENT is a comment string; if omitted, the contents of
|
|
|
381 the current buffer up to point becomes the comment for this delta."
|
|
|
382 (if (not comment)
|
|
|
383 (progn
|
|
|
384 (goto-char (point-max))
|
|
|
385 (if (not (bolp)) (newline))
|
|
|
386 (newline)
|
|
|
387 (setq comment (buffer-substring (point-min) (1- (point)))))
|
|
|
388 )
|
|
|
389 (sccs-do-command "*SCCS*" "delta" file "-n"
|
|
|
390 (if rev (format "-r%s" rev))
|
|
|
391 (format "-y%s" comment))
|
|
|
392 (chmod "-w" file))
|
|
|
393
|
|
|
394 (defun sccs-delta-abort ()
|
|
|
395 "Abort an SCCS delta command."
|
|
|
396 (interactive)
|
|
|
397 (if (or sccs-mode-expert (y-or-n-p "Abort the delta? "))
|
|
|
398 (progn
|
|
|
399 (delete-window)
|
|
|
400 (error "Delta aborted")))
|
|
|
401 )
|
|
|
402
|
|
|
403 (defun sccs-log-exit ()
|
|
|
404 "Leave the recursive edit of an SCCS log message."
|
|
|
405 (interactive)
|
|
|
406 (if (< (buffer-size) sccs-max-log-size)
|
|
|
407 (progn
|
|
|
408 (copy-to-buffer sccs-log-buf (point-min) (point-max))
|
|
|
409 (exit-recursive-edit)
|
|
|
410 (delete-window))
|
|
|
411 (progn
|
|
|
412 (goto-char sccs-max-log-size)
|
|
|
413 (error
|
|
|
414 "Log must be less than %d characters. Point is now at char %d."
|
|
|
415 sccs-max-log-size sccs-max-log-size)))
|
|
|
416 )
|
|
|
417
|
|
|
418 ;; Additional entry points for examining version histories
|
|
|
419
|
|
|
420 (defun sccs-revert-diff (&rest flags)
|
|
|
421 "*Compare the version being edited with the last checked-in revision.
|
|
|
422 Or, if given a prefix argument, with another specified revision."
|
|
|
423 (interactive)
|
|
|
424 (let (old file)
|
|
|
425 (if
|
|
|
426 (setq old (sccs-get-version (buffer-file-name)
|
|
|
427 (and
|
|
|
428 current-prefix-arg
|
|
|
429 (read-string "Revision to compare against: "))
|
|
|
430 ))
|
|
|
431 (progn
|
|
|
432 (if (and (buffer-modified-p)
|
|
|
433 (or
|
|
|
434 sccs-mode-expert
|
|
|
435 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
436 (buffer-name)))))
|
|
|
437 (save-buffer))
|
|
|
438
|
|
|
439 (setq file (buffer-file-name))
|
|
|
440 (set-buffer (get-buffer-create "*SCCS*"))
|
|
|
441 (erase-buffer)
|
|
|
442 (apply 'call-process (car sccs-diff-command) nil t nil
|
|
|
443 (append (cdr sccs-diff-command) flags (list old) (list file)))
|
|
|
444 (set-buffer-modified-p nil)
|
|
|
445 (goto-char (point-min))
|
|
|
446 (delete-file old)
|
|
|
447 (if (equal (point-min) (point-max))
|
|
|
448 (message (format "No changes to %s since last get." file))
|
|
|
449 (pop-to-buffer "*SCCS*")
|
|
|
450 )
|
|
|
451 )
|
|
|
452 )
|
|
|
453 )
|
|
|
454 )
|
|
|
455
|
|
|
456 (defun sccs-prs ()
|
|
|
457 "*List the SCCS log of the current buffer in an emacs window."
|
|
|
458 (interactive)
|
|
|
459 (if (and buffer-file-name (file-exists-p (sccs-name buffer-file-name "s")))
|
|
|
460 (progn
|
|
|
461 (sccs-do-command "*SCCS*" "prs" buffer-file-name)
|
|
|
462 (pop-to-buffer (get-buffer-create "*SCCS*"))
|
|
|
463 )
|
|
|
464 (error "There is no SCCS file associated with this buffer")
|
|
|
465 )
|
|
|
466 )
|
|
|
467
|
|
|
468 (defun sccs-version-diff (file rel1 rel2)
|
|
|
469 "*For FILE, report diffs between two stored deltas REL1 and REL2 of it."
|
|
|
470 (interactive "fFile: \nsOlder version: \nsNewer version: ")
|
|
|
471 (if (string-equal rel1 "") (setq rel1 nil))
|
|
|
472 (if (string-equal rel2 "") (setq rel2 nil))
|
|
|
473 (set-buffer (get-buffer-create "*SCCS*"))
|
|
|
474 (erase-buffer)
|
|
|
475 (sccs-vdiff file rel1 rel2)
|
|
|
476 (set-buffer-modified-p nil)
|
|
|
477 (goto-char (point-min))
|
|
|
478 (if (equal (point-min) (point-max))
|
|
|
479 (message (format "No changes to %s between %s and %s." file rel1 rel2))
|
|
|
480 (pop-to-buffer "*SCCS*")
|
|
|
481 )
|
|
|
482 )
|
|
|
483
|
|
|
484 (defun sccs-vdiff (file rel1 rel2 &optional flags)
|
|
|
485 "Compare two deltas into the current buffer."
|
|
|
486 (let (vers1 vers2)
|
|
|
487 (and
|
|
|
488 (setq vers1 (sccs-get-version file rel1))
|
|
|
489 (setq vers2 (if rel2 (sccs-get-version file rel2) file))
|
|
|
490 ; (prog1
|
|
|
491 ; (save-excursion
|
|
|
492 ; (not (error-occurred
|
|
|
493 ; (call-process "prs" nil t t
|
|
|
494 ; (sccs-name file))))
|
|
|
495 ; )
|
|
|
496 ; )
|
|
|
497 (unwind-protect
|
|
|
498 (apply 'call-process (car sccs-diff-command) nil t t
|
|
|
499 (append (cdr sccs-diff-command) flags (list vers1) (list vers2)))
|
|
|
500 (condition-case () (delete-file vers1) (error nil))
|
|
|
501 (if rel2
|
|
|
502 (condition-case () (delete-file vers2) (error nil)))
|
|
|
503 )
|
|
|
504 )
|
|
|
505 )
|
|
|
506 )
|
|
|
507
|
|
|
508 ;; SCCS header insertion code
|
|
|
509
|
|
|
510 (defun sccs-insert-headers ()
|
|
|
511 "*Insert headers for use with the Source Code Control System.
|
|
|
512 Headers desired are inserted at the start of the buffer, and are pulled from
|
|
|
513 the variable sccs-headers-wanted"
|
|
|
514 (interactive)
|
|
|
515 (save-excursion
|
|
|
516 (save-restriction
|
|
|
517 (widen)
|
|
|
518 (if (or (not (sccs-check-headers))
|
|
|
519 (y-or-n-p "SCCS headers already exist. Insert another set?"))
|
|
|
520 (progn
|
|
|
521 (goto-char (point-min))
|
|
|
522 (run-hooks 'sccs-insert-headers-hook)
|
|
|
523 (cond ((eq major-mode 'c-mode) (sccs-insert-c-header))
|
|
|
524 ((eq major-mode 'lisp-mode) (sccs-insert-lisp-header))
|
|
|
525 ((eq major-mode 'emacs-lisp-mode) (sccs-insert-lisp-header))
|
|
|
526 ((eq major-mode 'scheme-mode) (sccs-insert-lisp-header))
|
|
|
527 ((eq major-mode 'nroff-mode) (sccs-insert-nroff-header))
|
|
|
528 ((eq major-mode 'plain-tex-mode) (sccs-insert-tex-header))
|
|
|
529 ((eq major-mode 'texinfo-mode) (sccs-insert-texinfo-header))
|
|
|
530 (t (sccs-insert-generic-header))))))))
|
|
|
531
|
|
|
532 (defun sccs-insert-c-header ()
|
|
|
533 (let (st en)
|
|
|
534 (insert "/*\n")
|
|
|
535 (mapcar '(lambda (s)
|
|
|
536 (insert " *\t" s "\n"))
|
|
|
537 sccs-headers-wanted)
|
|
|
538 (insert " */\n\n")
|
|
|
539 (if (and sccs-insert-static
|
|
|
540 (not (string-match "\\.h$" (buffer-file-name))))
|
|
|
541 (progn
|
|
|
542 (insert "#ifndef lint\n"
|
|
|
543 "static char *sccsid")
|
|
|
544 ;; (setq st (point))
|
|
|
545 ;; (insert (file-name-nondirectory (buffer-file-name)))
|
|
|
546 ;; (setq en (point))
|
|
|
547 ;; (subst-char-in-region st en ?. ?_)
|
|
|
548 (insert " = \"\%\W\%\";\n"
|
|
|
549 "#endif /* lint */\n\n")))
|
|
|
550 (run-hooks 'sccs-insert-c-header-hook)))
|
|
|
551
|
|
|
552 (defun sccs-insert-lisp-header ()
|
|
|
553 (mapcar '(lambda (s)
|
|
|
554 (insert ";;;\t" s "\n"))
|
|
|
555 sccs-headers-wanted)
|
|
|
556 (insert "\n")
|
|
|
557 (run-hooks 'sccs-insert-lisp-header-hook))
|
|
|
558
|
|
|
559 (defun sccs-insert-nroff-header ()
|
|
|
560 (mapcar '(lambda (s)
|
|
|
561 (insert ".\\\"\t" s "\n"))
|
|
|
562 sccs-headers-wanted)
|
|
|
563 (insert "\n")
|
|
|
564 (run-hooks 'sccs-insert-nroff-header-hook))
|
|
|
565
|
|
|
566 (defun sccs-insert-tex-header ()
|
|
|
567 (mapcar '(lambda (s)
|
|
|
568 (insert "%%\t" s "\n"))
|
|
|
569 sccs-headers-wanted)
|
|
|
570 (insert "\n")
|
|
|
571 (run-hooks 'sccs-insert-tex-header-hook))
|
|
|
572
|
|
|
573 (defun sccs-insert-texinfo-header ()
|
|
|
574 (mapcar '(lambda (s)
|
|
|
575 (insert "@comment\t" s "\n"))
|
|
|
576 sccs-headers-wanted)
|
|
|
577 (insert "\n")
|
|
|
578 (run-hooks 'sccs-insert-texinfo-header-hook))
|
|
|
579
|
|
|
580 (defun sccs-insert-generic-header ()
|
|
|
581 (let* ((comment-start-sccs (or comment-start "#"))
|
|
|
582 (comment-end-sccs (or comment-end ""))
|
|
|
583 (dont-insert-nl-p (string-match "\n" comment-end-sccs)))
|
|
|
584 (mapcar '(lambda (s)
|
|
|
585 (insert comment-start-sccs "\t" s ""
|
|
|
586 comment-end-sccs (if dont-insert-nl-p "" "\n")))
|
|
|
587 sccs-headers-wanted)
|
|
|
588 (insert comment-start-sccs comment-end-sccs (if dont-insert-nl-p "" "\n"))))
|
|
|
589
|
|
|
590 (defun sccs-check-headers ()
|
|
|
591 "Check if the current file has any SCCS headers in it."
|
|
|
592 (interactive)
|
|
|
593 (save-excursion
|
|
|
594 (goto-char (point-min))
|
|
|
595 (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" (point-max) t)))
|
|
|
596
|
|
|
597 ;; Status-checking functions
|
|
|
598
|
|
|
599 (defun sccs-status (prefix legend)
|
|
|
600 "List all files underneath the current directory matching a prefix type."
|
|
|
601 (sccs-shell-command
|
|
|
602 (concat "/bin/ls -1 SCCS/" prefix ".*"))
|
|
|
603 (if
|
|
|
604 (save-excursion
|
|
|
605 (set-buffer "*Shell Command Output*")
|
|
|
606 (if (= (point-max) (point-min))
|
|
|
607 (not (message
|
|
|
608 "No files are currently %s under %s"
|
|
|
609 legend default-directory))
|
|
|
610 (progn
|
|
|
611 (goto-char (point-min))
|
|
|
612 (insert
|
|
|
613 "The following files are currently " legend
|
|
|
614 " under " default-directory ":\n")
|
|
|
615 (replace-string (format "SCCS/%s." prefix) "")
|
|
|
616 )
|
|
|
617 )
|
|
|
618 )
|
|
|
619 (pop-to-buffer "*Shell Command Output*")
|
|
|
620 )
|
|
|
621 )
|
|
|
622
|
|
|
623 (defun sccs-pending ()
|
|
|
624 "*List all files currently SCCS locked."
|
|
|
625 (interactive)
|
|
|
626 (sccs-status "p" "locked"))
|
|
|
627
|
|
|
628 (defun sccs-registered ()
|
|
|
629 "*List all files currently SCCS registered."
|
|
|
630 (interactive)
|
|
|
631 (sccs-status "s" "registered"))
|
|
|
632
|
|
|
633 (defun sccs-register-file (override)
|
|
|
634 "*Register the file visited by the current buffer into SCCS."
|
|
|
635 (interactive "P")
|
|
|
636 (if (file-exists-p (sccs-name (buffer-file-name)))
|
|
|
637 (error "This file is already registered into SCCS.")
|
|
|
638 (progn
|
|
|
639 (if (and (buffer-modified-p)
|
|
|
640 (or
|
|
|
641 sccs-mode-expert
|
|
|
642 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
643 (buffer-name)))))
|
|
|
644 (save-buffer))
|
|
|
645 (sccs-load-vars)
|
|
|
646 (sccs-admin
|
|
|
647 (buffer-file-name)
|
|
|
648 (cond
|
|
|
649 (override (read-string "Initial SID: "))
|
|
|
650 ((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
|
|
|
651 (t sccs-current-major-version))
|
|
|
652 )
|
|
|
653 )
|
|
|
654 )
|
|
|
655 )
|
|
|
656
|
|
|
657 ;; Major functions for release-tracking and generation.
|
|
|
658
|
|
|
659 (defun sccs-release-diff (rel1 rel2)
|
|
|
660 "*Diff all files below default-directory between versions REL1 and REL2.
|
|
|
661 The report goes to a shell output buffer which is popped to. If REL2 is
|
|
|
662 omitted or nil, the comparison is done against the most recent version."
|
|
|
663 (interactive "sOlder version: \nsNewer version: ")
|
|
|
664 (if (string-equal rel1 "") (setq rel1 nil))
|
|
|
665 (if (string-equal rel2 "") (setq rel2 nil))
|
|
|
666 (sccs-shell-command (concat
|
|
|
667 "/bin/ls -1 " default-directory "SCCS/s.*"
|
|
|
668 ))
|
|
|
669 (set-buffer "*Shell Command Output*")
|
|
|
670 (goto-char (point-min))
|
|
|
671 (replace-string "SCCS/s." "")
|
|
|
672 (goto-char (point-min))
|
|
|
673 (if (eobp)
|
|
|
674 (error "No SCCS files under %s" default-directory))
|
|
|
675 (let
|
|
|
676 ((sccsbuf (get-buffer-create "*SCCS*")))
|
|
|
677 (save-excursion
|
|
|
678 (set-buffer sccsbuf)
|
|
|
679 (erase-buffer)
|
|
|
680 (insert (format "Diffs from %s to %s.\n\n"
|
|
|
681 (or rel1 "current") (or rel2 "current"))))
|
|
|
682 (while (not (eobp))
|
|
|
683 (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
|
|
|
684 (save-excursion
|
|
|
685 (set-buffer sccsbuf)
|
|
|
686 (set-buffer-modified-p nil)
|
|
|
687
|
|
|
688 (sccs-vdiff file rel1 rel2)
|
|
|
689 (if (buffer-modified-p)
|
|
|
690 (insert "\n"))
|
|
|
691 )
|
|
|
692 (forward-line 1)
|
|
|
693 )
|
|
|
694 )
|
|
|
695 (kill-buffer "*Shell Command Output*")
|
|
|
696 (pop-to-buffer sccsbuf)
|
|
|
697 (insert "\nEnd of diffs.\n")
|
|
|
698 (goto-char (point-min))
|
|
|
699 (replace-string (format "/SCCS/%s." rel1) "/")
|
|
|
700 (goto-char (point-min))
|
|
|
701 (replace-string (format "/SCCS/%s." rel2) "/new/")
|
|
|
702 (goto-char (point-min))
|
|
|
703 (replace-string "/SCCS/new." "/new/")
|
|
|
704 (goto-char (point-min))
|
|
|
705 (replace-regexp (concat "^*** " default-directory) "*** ")
|
|
|
706 (goto-char (point-min))
|
|
|
707 (replace-regexp (concat "^--- " default-directory) "--- ")
|
|
|
708 (goto-char (point-min))
|
|
|
709 (set-buffer-modified-p nil)
|
|
|
710 )
|
|
|
711 )
|
|
|
712
|
|
|
713 (defun sccs-dummy-delta (file sid)
|
|
|
714 "Make a dummy delta to the given FILE with the given SID."
|
|
|
715 (interactive "sFile: \nsRelease ID: ")
|
|
|
716 (if (not (sccs-locked-revision file))
|
|
|
717 (sccs-get file t))
|
|
|
718 ;; Grottiness alert -- to get around SCCS's obsessive second-guessing we
|
|
|
719 ;; have to mung the p-file
|
|
|
720 (save-excursion
|
|
|
721 (let ((pfile (sccs-name file "p")))
|
|
|
722 (chmod "u+w" pfile)
|
|
|
723 (find-file pfile)
|
|
|
724 (auto-save-mode nil)
|
|
|
725 (replace-regexp "^\\([0-9.]+\\) \\([0-9.]+\\)" (concat "\\1 " sid) t)
|
|
|
726 (write-region (point-min) (point-max) pfile t 0)
|
|
|
727 (chmod "u-w" pfile)
|
|
|
728 (set-buffer-modified-p nil)
|
|
|
729 (kill-buffer (current-buffer))
|
|
|
730 )
|
|
|
731 )
|
|
|
732 (sccs-delta file sid (concat "Release " sid))
|
|
|
733 (sccs-get file nil)
|
|
|
734 (sccs-save-vars sid)
|
|
|
735 )
|
|
|
736
|
|
|
737 (defun sccs-delta-release (sid)
|
|
|
738 "*Delta everything underneath the current directory to mark it as a release."
|
|
|
739 (interactive "sRelease: ")
|
|
|
740 (sccs-tree-walk 'sccs-dummy-delta sid)
|
|
|
741 (kill-buffer "*SCCS*")
|
|
|
742 )
|
|
|
743
|
|
|
744 ;; Miscellaneous other entry points
|
|
|
745
|
|
|
746 (defun sccs-revert-buffer ()
|
|
|
747 "*Revert the current buffer's file back to the last saved version."
|
|
|
748 (interactive)
|
|
|
749 (let ((file (buffer-file-name)))
|
|
|
750 (if (y-or-n-p (format "Revert file %s to last SCCS revision?" file))
|
|
|
751 (progn
|
|
|
752 (delete-file file)
|
|
|
753 (delete-file (sccs-name file "p"))
|
|
|
754 (rename-file (sccs-get-version file nil) file)
|
|
|
755 (chmod "-w" file)
|
|
|
756 (revert-buffer nil t)
|
|
|
757 (sccs-mode-line file)))))
|
|
|
758
|
|
|
759 (defun sccs-rename-file (old new)
|
|
|
760 "*Rename a file, taking its SCCS files with it."
|
|
|
761 (interactive "fOld name: \nFNew name: ")
|
|
|
762 (let ((owner (sccs-locking-user old)))
|
|
|
763 (if (and owner (not (string-equal owner (user-login-name))))
|
|
|
764 (error "Sorry, %s has that file checked out" owner))
|
|
|
765 )
|
|
|
766 (rename-file old new)
|
|
|
767 (if (file-exists-p (sccs-name old "p"))
|
|
|
768 (rename-file (sccs-name old "p") (sccs-name new "p")))
|
|
|
769 (if (file-exists-p (sccs-name old "s"))
|
|
|
770 (rename-file (sccs-name old "s") (sccs-name new "s")))
|
|
|
771 )
|
|
|
772
|
|
|
773 ;; Set up key bindings for SCCS use, e.g. while editing log messages
|
|
|
774
|
|
|
775 (defun sccs-mode ()
|
|
|
776 "Minor mode for driving the SCCS tools.
|
|
|
777
|
|
|
778 These bindings are added to the global keymap when you enter this mode:
|
|
|
779 \\[sccs] perform next logical SCCS operation (`sccs') on current file
|
|
|
780 \\[sccs-register-file] register current file into SCCS
|
|
|
781 \\[sccs-insert-headers] insert SCCS headers in current file
|
|
|
782 \\[sccs-prs] display change history of current file
|
|
|
783 \\[sccs-revert-buffer] revert buffer to last saved version
|
|
|
784 \\[sccs-revert-diff] show difference between buffer and last saved delta
|
|
|
785 \\[sccs-pending] show all files currently locked by any user in or below .
|
|
|
786 \\[sccs-registered] show all files registered into SCCS in or below .
|
|
|
787 \\[sccs-version-diff] show diffs between saved versions for all files in or below .
|
|
|
788
|
|
|
789 When you generate headers into a buffer using C-c h, the value of
|
|
|
790 sccs-insert-headers-hook is called before insertion. If the file is
|
|
|
791 recognized a C or Lisp source, sccs-insert-c-header-hook or
|
|
|
792 sccs-insert-lisp-header-hook is called after insertion respectively.
|
|
|
793
|
|
|
794 While you are entering a change log message for a delta, the following
|
|
|
795 additional bindings will be in effect.
|
|
|
796
|
|
|
797 \\[sccs-log-exit] proceed with check in, ending log message entry
|
|
|
798 \\[sccs-insert-last-log] insert log message from last check-in
|
|
|
799 \\[sccs-delta-abort] abort this delta check-in
|
|
|
800
|
|
|
801 Entry to the change-log submode calls the value of text-mode-hook, then
|
|
|
802 the value sccs-mode-hook.
|
|
|
803
|
|
|
804 Global user options:
|
|
|
805 sccs-mode-expert suppresses some conformation prompts,
|
|
|
806 notably for delta aborts and file saves.
|
|
|
807 sccs-max-log-size specifies the maximum allowable size
|
|
|
808 of a log message plus one.
|
|
|
809 sccs-diff-command A list consisting of the command and flags
|
|
|
810 to be used for generating context diffs.
|
|
|
811 sccs-headers-wanted which %-keywords to insert when adding
|
|
|
812 SCCS headers with C-c h
|
|
|
813 sccs-insert-static if non-nil, SCCS keywords inserted in C files
|
|
|
814 get stuffed in a static string area so that
|
|
|
815 what(1) can see them in the compiled object
|
|
|
816 code.
|
|
|
817 "
|
|
|
818 (interactive)
|
|
|
819 (set-syntax-table text-mode-syntax-table)
|
|
|
820 (use-local-map sccs-log-entry-mode)
|
|
|
821 (setq local-abbrev-table text-mode-abbrev-table)
|
|
|
822 (setq major-mode 'sccs-mode)
|
|
|
823 (setq mode-name "SCCS Change Log Entry")
|
|
|
824 (run-hooks 'text-mode-hook 'sccs-mode-hook)
|
|
|
825 )
|
|
|
826
|
|
|
827 ;; Initialization code, to be done just once at load-time
|
|
|
828 (if sccs-log-entry-mode
|
|
|
829 nil
|
|
|
830 (setq sccs-log-entry-mode (make-sparse-keymap))
|
|
|
831 (define-key sccs-log-entry-mode "\C-ci" 'sccs-insert-last-log)
|
|
|
832 (define-key sccs-log-entry-mode "\C-c\C-i" 'sccs-insert-last-log)
|
|
|
833 (define-key sccs-log-entry-mode "\C-ca" 'sccs-delta-abort)
|
|
|
834 (define-key sccs-log-entry-mode "\C-c\C-a" 'sccs-delta-abort)
|
|
|
835 (define-key sccs-log-entry-mode "\C-c\C-c" 'sccs-log-exit)
|
|
|
836 (define-key sccs-log-entry-mode "\C-x\C-s" 'sccs-log-exit)
|
|
|
837 )
|
|
|
838
|
|
|
839
|
|
|
840 ;;; Lucid Emacs support
|
|
|
841
|
|
|
842 (defconst sccs-menu
|
|
|
843 '("SCCS Commands"
|
|
|
844
|
|
|
845 ["SCCS" sccs t nil] ; C-c s n
|
|
|
846 ["Insert Headers" sccs-insert-headers t] ; C-c s h
|
|
|
847 ["Archive History:" sccs-prs t nil] ; C-c s p
|
|
|
848 ["Diffs from Archive:" sccs-revert-diff t nil] ; C-c s d
|
|
|
849 ["Revert to Archive:" sccs-revert-buffer t nil] ; C-c s r
|
|
|
850 "----"
|
|
|
851 ["Check In..." sccs-dummy-delta t]
|
|
|
852 ["Create Archive..." sccs-register-file t] ; C-c s h
|
|
|
853 ["Rename Archive..." sccs-rename-file t]
|
|
|
854 "----"
|
|
|
855 ["List Checked-Out Files" sccs-pending t] ; C-c s C-p
|
|
|
856 ["List Registered Files" sccs-registered t] ; C-c s C-r
|
|
|
857 ["Diff Directory" sccs-release-diff t]
|
|
|
858 ["Delta Directory" sccs-delta-release t]
|
|
|
859 ))
|
|
|
860
|
|
|
861 (progn
|
|
|
862 (delete-menu-item '("SCCS"))
|
|
|
863 (add-menu '() "SCCS" (cdr sccs-menu)))
|
|
|
864
|
|
|
865 (defun sccs-sensitize-menu ()
|
|
|
866 (let* ((rest (cdr (car (find-menu-item current-menubar '("SCCS")))))
|
|
|
867 (case-fold-search t)
|
|
|
868 (file (if buffer-file-name
|
|
|
869 (file-name-nondirectory buffer-file-name)
|
|
|
870 (buffer-name)))
|
|
|
871 (dir (file-name-directory
|
|
|
872 (if buffer-file-name buffer-file-name default-directory)))
|
|
|
873 (sccs-file (and buffer-file-name (sccs-name buffer-file-name)))
|
|
|
874 (known-p (and sccs-file (file-exists-p sccs-file)))
|
|
|
875 (checked-out-p (and known-p
|
|
|
876 (file-exists-p (sccs-name buffer-file-name "p"))))
|
|
|
877 command
|
|
|
878 item)
|
|
|
879 (while rest
|
|
|
880 (setq item (car rest))
|
|
|
881 (if (not (vectorp item))
|
|
|
882 nil
|
|
|
883 (setq command (aref item 1))
|
|
|
884 (if (eq 'sccs command)
|
|
|
885 (aset item 0
|
|
|
886 (cond ((or (null sccs-file) (not known-p))
|
|
|
887 "Create Archive:")
|
|
|
888 ((not checked-out-p)
|
|
|
889 "Check Out")
|
|
|
890 (t
|
|
|
891 "Check In"))))
|
|
|
892 (cond
|
|
|
893 ((and (> (length item) 3)
|
|
|
894 (string-match "directory" (aref item 0)))
|
|
|
895 (aset item 3 dir))
|
|
|
896 ((> (length item) 3)
|
|
|
897 (aset item 3 file))
|
|
|
898 (t nil))
|
|
|
899 (aset item 2
|
|
|
900 (cond
|
|
|
901 ((memq command '(sccs-prs))
|
|
|
902 known-p)
|
|
|
903 ((memq command '(sccs-revert-diff sccs-revert-buffer))
|
|
|
904 checked-out-p)
|
|
|
905 (t))))
|
|
|
906 (setq rest (cdr rest))))
|
|
|
907 nil)
|
|
|
908
|
|
|
909 (add-hook 'activate-menubar-hook 'sccs-sensitize-menu)
|
|
|
910
|
|
|
911 (provide 'sccs)
|
|
|
912
|
|
|
913 ;; sccs.el ends here
|
