(in-package "CL-USER")

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

;; Code to read RCS files and build new ones with the checkpoint
;; labels taken out.

(defun rewrite-rcs-files (directory)
  (map-over-subdirs 'repair-one-rcs-file directory))

(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 repair-one-rcs-file (file)
  (let* ((path (truename file))
         (rcs-string (file-string path))
         (start-marker (format nil "symbols~%"))
         (start (+ (or (search start-marker rcs-string)
                       (when (search "symbols;" rcs-string)
                         (warn "Leaving ~s unchanged." file)
                         (return-from repair-one-rcs-file))
                       (error "Could not find start-marker ~s." start-marker))
                   (length start-marker)))
         (end (or (position #\; rcs-string :start start)
                  (error "Could not find terminator ~c." #\;))))
    (with-open-file (ostream file :direction :output
                             :external-format '(:latin-1 :eol-style :lf)
                             :if-exists :supersede
                             :if-does-not-exist :error)
      (write-string rcs-string ostream :end (1- start))
      (loop 
       (when (>= start end)
         (return))
       (let* ((line-end (position-if (lambda (c) (find c #(#\Newline #\;)))
                                     rcs-string :start start))
              (full-line (subseq rcs-string start line-end))
              (line (string-trim '(#\Space #\Tab) full-line))
              (name-end (position #\: line))
              (numbers (subseq line (1+ name-end))))
         (when (evenp (count #\. numbers))
           ;; it's a branch - keep it
           (terpri ostream)
           (write-string rcs-string ostream :start start :end line-end))
         (incf start (1+ (length full-line)))))
      (write-string rcs-string ostream :start end)))
  nil)