(in-package "CL-USER")

;; NDL 2001-09-07
;; $Id: //info.ravenbrook.com/project/mps/tool/second-rcs-import/parse-rcs.lisp#1 $

;; 2001-09-12 - parse-rcs.lisp is no longer in use, but I have added
;; it to source control for safekeeping...

;; Code to read metadata from RCS files and build a Perforce
;; checkpoint corresponding to the changes therein. Written to do what
;; rectoperf.sh should have done, but to get it right.

;; This version assumes only one RCS file. Once I've got this right
;; I'll extend it to cover many files

(defstruct (rcsdata
            (:constructor make-rcsdata (name branches versions)))
  name
  branches
  versions)

(defstruct (branch
            (:constructor make-branch (id name)))
  id
  name)

(defstruct (version
            (:constructor make-version (id date author)))
  id
  date
  author
  reason)

(defstruct checkpoint
  counters
  ;; domain               ; not in use. labels appear to be bogus in the RCS file...
  have
  integ
  rev
  revcx
  change
  desc)

(defun read-rcs-file (file)
  (let* ((path (truename file))
         (rcs-string (file-string path))
         (rcsdata (multiple-value-bind (branches continue)
                      (read-branch-symbols rcs-string)
                    (multiple-value-bind (versions continue)
                        (read-deltas rcs-string continue)
                      (read-logs rcs-string versions continue)
                      (make-rcsdata (let ((name pathname-name)
                                          (type (pathname-type path)))
                                      (if (stringp type)
                                          (format nil "~a.~a"
                                                  name
                                                  (subseq type 0
                                                          (position #\, type)))
                                        (subseq name 0
                                                (position #\, name))))
                                    branches versions)))))
    ;; (generate-checkpoint rcsdata)
    rcsdata))

;; Stage One
;; Read the "symbols" from an RCS file and build a list of branches
;; (drop the version labels - they are of no interest)

(defun read-branch-symbols (rcs-string)
  (let* ((start-marker (format nil "symbols~%"))
         (start (+ (safe-search start-marker rcs-string)
                   (length start-marker)))
         (end (position #\; rcs-string :start start))
         (branches nil))
    (loop 
     (when (>= start end)
       (return))
     (let* ((line-end (position #\Newline rcs-string :start start))
            (full-line (subseq rcs-string start line-end))
            (line (string-trim '(#\Space #\Tab #\;) full-line))
            (name-end (position #\: line))
            (name (subseq line 0 name-end))
            (numbers (subseq line (1+ name-end))))
       (when (evenp (count #\. numbers))
         ;; the business
         (push (make-branch (pull-numbers numbers) name) branches))
       (incf start (1+ (length full-line)))))
    (values branches end)))

                       
;; Stage Two
;; Read the version and branching structure from the RCS file (in man
;; rcsfile(5) these entries are called "deltas")

(defun read-deltas (rcs-string start)
  (let* ((end-marker (format nil "~%desc"))
         (end (safe-search end-marker rcs-string :start2 start))
         (versions nil))
    (loop
     ;; find next start
     (loop (setf start (1+ (position #\Newline rcs-string :start start)))
           (when (digit-char-p (schar rcs-string start))
             (return)))
     (when (>= start end)
       (return))
     (let* ((version-end (position #\Newline rcs-string :start start))
            (version (pull-numbers (subseq rcs-string start version-end)))
            (date-marker "date")
            (date-start (+ (safe-search date-marker rcs-string :start2 version-end)
                           (length date-marker)))
            (date-end (position #\; rcs-string :start date-start))
            (date-string (string-trim '(#\Space #\Tab)
                                      (subseq rcs-string date-start date-end)))
            (date (apply 'encode-universal-time (reverse (pull-numbers date-string))))
            (author-marker "author")
            (author-start (+ (safe-search author-marker rcs-string :start2 date-end)
                             (length author-marker)))
            (author-end (position #\; rcs-string :start author-start))
            (author (string-trim '(#\Space #\Tab)
                                 (subseq rcs-string author-start author-end))))
       (push (make-version version date author) versions)
       (setf start author-end)))
    (multiple-value-bind (junk real-end)
        (read-at-delimited-string rcs-string end)
      (declare (ignore junk))
      (values (sort versions '<
                    :key 'version-date)
              real-end))))

;; Stage Three 
;; Read the change logs and add them to the version structures.

(defun read-logs (rcs-string versions start)
  (loop
   (setf start (position-if 'digit-char-p rcs-string :start start))
   (when (not start)
     (return))
   (let* ((version-end (position #\Newline rcs-string :start start))
          (version (pull-numbers (subseq rcs-string start version-end))))
     (multiple-value-bind (log log-end)
         (read-at-delimited-string rcs-string version-end)
       (setf (version-reason (find version versions :test 'equal :key 'version-id))
             log)
       (multiple-value-bind (junk text-end)
           (read-at-delimited-string rcs-string log-end)
         (declare (ignore junk))
         (setf start text-end))))))

;; Stage Four
;; Generate a checkpoint file from the rcs data.

#+not-yet
(defun generate-checkpoint (rcsdata)
  (let ((checkpoint (make-checkpoint)))
    (dolist (version (rcsdata-versions rcsdata))
      (add-to-checkpoint checkpoint version))))

#+not-yet
(defun add-to-checkpoint (checkpoint version)
  (let* ((id (version-id version))
         (type (cond ((equal id '(1 1)) :add)
                     ((= (car (last id)) 1) :branch)
                     (t :edit)))
         )))
    



;; Utilities

;; return the string with its @ delimiters
(defun read-at-delimited-string (text start)
  (let* ((start (position #\@ text :start start))         ; advance to real start
         (end (1+ start)))
    (loop (setf end (1+ (position #\@ text :start end)))
          (when (char/= (schar text end) #\@)
            (return (values (subseq text start end)
                            end)))
          (incf end))))

(defun pull-numbers (string)
  (let ((numbers nil)
        (where 0))
    (loop
     (let ((next (position #\. string :start where)))
       (push (parse-integer string
                            :start where
                            :end next)
             numbers)
       (unless next
         (return (reverse numbers)))
       (setf where (1+ next))))))
    
(defun join-numbers (list)
  (let ((rest (rest list)))
    (if rest
        (format nil "~a.~a"
                (first list)
                (join-numbers rest))
      (format nil "~a" (first list)))))


(defun safe-search (substring string &rest args)
  (or (apply 'search substring string args)
      (error "Could not find ~s." substring)))

(defun map-over-subdirs (function directory)
  (dolist (entry (directory (namestring directory)))
    (if (file-directory-p entry)
        (map-over-subdirs function entry)
      (funcall function entry))))

;;;;;;;;;;;

(defun generate-corrections-once (file)
  (let ((rcsdata (read-rcs-file file)))
    (format t "~&(progn")
    (dolist (branch (rcsdata-branches rcsdata))
      (format t "~&  (correct-one-branch-file ~s ~s ~s)~&"
              (branch-name branch)
              (join-numbers (branch-id branch))
              (rcsdata-name rcsdata)))
    (format t ")~&")))

(defun generate-all-corrections (directory)
  (map-over-subdirs 'generate-corrections-once directory))