;;; rmangle.el
;;;
;;; Copyright (C) 2004, 2005, 2007, 2008 Thien-Thi Nguyen
;;;
;;; This file is part of ttn's personal elisp library, released under
;;; the terms of the GNU General Public License as published by the
;;; Free Software Foundation; either version 3, or (at your option) any
;;; later version.  There is NO WARRANTY.  See file COPYING for details.
;;;
;;; Description: Release management.

;;; Commentary:

;; In the software industry, as in the porn industry, "release" is a technical
;; term and its management can vary from highly personal to highly impersonal.

;;; Code:

(require 'cl)
(require 'vc)

(defvar rmangle-status nil
  "Hash table for dirs and files under ttn-style release manglement.
Modified by `update-rmanglement'; dumped by `describe-rmangle-status'.")

(defvar rmangle-cookie ".last-release"
  "*Filename in a topdir indicating ttn-style release manglement.
The file contains a version control tag, like \"v-4-2\" corresponding
to the last release of the tree under TOPDIR.")

(defvar rmanglement nil
  "String describing ttn-style release manglement status for the mode line.
Nil if the file is neither under version control nor under ttn-style
release manglement; otherwise, a string of the form \"/NAMED!ANON\".

The \"/\" is literal.  NAMED is the number of revisions after a named
release.  If NAMED is 0 (zero), show \"Rel\".  The \"!\" may be repeated
zero or more times, each time reflecting the file's change to the \"Rel\"
state.  If there are revisions after the last change to the \"Rel\" state,
a count of them (if non-zero) is shown as ANON.

Loading rmangle.el modifies the default mode line to splice the indicator
  (rmanglement rmanglement)
immediately after `(vc-mode vc-mode)'.  If you don't like this, eval:
  (setq inhibit-rmangle-mode-line-splicing t)
before loading rmangle.el (or alternatively, don't load rmangle.el).")

;;;###autoload
(defun update-rmanglement ()
  "Set the var `rmanglement' associated with ttn-style release manglement.
Return the new value of `rmanglement', a string w/ text properties set."
  (interactive)
  (unless rmangle-status
    (setq rmangle-status (make-hash-table)))
  (let ((dd (expand-file-name (directory-file-name default-directory)))
        ;; Directory status, one of three values:
        ;; - `alas-no' means dir is not under release manglement;
        ;; - TOPDIR (symbol) means this dir is a child of TOPDIR, see next;
        ;; - a list (TAG ATTR DOWN) means this dir has the `rmangle-cookie'
        ;;   which has been pre[vc]iously examined to ferret out its TAG;
        ;;   ATTR are the `file-attributes' of the cookie; and DOWN are
        ;;   a list of keys "downstream" from the cookie that need to be
        ;;   invalidated on cookie update.
        ds
        ;; File status, one of three values:
        ;; - nil means this file is not under version control;
        ;; - `alas-no' means this file is not under release manglement;
        ;; - a list (REV SINCE RELS AFTER ATTR) means the last release
        ;;   (corresponding to the tag found in `rmangle-cookie')
        ;;   occurred for file-specific revision REV (a string), and there
        ;;   were SINCE (a number) revisions afterwards, and additionally RELS
        ;;   releases (list of strings) where the version control state was
        ;;   set to "Rel" for some unspecified reason, and AFTER number of
        ;;   revisions after the last Rel.  ATTR are file attributes.
        ;; REV ending in ".0" means that the file was added since the last
        ;; release; there is actually no such revision.
        fs)
    (flet ((bye! (sym) (remhash sym rmangle-status))
           (>sym (x) (intern (expand-file-name x)))
           (rget (s) (gethash (>sym s) rmangle-status))
           (rput (s v) (puthash (>sym s) v rmangle-status))
           (try (dir) (let* ((full (expand-file-name rmangle-cookie dir))
                             (attr (file-attributes full))
                             (look (rget dir))
                             (prev (and (consp look) look))
                             (prev-attr (nth 1 prev)))
                        (cond ((and attr prev-attr (equal attr prev-attr))
                               prev)
                              (attr
                               (mapc 'bye! (nth 2 prev))
                               (list (with-temp-buffer
                                       (insert-file-contents full)
                                       (car (split-string (buffer-string))))
                                     attr
                                     nil)) ; downstream keys
                              (prev-attr
                               (mapc 'bye! (nth 2 prev))
                               'alas-no)
                              (t
                               'alas-no))))
           (dir! (dir) (rput dir (try dir))))
      (setq
       ;; never nil
       ds
       (let ((dir dd)
             (chain (list))
             (alas-no t)
             (leafp t))
         (while (and alas-no leafp)
           (if (setq alas-no (eq 'alas-no (dir! dir)))
               (setq chain (cons dir chain)
                     dir (directory-file-name
                          (file-name-directory dir))
                     leafp (not (string= dir (car chain))))
             (let* ((yes (>sym dir))
                    (yes-ent (rget dir))
                    (kids (nth 2 yes-ent)))
               (dolist (child chain)
                 (let ((csym (>sym child)))
                   (setq kids (cons csym (delq csym kids))))
                 (rput child yes))
               (setcar (nthcdr 2 yes-ent) kids))))
         (let ((resolved (rget dd)))
           (while (and (not (eq 'alas-no resolved))
                       (symbolp resolved))
             (setq resolved (rget (symbol-name resolved))))
           resolved))
       ;; possibly nil
       fs
       (when vc-mode
         (let ((nn (expand-file-name buffer-file-name)))
           (cond ((eq 'alas-no ds) ds)
                 ((let ((cache (rget nn)))
                    (and cache (equal (file-attributes nn)
                                      (nth 4 cache))
                         cache)))
                 (t
                  (push (>sym nn) (nth 2 ds))
                  (rput nn (funcall (or (get (vc-backend nn)
                                             'update-rmanglement)
                                        (lambda (nn tag)
                                          nil))
                                    nn
                                    (car ds)))))))
       ;; for the mode line
       rmanglement
       (when (and fs (consp fs))
         (let ((since (nth 1 fs))
               (maybe (nth 2 fs))
               (after (nth 3 fs)))
           (propertize (format "/%s%s%s"
                               (if (= 0 since) "Rel" since)
                               (make-string (length maybe) ?!)
                               (if (and after (< 0 after)) after ""))
                       :since since
                       :maybe maybe
                       :after after)))))))

(put 'RCS 'update-rmanglement
     (lambda (nn tag)
       (message "NOTE: `rmangle-rcs-file-status' not yet written")
       (sit-for 2)
       nil))

(put 'CVS 'update-rmanglement
     (lambda (nn tag)
       (flet ((>n (s) (string-to-number (car (last (split-string s "\\.")))))
              (!! (s &rest args) (shell-command-to-string
                                  (apply 'format s args))))
         (let* ((cur (substring vc-mode 5))
                (lrev (let ((log (!! "cvs log -h %s" nn)))
                        (if (string-match (format "^\\s-+%s: \\(.+\\)$" tag)
                                          log)
                            (match-string 1 log)
                          (setq log (split-string cur "\\."))
                          (setcar (last log) "0")
                          (mapconcat 'identity log "."))))
                (samep (string= lrev cur))
                (post (unless samep
                        (let ((log (!! "cvs log -N -S -sRel -r%s:: %s"
                                       lrev nn))
                              (start 0)
                              acc)
                          (while (string-match "^revision \\([0-9.]+\\)"
                                               log start)
                            (push (match-string 1 log) acc)
                            (setq start (match-end 0)))
                          acc))))
           (list lrev
                 (- (>n cur) (>n lrev))
                 post
                 (when post
                   (- (>n cur)
                      (>n (car (reverse post)))))
                 (file-attributes nn))))))

(put 'Git 'update-rmanglement
     (lambda (nn tag)
       (let* ((cmd (format "git diff --shortstat --exit-code %s -- %s"
                           tag (file-relative-name nn)))
              (ans (shell-command-to-string cmd))
              (i/d (if (string-match "\\([0-9]+\\) ins.*\\([0-9]+\\) del" ans)
                       (string-to-number (mapconcat (lambda (n)
                                                      (match-string n ans))
                                                    '(1 2)
                                                    "."))
                     0)))
         (list "master"                 ; fixme
               i/d
               nil nil
               (file-attributes nn)))))

;;;###autoload
(defun describe-rmangle-status (all)
  "Describe `rmangle-status' contents in another buffer.
By default, filter out entries not in or under the default directory,
filter out directory entries that either point to the topdir or have
`alas-no' indication, and display filenames starting with \".\".  Prefix
arg ALL means no filtering; show all entries with absolute filenames.

The display buffer is placed in Emacs Lisp mode and contains two
forms: the current-time (followed by a human readable comment to
the same effect) and the `rmangle-status' contents as an alist."
  (interactive "P")
  (let* ((dd (substring (expand-file-name default-directory) 0 -1))
         (cut (length dd))
         acc)
    (when (hash-table-p rmangle-status)
      (maphash
       (lambda (k v)
         (let ((full (symbol-name k)))
           (if all
               (push (cons full v) acc)
             (when (and (not (symbolp v))
                        (eq t (compare-strings dd 0 nil full 0 cut)))
               (push (cons (concat "." (substring full cut)) v) acc)))))
       rmangle-status))
    (switch-to-buffer (concat
                       (unless all
                         (format "%s " (abbreviate-file-name dd)))
                       "*Rmangle Status*"))
    (erase-buffer)
    (emacs-lisp-mode)
    (save-excursion
      (insert (format "\n%S ;; %s\n\n"
                      (current-time)
                      (format-time-string "%Y-%m-%d %H:%M:%S")))
      (pp (sort acc (lambda (a b) (string< (car a) (car b))))
          (current-buffer)))))

;;;###autoload
(defun release ()
  "Change the state of the current buffer's file to \"Rel\".
Signal error if buffer is not visiting a file
or if the file is not under version control."
  (interactive)
  (unless buffer-file-name
    (error "No file associated with this buffer"))
  (unless (vc-backend buffer-file-name)
    (error "Not under version control"))
  (more-vc-set-state (list buffer-file-name) "Rel"))

;;;---------------------------------------------------------------------------
;;; load-time actions

(make-variable-buffer-local 'rmanglement)

(add-hook 'before-save-hook             ; handle C-x C-w to a new filename
          (defun clear-rmanglement-maybe ()
            (unless vc-mode (setq rmanglement nil))))

(defvar inhibit-rmangle-mode-line-splicing)

(unless (let ((v 'inhibit-rmangle-mode-line-splicing))
          (and (boundp v) (symbol-value v)))
  (set 'inhibit-rmangle-mode-line-splicing t)
  (let* ((ent '(rmanglement rmanglement))
         (mlf (default-value 'mode-line-format))
         (splice (member* 'vc-mode mlf :key (lambda (x)
                                              (and (consp x)
                                                   (car x))))))
    (unless (symbolp (cadar splice))
      (setq splice (memq 'vc-mode (cadar splice))))
    (setcdr splice (cons ent (cdr splice)))))

(provide 'rmangle)

;;; rmangle.el ends here