;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun Jul 08 03:59:45 2007 -0600 <enometh@net.meer>
;;;   Time-stamp: <2008-04-29 10:01:29 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Status: Experimental.  Do not redistribute
;;;   Copyright (C) 2007 Madhu.  All Rights Reserved.
;;;
(defpackage "GIT-IMPL-1-1"
  (:use "CL")
  (:export
   "GIT-SLOW-IMPORT"
   "GIT-LIST-FILES"
   "GIT-LIST-DELETED-FILES"
   "SHELL-LIST-FILES")
  (:nicknames
   "GIT"
   "GIT-IMPL"))
(in-package "GIT-IMPL-1-1")

(defvar $name "Madhu")
(defvar $addr "enometh@net.meer")
(defvar $git-exec-path nil)

(when $git-exec-path
  (let ((dir (user::probe-directory $git-exec-path)))
    (when dir
      #+(and nil win32 lispworks)
      (user:add-to-env "PATH" $git-exec-path ";" t)
      ;; TWEAK CMUCL's EXT:*ENVIRONMENT-LIST* FOR EXT:RUN-PROGRAM
      #+cmu
      (unless (find dir (ext:search-list "path:") :test #'equal)
	(user::nconcf (ext:search-list "path:") (list dir)))
      (user:setenv "GIT_EXEC_PATH" $git-exec-path))))

(user:setenv "GIT_COMMITTER_NAME" $name)
(user:setenv "GIT_AUTHOR_NAME" $name)
(user:setenv "GIT_COMMITTER_EMAIL" $addr)
(user:setenv "GIT_AUTHOR_EMAIL" $addr)

#+(and lispworks)
(defun chomp (x)
  (let ((l (length x)))
    (cond ((> l 0)
	   (decf l)
	   (if (char= (char x l) #\Newline)
	       (user:substr x 0 l)
	       x))
	  (t x))))

;;;
;;;
;;;
(defun git-list-files ()
  "Return a list of strings denoting pathnames."
  (let ((string (with-output-to-string (stream)
		       (user:with-defaults (:output stream)
			 (user:run2 "git" "ls-files" "-z")))))
    #+mswindows
    (setq string (chomp string))
    (user:string-split #\Null string :collect-empty nil)))

(defun git-list-refs ()
  "Wrapper around git-for-each-ref.
Returns a list of (objectname objectype refname)."
  (let ((string
	 (with-output-to-string (stream)
	   (user:with-defaults (:output stream)
	     (user:run2 "git-for-each-ref")))))
    #+mswindows
    (setq string (chomp string))
    (mapcar (lambda (x) (user:string-split '(#\Space #\Tab) x))
	    (user:string-split  #\Newline string :collect-empty nil))))

(defun git-list-deleted-files ()
  (let ((string
	 (with-output-to-string (stream)
	   (user:with-defaults (:output stream)
	     (user:run2 "git-ls-files" "-z" "--deleted")))))
    #+mswindows
    (setq string (chomp string))
    (user:string-split #\Null string :collect-empty nil)))

(defun git-list-diff-index-cached ()
  "Return a list of strings denoting files which will be affected by
the next commit. Second value is an alist of (status . files), which
groups the files according to their statuses."
  (let ((string (with-output-to-string (stream)
			 (user:with-defaults (:output stream)
			   (user:run2 "git" "diff-index"
				      "--cached"
				      "-z" "--name-status"
				      "HEAD")))))
    #+(and lispworks)
    (setq string (chomp string))
    (loop with alist
	  for (status file) on
	  (user:string-split #\Null string :collect-empty nil)
	  by #'cddr
	  for cons = (assoc status alist :test #'equal)
	  do (assert status)		; XXX fails here when no .git
	  (assert file nil "Expected (status file). got ~S" status)
	  collect file into files
	  if cons do (push file (cdr cons))
	  else do (push (list status file) alist)
	  finally (return (values files alist)))))

;;;
;;;
(defvar $commit-magic
  (concatenate 'string
	       (string (code-char 0))
	       (string (code-char 0))
	       "commit ")
  "Internal. For matching commit lines in git-log")

#+(and lispworks win32)			;madhu 070806 XXX HACK
(unless (find-symbol "$STDOUT" :USER)
  (export (list (intern "$STDOUT" :USER)) :USER))

(defun make-timestamp-string (timestamp &key unix-time-p)
  "Internal."
  (etypecase timestamp
    (integer
     (when (cond (unix-time-p (> timestamp user:+unix-epoch+))
		 (t (< timestamp user:+unix-epoch+)))
       (warn "Fishy time: ~A ~:[Universal~;Unix~]" timestamp unix-time-p))
     (user:iso-8601-date
      :stream nil
      :utime (if unix-time-p
		 (user:universal-time timestamp)
		 timestamp)
      :tz 0
      :suppress-tz-p nil))
    (string timestamp)))

(defun git-reset-mtimes ()
  "Algorithm from Eric Wong's git-set-file-times perlscript. Set the file
modification times to the time of the last commit. Does not work in the
presence of merges. Always resets time even if the modified file is newer,
could break `make'."
  (let ((all-files (make-hash-table :test #'equal))
	(ostream #-cmu (make-string-output-stream) #+cmu :stream)
	(istream #-cmu nil #+cmu user:$stdout)
	#-cmu string)
    (map nil (lambda (x) (setf (gethash x all-files) t)) (git-list-files))
    (assert (> (hash-table-count all-files) 0)  nil "No files found")
    (user:with-defaults (:output ostream)
      (user:run2 "git" "log" "-r" "--name-only" "--no-color"
		 "--pretty=raw" "-z"))
    #-cmu
    (setq istream (make-string-input-stream
		   (setq string
			 (get-output-stream-string ostream))))
    (loop with commit-time
	  for line = (read-line istream nil nil)
	  for pos = nil while line do
	  (cond ((setq pos (user:safe-string-match-position "committer" line))
		 (let* ((parts
			 (nreverse (user:string-split #\Space line :start pos)))
			(zone (pop parts))
			(unix-time (pop parts)))
		   (user:convert-zone-string zone) ;; NOP
		   (setq commit-time (parse-integer unix-time))))
		((setq pos (search $commit-magic line))
		 (let ((files (user:string-split #\Null line :end pos)))
		   (assert (numberp commit-time))
		   (loop for file in files
			 when (gethash file all-files) do
			 (setf (user:unix-mtime file) commit-time)
			 (remhash file all-files))
		   (setq commit-time nil))
		 (if (zerop (hash-table-count all-files))
		     (return))))
	  finally
	  (unless (zerop (hash-table-count all-files))
	    (assert (numberp commit-time))
	    (warn "Processing files: Initial Commit ~A"
		  (make-timestamp-string commit-time :unix-time-p t))
	    (loop for file being each hash-key of all-files do
		  (warn "~A" file)
		  (setf (user:unix-mtime file) commit-time))))))

;;;
;;;
;;;
(defun make-commit-message-string-1 (files2 timestamp &key commit-of trailer)
  "Internal. CVS Style commit-message listing files. Return NIL if no files
are given,otherwise return a string."
  (check-type timestamp string)
  (let ((nfiles (length files2)))
    (when (> nfiles 0)
      (format nil "~:[ Commit of ~;~:*~A ~]~A.
Last Modified: ~A~@[~&Files:~{~<~%Files:~1,72:; ~A~>~^,~}.~]~&~@[~A~&~]"
	      commit-of
	      (if (= nfiles 1)
		  (car files2)
		  (format nil "~D file~:P" nfiles))
	      timestamp
	      (if (= nfiles 1)
		  nil
		  files2)
	      trailer))))

(defun commit-helper (unix-time files2 commit-of trailer dry-run-p prompt-p)
  (let* ((timestamp (make-timestamp-string unix-time :unix-time-p t))
	 (commitmsg (make-commit-message-string-1 files2 timestamp
						  :commit-of commit-of
						  :trailer trailer)))
    (if dry-run-p
	(progn
	  (format t "~S: commiting files ~S~%" timestamp commitmsg)
	  (user:run2 "git" "reset"))
	(tagbody
	   (if prompt-p
	       (restart-case
		   (error "Next commit: timestamp: ~S commitmsg:~&~S~&"
			  timestamp commitmsg)
		 (proceed ()
		   :report "Proceed with commit and continue."
		   (go doit))
		 (skip ()
		   :report "Skip this commit."
		   (user:run2 "git" "reset")
		   (go skip))))
	 doit
	   (user:with-env-vars ((:GIT_COMMITTER_DATE timestamp)
				(:GIT_AUTHOR_DATE timestamp))
	     (user:with-defaults ()
	       (user:run2 "git" "commit" "-m" commitmsg)))
	 skip
	   ))))


;;;
;;;
(defun git-slow-import (filelist &key commit-of trailer dry-run-p prompt-p)
  "Sort the files in the list FILELIST according to their modification times
into N groups and do N commits using the modification times as commit times,
after adding the files to the index via git-add.  COMMIT-OF is a string which
if supplied is prepended to each commit message.

The strings in FILELIST should match what git-status would print, after adding
the files to the index.  This is because we want to verify that the list of
files actually affected is a subset of the group of files being committed
before performing the commit.  Note if this is an initial commit, we cannot
get a list of affected files and the operation will fail; dropping you into
the debugger: choose the continue-initial-import restart to continue.

If dry-run-p is non-NIL nothing is comitted, but INDEX is munged.
"
  (assert (null (user:getenv "GIT_COMMITTER_DATE")))
  (assert (null (user:getenv "GIT_AUTHOR_DATE")))
  (unless (listp filelist) (setq filelist (list filelist))) ; loose
  (let ((sorted-file-list (sort (user:group2 filelist :key #'user:unix-mtime)
				#'< :key #'car))
	(deleted-files (git-list-deleted-files)))
    ;; Handle deletes in a separate commit.
    (when deleted-files
      (let ((namestrings (mapcar #'namestring deleted-files))
	    (unix-time (car (car sorted-file-list))))
	(assert (numberp unix-time)
		(unix-time)
		"Could not get a unix mtime for committing deletes of files~A~S"
		namestrings)
	(user:with-defaults ()
	  (apply #'user:run2
		 `("git" "rm" ,@namestrings)))
	(multiple-value-bind (files2 alist) (git-list-diff-index-cached)
	  (assert (endp (cdr (assoc "M" alist :test #'equal)))
		  nil "Handling deleted files Separately. ~S." alist)
	  (assert (endp (cdr (assoc "A" alist :test #'equal)))
		  nil "Handling deleted files Separately. ~S." alist)
	  (assert (endp (set-difference (cdr (assoc "D" alist :test #'equal))
					namestrings
					:test #'equal))
		  nil "Handling deleted files Separately. ~&~S~&!=~&~S."
		  namestrings deleted-files)
	  (commit-helper unix-time files2 commit-of trailer
			 dry-run-p prompt-p))))

  (loop for (unix-time . files) in sorted-file-list
	for namestrings = (mapcar #+cmu #'unix::unix-namestring
				  #-cmu #'namestring
				  files)
	do
	(let (files2 alist)
	  (user:with-defaults ()
	    (apply #'user:run2 `("git" "add" ,@namestrings)))
	  (restart-case
	      (multiple-value-setq (files2 alist)
		(git-list-diff-index-cached))
	    (continue-initial-import () ; kludge the empty repository case
	      :report "Continue, using supplied files for Initial Import."
	      (setq files2 files)))
	  (format t "~@[Files omitted by GIT from list: ~S~]~&"
		  (set-difference files files2 :test #'equal))
	  (with-simple-restart (continue "Continue Anyway.")
	    (assert (null (set-difference files2 files :test #'equal))
		    nil
		    "Next commit affects more files than expected.
Affected: ~S~&Expected: ~S~&Status List: ~S"
		    files2 files alist))
	  (when files2
	    (commit-helper unix-time files2 commit-of trailer
			   dry-run-p prompt-p))))))

(defun make-command-line-string (&rest args)
  (reduce (lambda (a b) (concatenate 'string a " " b)) args))

(defun shell-list-files ()
  "Return a list of all strings denoting pathnames of all files in the default
directory. Excludes .git and .hg"
  (let ((string (with-output-to-string (stream)
		  (user:with-defaults (:output stream)
		    (user:run2
		     "sh" "-c"		;ensures find rather than find.com
		     (make-command-line-string
		      "find"
		      "-path" "./.git" "-prune"
		      "-o"
		      "-path" "./.hg" "-prune"
		      "-o"
		      "-type" "f" "-print0"))))))
    #+(and lispworks)
    (setq string (chomp string))
    (mapcar (lambda  (s)
	      (assert (char= (aref string 0) #\.) nil s)
	      (assert (char= (aref string 1) #\/) nil s)
	      (user:substr s 2))
	    (user:string-split #\Null string :collect-empty nil))))

#||
(user:in-directory "home:t/" (shell-list-files))
(user:in-directory "home:t/" (git-reset-mtimes))
(user:in-directory "home:eli/"
  (git-slow-import (shell-list-files)
		   :commit-of
		   "Vendor update on branch `scieneer' (supplied 20051204) 2.0.21.16.2.1"))
(user:in-directory "home:git-tools/eli-20051204-scieneer/"
  (setq $b (pairlis (setq $a (shell-list-files))
		    (mapcar #'user:unix-mtime $a))))
(user:in-directory "home:eli/"
  (setq $d (pairlis (setq $c (shell-list-files))
		    (mapcar #'user:unix-mtime $c))))
(loop for (file . mtime) in $b		; newer
      for cons = (assoc file $d :test #'equal) ; tree
      if (> (cdr cons) mtime)
      collect file)
||#