Re: patch for documentation about version control

[Thien-Thi Nguyen]

Andre Spiegel <address@hidden> writes:

   Please don't add this.  RCS is perfectly alive and kicking, and to add
   an alternative means of manipulating the master files (with subtle
   incompatibilities admitted) is just plain unnecessary.

   If you can use your parsing functions to make vc-annotate work under
   RCS, that is a fine improvement, but please (a) let me see your patches
   before you commit them, and (b) version control operations on RCS files
   should always go via the actual RCS commands.

the patch is appended.  for the curious, there is also version 2.0.1 of
comma-v.el, from which the patch originated, in dir:

http://www.glug.org/people/ttn/software/ttn-pers-elisp/standalone/

as you can see, the patch does not actually change anything currently
defined in vc-rcs.el; it is purely additive.  btw, ORIG => 1.41.  if
there is a better way to get a file's per-line version info w/o parsing
the masterfile, please let me know in the next few days.  otherwise, i
will commit this so that vc-annotate is supported for RCS.

we can always ask the RCS maintainers to provide such info to Emacs in
the future (if we care), w/o being constrained by its present lack.

thi

____________________________________
diff -c vc-rcs.el.ORIG vc-rcs.el
*** vc-rcs.el.ORIG      Wed Nov 10 17:00:47 2004
--- vc-rcs.el   Wed Nov 10 17:35:19 2004
***************
*** 497,502 ****
--- 497,608 ----
                         (and newvers (concat "-r" newvers)))
                   (vc-switches 'RCS 'diff))))
  
+ (defun vc-rcs-annotate-command (file buffer &optional revision)
+   "Annotate FILE, inserting the results in BUFFER.
+ Optional arg REVISION is a revision to annotate from."
+   (let* ((tree (with-temp-buffer
+                  (insert-file-contents (vc-rcs-registered file))
+                  (vc-rcs-parse)))
+          (headers (cdr (assq 'headers tree)))
+          (revisions (cdr (assq 'revisions tree)))
+          (cur (cdr (assq 'head headers)))
+          (rbit (assoc cur revisions))
+          (meta (cdr rbit))
+          path pre delayed opp)
+     (unless revision
+       (setq revision cur))
+     (unless (assoc revision revisions)
+       (error "No such revision: %s" revision))
+     (set-buffer buffer)
+     ;; korg
+     (insert (cdr (assq 'text meta)))
+     (while (when (setq pre cur cur (cdr (assq 'next meta)))
+              (not (string= "" cur)))
+       (setq meta (cdr (assoc cur revisions))
+             opp nil
+             delayed nil)
+       (dolist (insn (cdr (assq :insn meta)))
+         (goto-line (pop insn))
+         (let ((p (point)))
+           (case (pop insn)
+             (k (push (let ((s (buffer-substring-no-properties
+                                p (progn (forward-line (car insn))
+                                         (point)))))
+                        `(,p ,(length s) I ,s))
+                      delayed))
+             (i (push (let ((s (car insn)))
+                        `(,p ,s K ,(length s)))
+                      delayed)))))
+       (dolist (p-act-ract (sort delayed (lambda (a b) (> (car a) (car b)))))
+         (let* ((p (pop p-act-ract))
+                (act (pop p-act-ract)))
+           (push (cons p p-act-ract) opp)
+           (goto-char p)
+           (funcall (if (numberp act)
+                        'delete-char
+                      'insert)
+                    act)))
+       (when (or path (string= revision pre))
+         (push `((:pre . ,pre)
+                 (:opp . ,opp)
+                 ,@meta)
+               path)))
+     (push `((:pre . ,pre)
+             (:opp . ((1 I ,(buffer-substring-no-properties
+                             (point-min) (point-max)))))
+             ,@meta)
+           path)
+     (erase-buffer)
+     ;; grok
+     (flet ((r/d/a (ls) (let ((r (cdr (assq :pre ls))))
+                          (let ((pre-ls (cdr (assoc r revisions))))
+                            (vector r
+                                    (cdr (assq 'date pre-ls))
+                                    (cdr (assq 'author pre-ls)))))))
+       (dolist (rbit path)
+         (dolist (insn (cdr (assq :opp rbit)))
+           (goto-char (pop insn))
+           (case (pop insn)
+             (I (insert (propertize (car insn)
+                                    :vc-rcs-r/d/a (r/d/a rbit)
+                                    'front-sticky '(:vc-rcs-r/d/a)
+                                    'rear-nonsticky t)))
+             (K (delete-char (car insn))))))))
+   ;; decorate
+   (goto-char (point-min))
+   (while (not (eobp))
+     (let ((r/d/a (get-text-property (point) :vc-rcs-r/d/a)))
+       (insert-and-inherit
+        ;; cvs envy (for now -- usurpers enjoy the dish best served cold)
+        (format "%-12s (%-8s %s): "      ; see `vc-rcs-annotate-time'
+                (aref r/d/a 0)
+                (aref r/d/a 2)
+                (format-time-string "%d-%b-%y" (aref r/d/a 1)))))
+     (forward-line 1)))
+ 
+ (defun vc-rcs-annotate-current-time ()
+   "Return the current time, based at midnight of the current day, and
+ encoded as fractional days."
+   (vc-annotate-convert-time
+    (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
+ 
+ (defun vc-rcs-annotate-time ()
+   "Return the time of the next annotation (as fraction of days)
+ systime, or nil if there is none.  Also, reposition point."
+   (unless (eobp)
+     (forward-char                       ; see `vc-rcs-annotate-command'
+      (+ 12                              ; revision
+         2                               ; space + left paren
+         8                               ; author
+         1                               ; space
+         (+ 2 1 3 1 2)                   ; date
+         3))                             ; right paren + colon + space
+     (vc-annotate-convert-time
+      (aref (get-text-property (point) :vc-rcs-r/d/a) 1))))
+ 
+ (defun vc-rcs-annotate-extract-revision-at-line ()
+   (aref (get-text-property (point) :vc-rcs-r/d/a) 0))
+ 
  
  ;;;
  ;;; Snapshot system
***************
*** 784,789 ****
--- 890,1126 ----
  (defun vc-rcs-set-default-branch (file branch)
    (vc-do-command nil 0 "rcs" (vc-name file) (concat "-b" branch))
    (vc-file-setprop file 'vc-rcs-default-branch branch))
+ 
+ (defun vc-rcs-parse (&optional buffer)
+   ;; Parse current buffer, presumed to be in RCS-style masterfile format.
+   ;; Optional arg BUFFER specifies another buffer to parse.  Return an alist
+   ;; of two elements, w/ keys `headers' and `revisions' and values in turn
+   ;; sub-alists.  For `headers', the values unless otherwise specified are
+   ;; strings and the keys are:
+   ;;
+   ;;  desc     -- description
+   ;;  head     -- latest revision
+   ;;  access   -- ???
+   ;;  symbols  -- sub-alist of (SYMBOL . REVISION) elements
+   ;;  locks    -- if file is checked out, something like "ttn:1.7"
+   ;;  strict   -- ???
+   ;;  comment  -- typically something like "# " or "; "
+   ;;
+   ;; For `revisions', the car is REVISION (string), the cdr a sub-alist,
+   ;; with string values (unless otherwise specified) and keys:
+   ;;
+   ;;  date     -- a time value (like that returned by `encode-time'); as a
+   ;;              special case, a year value less than 100 is augmented by 
1900
+   ;;  author   -- username
+   ;;  state    -- typically "Exp" or "Rel"
+   ;;  branches -- ???
+   ;;  next     -- next revision (which is actually prior in time!)
+   ;;  log      -- change log entry
+   ;;  text     -- for the head revision, this is the body of the file;
+   ;;              other revisions have `:insn' instead
+   ;;  :insn    -- for non-head revisions, a list of parsed instructions
+   ;;              in one of two forms, in both cases START meaning "first
+   ;;              go to line START":
+   ;;              - `(START k COUNT)' -- kill COUNT lines
+   ;;              - `(START i TEXT)'  -- insert TEXT (a string)
+   ;;
+   ;; The `:insn' key is a keyword to distinguish it as a vc-rcs.el value-added
+   ;; extra crispy not-found-in-stores bonus.
+   (setq buffer (get-buffer (or buffer (current-buffer))))
+   (set-buffer buffer)
+   (let (start context tok headers desc revs)
+     (setq start (point))
+     (goto-char (point-min))
+     (flet ((sw () (skip-chars-forward "[:space:]"))
+            (to-eol () (buffer-substring (point) (progn (forward-line 1)
+                                                        (1- (point)))))
+            (to-semi () (buffer-substring (point) (progn (search-forward ";")
+                                                         (1- (point)))))
+            (to-one@ () (buffer-substring
+                         (progn (search-forward "@") (point))
+                         (progn (while (and (search-forward "@")
+                                            (= ?@ (char-after))
+                                            (progn (forward-char 1) t)))
+                                (1- (point)))))
+            (tok+val (src name &optional proc)
+                     (if (not (eq name (setq tok (read buffer))))
+                         (error "Missing `%s' while parsing %s" name context)
+                       (sw)
+                       (cons tok (funcall (or proc 'identity)
+                                          (funcall src)))))
+            (k-semi (name &optional proc) (tok+val 'to-semi name proc))
+            (k-one@ (name &optional proc) (tok+val 'to-one@ name proc))
+            (@<-@@ (s) (with-temp-buffer
+                         (insert s)
+                         (while (search-backward "@@" (point-min) t)
+                           (delete-char 1))
+                         (buffer-string))))
+       ;; headers
+       (setq context 'headers)
+       (flet ((hpush (name &optional proc)
+                     (push (k-semi name proc) headers)))
+         (mapc 'hpush '(head access))
+         (hpush 'symbols
+                (lambda (x)
+                  (mapcar (lambda (together)
+                            (let ((two (split-string together ":")))
+                              (setcar two (intern (car two)))
+                              (setcdr two (cadr two))
+                              two))
+                          (split-string x))))
+         (mapc 'hpush '(locks strict)))
+       (push (tok+val                    ; ugh
+              (lambda ()
+                (unless (looking-at "@")
+                  (error "Malformed `comment' header"))
+                (forward-char 1)
+                (buffer-substring
+                 (point) (progn (search-forward "@;")
+                                (- (point) 2))))
+              'comment)
+             headers)
+       (setq headers (nreverse headers))
+       ;; rev headers
+       (sw) (setq context 'rev-headers)
+       (while (looking-at "[0-9]")
+         (push `(,(to-eol)
+                 ,(k-semi 'date
+                          (lambda (s)
+                            (apply 'encode-time
+                                   (let ((ls (mapcar 'string-to-number
+                                                     (split-string s "\\."))))
+                                     ;; hack the year -- verified to be the
+                                     ;; same algorithm used in RCS 5.7
+                                     (when (< (car ls) 100)
+                                       (setcar ls (+ 1900 (car ls))))
+                                     (reverse ls)))))
+                 ,@(mapcar 'k-semi '(author state branches next)))
+               revs)
+         (sw))
+       (setq revs (nreverse revs))
+       ;; desc
+       (sw) (setq context 'desc
+                  desc (k-one@ 'desc '@<-@@))
+       ;; rev bodies
+       (dolist (rev revs)
+         (sw)
+         (unless (string= (car rev) (to-eol))
+           (error "Missing rev body while parsing rev `%s'" (car rev)))
+         (push (k-one@ 'log  '@<-@@) (cdr rev))
+         (push (k-one@ 'text '@<-@@) (cdr rev))
+         (unless (string= (car rev) (cdr (assq 'head headers)))
+           (setcar (cadr rev) :insn)
+           (setcdr (cadr rev)
+                   (with-temp-buffer
+                     (insert (cdadr rev))
+                     (goto-char (point-min))
+                     (let (acc start act)
+                       (while (re-search-forward "^[ad]" (point-max) t)
+                         ;; d:a::k:i
+                         (setq start (read (current-buffer))
+                               act (read (current-buffer)))
+                         (push (if (string= "d" (match-string 0))
+                                   ;; `d' means "delete lines"
+                                   `(,start k ,act)
+                                 ;; `a' means "append after this line" but
+                                 ;; internally we normalize it so that START
+                                 ;; specifies the actual line for insert, thus
+                                 ;; requiring less hair in the realization algs
+                                 `(,(1+ start) i
+                                   ,(progn
+                                      (forward-char 1)
+                                      (buffer-substring-no-properties
+                                       (point)
+                                       (progn (forward-line act)
+                                              (point))))))
+                               acc))
+                       (nreverse acc))))))
+       (goto-char start)
+       ;; rv
+       `((headers ,desc ,@headers)
+         (revisions ,@revs)))))
+ 
+ ;;;; This is unused, included here for completeness.
+ ;;;; (IMHO, there is no harm in including it. --ttn)
+ ;;
+ ;;(defun vc-rcs-unparse (tree &optional buffer)
+ ;;  ;; Insert TREE into current buffer in RCS-style masterfile format.
+ ;;  ;; Optional second arg BUFFER specifies another buffer to insert into.
+ ;;  ;; You can use `vc-rcs-parse' to get TREE.
+ ;;  (setq buffer (get-buffer (or buffer (current-buffer))))
+ ;;  (let ((standard-output buffer)
+ ;;        (headers (cdr (assq 'headers tree)))
+ ;;        (revisions (cdr (assq 'revisions tree))))
+ ;;    (flet ((spew! (look name finish &optional proc)
+ ;;                  (princ name)
+ ;;                  (let ((v (funcall (or proc 'identity)
+ ;;                                    (funcall look name))))
+ ;;                    (unless (string= "" v)
+ ;;                      (unless proc
+ ;;                        (princ "\t"))
+ ;;                      (princ v)))
+ ;;                  (princ ";") (princ finish)))
+ ;;      (flet ((hspew (name finish &optional proc)
+ ;;                    (spew! (lambda (name) (cdr (assq name headers)))
+ ;;                           name finish proc)))
+ ;;        (hspew 'head "\n")
+ ;;        (hspew 'access "\n")
+ ;;        (hspew 'symbols "\n" (lambda (ls)
+ ;;                               (apply 'concat
+ ;;                                      (mapcar (lambda (x)
+ ;;                                                (format "\n\t%s:%s"
+ ;;                                                        (car x) (cdr x)))
+ ;;                                              ls))))
+ ;;        (hspew 'locks " ")
+ ;;        (hspew 'strict "\n")
+ ;;        (hspew 'comment "\n\n\n" (lambda (s) (format "address@hidden@" s))))
+ ;;      (dolist (rev revisions)
+ ;;        (princ (car rev))
+ ;;        (princ "\n")
+ ;;        (flet ((rlook (name) (cdr (assq name (cdr rev))))
+ ;;               (rspew (name finish &optional proc)
+ ;;                      (spew! 'rlook name finish proc)))
+ ;;          (rspew 'date "\t" (lambda (v)
+ ;;                              (format-time-string "\t%Y.%m.%d.%H.%M.%S" v)))
+ ;;          (rspew 'author "\t" (lambda (v) (concat " " v)))
+ ;;          (rspew 'state "\n" (lambda (v) (concat " " v)))
+ ;;          (rspew 'branches "\n")
+ ;;          (rspew 'next "\n\n"))))
+ ;;    (princ "\n")
+ ;;    (flet ((spew! (look name finish &optional proc)
+ ;;                  (princ name)
+ ;;                  (princ "\n@")
+ ;;                  (princ (with-temp-buffer
+ ;;                           (insert (funcall (or proc 'identity)
+ ;;                                            (funcall look name)))
+ ;;                           (while (search-backward "@" (point-min) t)
+ ;;                             (insert "@") (forward-char -1))
+ ;;                           (buffer-string)))
+ ;;                  (princ "@\n") (princ finish)))
+ ;;      (spew! (lambda (name) (cdr (assq name headers))) 'desc "")
+ ;;      (dolist (rev revisions)
+ ;;        (princ "\n\n") (princ (car rev)) (princ "\n")
+ ;;        (flet ((rlook (name) (cdr (assq name (cdr rev)))))
+ ;;          (spew! 'rlook 'log "")
+ ;;          (spew! (if (assq :insn (cdr rev))
+ ;;                     (let ((s (with-temp-buffer
+ ;;                                (dolist (cmd (rlook :insn))
+ ;;                                  (case (cadr cmd)
+ ;;                                    (k (insert (format "d%d %d\n"
+ ;;                                                       (car cmd)
+ ;;                                                       (caddr cmd))))
+ ;;                                    (i (insert (format "a%d "
+ ;;                                                       (1- (car cmd))))
+ ;;                                       (save-excursion
+ ;;                                         (insert (caddr cmd)))
+ ;;                                       (insert (format "%d\n"
+ ;;                                                       (count-lines
+ ;;                                                        (point) 
(point-max))))
+ ;;                                       (goto-char (point-max)))))
+ ;;                                (buffer-string))))
+ ;;                       `(lambda (x) ,s))
+ ;;                   'rlook)
+ ;;                 'text ""))))))
  
  (provide 'vc-rcs)