(in-package "CL-USER")

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

;; Code to read a checkpoint and fix the damage. For each file /
;; branch combination, do the following:
;; a) Remove db.rev and db.revcx entries with lowest changelist
;;    numbers (they're bogus), confirming that the remaining db.rev
;;    entry with the lowest changelist number is correctly numbered in
;;    the lbrRev field
;; b) Subtract 1 from revision values for all remaining entries
;; c) Change "action" on earliest remaining db.rev / db.revcx entries
;;    to 0 ("add")
;; d) Store changelist from earliest remaining db.rev / db.revcx
;;    entries in db.integ (in place of zero there at present)
;; e) Change "resolved" to 2 ("automatically as part of branch") in
;;    all db.integ entries
;; f) Change "how" from 3 ("branch into") to 11 ("dirty branch into")
;;    in first of each db.integ pair

;; 1. Describe the entries we expect to find in the checkpoint

(eval-when (compile load eval)
  (defparameter *schema* 
    ;; entries of form (lock-order version number-of-fields constructor)
    (make-hash-table :test 'equal)))

(defmacro def-db (name (&key (lock (error "Lock compulsory.")) (version 0)) &rest fields)
  (let ((db-name (format nil "@db.~(~a~)@" name))
        (boa-constructor (intern (format nil "MAKE-~a" name))))
    `(progn
       (setf (gethash ,db-name *schema*)
             '(,lock ,version ,(length fields) ,boa-constructor))
       (defstruct (,name (:type vector) :named
                         (:constructor ,boa-constructor (,@fields)))
         ,@fields))))

(def-db counters (:lock 0)
        name
        value)

(def-db domain (:lock 4 :version 1)
        name
        type
        host
        mount
        owner
        update-date
        access-date
        options
        description)

(def-db have (:lock 7 :version 1)
        client-file
        depot-file
        have-rev
        type)

(def-db integ (:lock 8)
        to-file
        from-file
        start-from-rev
        end-from-rev
        to-rev
        how
        committed
        resolved
        change)

(def-db rev (:lock 10 :version 3)
        depot-file
        depot-rev
        type
        action
        change
        date
        mod-time
        digest
        lbr-file
        lbr-rev
        lbr-type)

(def-db revcx (:lock 11)
        change
        depot-file
        depot-rev
        action)

(def-db change (:lock 13)
        change
        desc-key
        client
        user
        date
        status
        description)

(def-db desc (:lock 14)
        desc-key
        description)

;; 2. Top-level control

(defun edit-checkpoint (file)
  (let ((out-file (format nil "~a.out"
                          (namestring file)))
        (database (make-hash-table :test 'equal)))
    (with-open-file (ostream out-file
                             :direction :output
                             :external-format '(:latin-1 :eol-style :lf)
                             :if-exists :supersede)
      (read-checkpoint-entries database file)
      (fixup-branches database)
      (dump-new-checkpoint database ostream)
      database)))

(defun debug-msg (&optional message)
  (if message
      (format t "~&~a~&" message)
    ;; (write-string  ".")
    )
  (force-output))

;; 3. Read contents of checkpoint into database

(defun read-checkpoint-entries (database file)
  (debug-msg 'read-checkpoint-entries)
  (let ((raw-checkpoint-entries (make-text file))
        (start 0))
    (unwind-protect
        (loop
         (multiple-value-bind (db-name entry next)
             (read-checkpoint-entry raw-checkpoint-entries start)
           (unless entry
             (return))
           (push entry
                 (gethash db-name database))
           (setf start next)))
      #+lispworks
      (close (text-istream raw-checkpoint-entries)))))

(defun read-checkpoint-entry (text start)
  (let ((next (confirm-put-action text start)))
    (when next
      (multiple-value-bind (db-name next number-of-fields constructor)
          (read-db-name text next)
        (let ((fields nil))
          (dotimes (i number-of-fields)
            ;; advance to start of field so we can tell what type it is
            (loop (if (whitespace-char-p (lazy-schar text next))
                      (incf next)
                    (return)))
            ;; read in field and add it to list
            (multiple-value-bind (field continue)
                (if (digit-char-p (lazy-schar text next))
                    (rapid-parse-integer text next)
                  (read-at-delimited-string text next))
              (push field fields)
              (setf next continue)))
          (values db-name
                  (apply constructor (nreverse fields))
                  next))))))


(defun confirm-put-action (text start)
  (multiple-value-bind (action next)
      (read-at-delimited-string text start)
    (cond ((null action)
           (return-from confirm-put-action                ; end of file
             nil))
          ((string/= action "@pv@")
           (error "Only expecting put-values; at position ~d." start))
          (t next))))

(defun read-db-name (text start)
  (multiple-value-bind (version next)
      (rapid-parse-integer text start)
    (multiple-value-bind (db-name next)
        (read-at-delimited-string text next)
      (let* ((schema-entry (gethash db-name *schema*))
             (expected-version (second schema-entry)))
        (or (= version expected-version)
            (error "Version ~d in ~s should be ~d (position ~d)."
                   version db-name expected-version start))
        (values db-name next 
                (third schema-entry) (fourth schema-entry))))))

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

#+lispworks
(defun read-at-delimited-string (text start)
  (loop (let ((char (lazy-schar text start)))
          (cond ((null char)
                 (return-from read-at-delimited-string    ; ... end of file
                   nil))
                ((char= char #\@)
                 (return))                                ; have advanced to real start
                (t (incf start)))))
  (let ((end (1+ start))
        (chars (list #\@)))
    (loop
     ;; (setf end (1+ (position #\@ text :start end)))
     (loop (let ((char (lazy-schar text end)))
             (incf end)
             (push char chars)
             (when (char= char #\@)
               (return))))
     (when (char/= (lazy-schar text end) #\@)
       (return (values (nreverse (coerce chars 'simple-base-string))
                       end)))
     (incf end))))

;; yawn. a version of parse-integer which does not copy its input string
(defun rapid-parse-integer (text start)
  (loop (if (whitespace-char-p (lazy-schar text start))
            (incf start)
          (return)))
  (let ((integer 0))
    (loop (let* ((char (lazy-schar text start))
                 (digit (digit-char-p char)))
            (or digit
                (return (values integer start)))
            (setf integer (+ (* integer 10) digit))
            (incf start)))))

;; Yawn. A version of schar which hide lispworks' reluctance to build a 14MB string.
;; It happens that we never have to read backwards...

#+lispworks
(defstruct (text
            (:print-object print-text)
            (:constructor construct-text))
  str
  index
  istream
  buffer-len)

(defun print-text (object stream)
  (print-unreadable-object
      (object stream :type t :identity t)))

(defun make-text (file)
  #-lispworks
  (return-from make-text
    (file-string file))         ; not CL but at least the meaning is obvious...
  #+lispworks
  (let ((buffer-length 1000000))
    (construct-text :str ""
                    :index (- buffer-length)
                    :istream (open file)
                    :buffer-len buffer-length)))

(defun lazy-schar (text index)
  #-lispworks (return-from lazy-schar
                (schar text index))
  #+lispworks
  (let* ((str (text-str text))
         (str-len (length str))
         (real-index (- index (text-index text))))
    (when (>= real-index str-len)
      (let* ((buffer-len (text-buffer-len text))
             (new-str (stream::file-string* (text-istream text)
                                            buffer-len
                                            'base-char)))
        (setf (text-str text) new-str)
        (incf (text-index text) buffer-len)
        (return-from lazy-schar
          (if (plusp (length new-str))
              (lazy-schar text index)
            nil))))
    (schar str real-index)))

;; 4. Locate file / branch combinations and run through actions (a) -
;; (g) above.

;; Once we have the list of branches it's worth restructuring the data so we
;; don't get grid-locked in searches

(defun fixup-branches (database)
  (let ((branches (identify-branches database)))
    (preorder-data database)
    (debug-msg 'fixup-branches)
    (dolist (branch branches)
      (fixup-one-branch branch database))))

(defun identify-branches (database)
  (debug-msg 'identify-branches)
  (let* ((all-revcx (gethash  "@db.revcx@" database))
         (branches (remove-if-not (lambda (r) (= (revcx-action r) 3))  ; remove-if-not copies list argument.
                                  all-revcx)))
    branches))

(defun preorder-data (database)
  (debug-msg 'preorder-data)
  (dolist (pair '((rev-depot-file . "@db.rev@")
                  (revcx-depot-file . "@db.revcx@")
                  (integ-from-file . "@db.integ@")
                  (integ-to-file . "@db.integ@")))
    (let ((getter (car pair))
          (name (cdr pair))
          (new-table (make-hash-table :test 'equal)))
      (dolist (entry (gethash name database))
        (debug-msg)
        (let* ((file (funcall getter entry))
               (key (reverse file)) ; experiment, gives 10x speedup!
               (already (gethash key new-table)))
          ;; hack to remove puthash from bottleneck
          ;; (push entry (gethash file new-table))
          (if already
              (setf (cdr already)
                    (cons entry (cdr already)))
            (setf (gethash key new-table)
                  (cons entry nil)))))
      (setf (gethash getter database) new-table))))

(defun fixup-one-branch (bogus-revcx database)
  (debug-msg)
  ;; Start by finding rev / revcx data
  (let* ((bogus-change (revcx-change bogus-revcx))
         (depot-file (revcx-depot-file bogus-revcx))
         (hash-key (reverse depot-file))
         (all-rev (gethash hash-key (gethash 'rev-depot-file database)))
         (all-revcx (gethash hash-key (gethash 'revcx-depot-file database)))
         (relavent-rev (remove-if-not (lambda (r) (aref r 0)) ; not removed yet?!
                                      all-rev))
         (bogus-rev (find-if (lambda (r)
                               (= (rev-change r) bogus-change))
                             relavent-rev))
         (relavent-revcx (remove-if-not (lambda (r) (aref r 0)) ; not removed yet?!
                                      all-revcx))
         (lead-rev (car (sort (remove bogus-rev relavent-rev) '<      ; remove copies list argument.
                              :key 'rev-change)))
         (lead-revcx (car (sort (remove bogus-revcx relavent-revcx) '<
                                :key 'revcx-change)))
         (desired-change (rev-change lead-rev)))

    ;; Confirm that the remaining db.rev entry with the lowest
    ;; changelist number is correctly numbered in the lbrRev field
    (let ((lbr-rev (rev-lbr-rev lead-rev)))
      (or (string= lbr-rev ".1@" :start1 (- (length lbr-rev) 3))
          (cerror "Librarian's version ~s in ~s is wrong." lbr-rev lead-rev)))

    ;; [c] Change "action" on earliest remaining db.rev / db.revcx entries
    ;; to 0 ("add")
    (setf (rev-action lead-rev) 0
          (revcx-action lead-revcx) 0)

    ;; [b] Subtract 1 from revision values for all remaining entries
    (dolist (r relavent-rev)
      (decf (rev-depot-rev r)))
    (dolist (r relavent-revcx)
      (decf (revcx-depot-rev r)))

    ;; [a] Remove db.rev and db.revcx entries with lowest changelist
    ;;    numbers (they're bogus)
    (setf (aref bogus-rev 0) nil
          (aref bogus-revcx 0) nil)

    ;; locate db.integ entries
    (let* ((all-integ-from (gethash hash-key (gethash 'integ-from-file database)))
           (all-integ-to (gethash hash-key (gethash 'integ-to-file database)))
           (integ-from (find-if (lambda (i)
                                  (= (integ-how i) 2))
                                all-integ-to))
           (integ-into (find-if (lambda (i)
                                  (= (integ-how i) 3))
                                all-integ-from)))

      ;; [d] Store changelist from earliest remaining db.rev / db.revcx
      ;; entries in db.integ (in place of zero there at present)
      (setf (integ-change integ-from) desired-change
            (integ-change integ-into) desired-change)

      ;; [e] Change "resolved" to 2 ("automatically as part of branch") in
      ;; all db.integ entries
      (setf (integ-resolved integ-from) 2
            (integ-resolved integ-into) 2)

      ;; [f] Change "how" from 3 ("branch into") to 11 ("dirty branch into")
      ;; in first of each db.integ pair
      (setf (integ-how integ-into) 11)

      )))

;; 5. Dump the resulting new checkpoint file

(defun dump-new-checkpoint (database ostream)
  (debug-msg 'dump-new-checkpoint)
  ;; make the digests 32 chars long...
  (dolist (r (gethash "@db.rev@" database))
    (when (aref r 0)
      (setf (rev-digest r)
            (format nil "~32,'0d" (rev-digest r)))))
  ;; now dump the lot, in order
  (let ((plans (let ((p nil))
                 (maphash (lambda (name info)
                            (push (list (first info) name (second info)) p))
                          *schema*)
                 (mapcar 'cdr (sort p '< :key 'car)))))
    (dolist (plan plans)
      (let* ((name (car plan))
             (version (cadr plan))
             (entries (gethash name database)))
        (dolist (entry (reverse entries))     ; restore input order
          (dotimes (i (length entry))
            (let ((field (aref entry i)))
              (if (zerop i)
                  ;; check not "removed"
                  (if field
                      (format ostream "~&@pv@ ~a ~a "
                              version 
                              name)
                    (return))                  ; returns from the dotimes
                (format ostream "~a " field)))))))))