":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation
;;;;; Can also be invoked by cl-launch 4: cl-launch "$0" "$@"

;;; The code below exemplifies how to load and configure ASDF
;;; as part of your own deterministic build.
;;; See "User-configurable parts" for where you'd customize it to suit your build.
;;;
;;; Everything is MUCH simpler if you can assume your implementation has a recent-enough ASDF 3:
;;; just (require "asdf"), then configure in a subsequent eval-when form,
;;; in which you may then use asdf: and uiop: prefix.
;;;
;;; To use the user-configured ASDF rather than a deterministic self-contained project build,
;;; see instead how cl-launch 4.0.4 loads ASDF.

(in-package :cl-user) ;; That's may be default, but let's make double sure and tell SLIME.

;; Do everything in eval-when, so this works
;; whether this file is being loaded directly or compiled first.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let* ((this (or *load-pathname* *compile-file-pathname*)))
    (load (merge-pathnames (make-pathname :name "load-asdf" :type "lisp"
                                          :directory '(:relative :back "tools")
                                          :defaults this) this))))

(in-package :asdf)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (load-systems :cl-ppcre :fare-utils :inferior-shell))

(unless (featurep :cl-launch) (restore-image))

(defpackage :asdf-builder
  (:use :cl :uiop :asdf/operate :asdf :fare-utils :inferior-shell)
  (:shadow #:DBG))

(in-package :asdf-builder)

(uiop-debug)

(defun build-asdf ()
  "Make sure asdf.lisp is built"
  (load-system :asdf)
  (values))


;;; ASDF directory
(defvar *asdf-dir*
  (ensure-pathname (system-relative-pathname :asdf/defsystem ())
                   :want-physical t :want-absolute t
                   :want-existing t :truename t))
(defun pn (&rest x)
  (subpathname *asdf-dir* (and x (uiop:resolve-relative-location x))))
(defun nn (&rest x)
  (native-namestring (apply 'pn x)))

;;; UIOP directory
(defvar *uiop-dir* (pn "uiop/"))

;;; build directory
(defparameter *build-dir* (pn "build/"))
(defparameter /build-dir/ (nn "build/"))
(defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys))

(defparameter *version-file*
  (pn "version.lisp-expr"))

(defparameter *version* (safe-read-file-form *version-file*))

(defun enough-namestring! (base pathname)
  (let ((e (enough-namestring base pathname)))
    (assert (relative-pathname-p e))
    e))

(defun enough-namestrings (base pathnames)
  (loop :with b = (ensure-pathname base :want-absolute t :want-directory t)
        :for p :in pathnames
        :collect (enough-namestring! p b)))

(defun system-source-files (system)
  (let* ((sys (find-system system))
         (dir (ensure-pathname
               (system-source-directory sys)
               :want-absolute t :want-directory t))
         (components
           (required-components
            sys :other-systems nil
            :goal-operation 'load-op
            :keep-operation 'load-op
            :keep-component 'file-component))
         (pathnames (mapcar 'component-pathname components)))
    (enough-namestrings dir pathnames)))

(defun tarname (name) (strcat name ".tar.gz"))

(defun make-tarball-under-build (name base files)
  (check-type name string)
  (ensure-pathname base :want-absolute t :want-existing t :want-directory t)
  (dolist (f files)
    (check-type f string))
  (let* ((base
           (ensure-pathname
            base
            :want-absolute t :want-directory t
            :want-existing t :truename t))
         (destination
           (ensure-pathname
            name
            :defaults *build-dir*
            :want-relative t :ensure-absolute t
            :ensure-subpath t :ensure-directory t))
         (tarball
           (ensure-pathname
            (tarname name)
            :defaults *build-dir*
            :want-relative t :ensure-absolute t
            :ensure-subpath t :want-file t
            :ensure-directories-exist t)))
    (assert (< 6 (length (pathname-directory destination))))
    (when (probe-file* destination)
      (error "Destination ~S already exists, not taking chances - you can delete it yourself."
             destination))
    (ensure-directories-exist destination)
    (run `(cp "-pHux" --parents ,@files ,destination) :directory base :show t)
    (run `(tar "zcfC" ,tarball ,*build-dir*
               ;; TODO: Have better autodetection for which tar is being used,
               ;; and fall back to no option if not recognized.
               #+linux (* :owner root :group root) ;; assume GNU tar on Linux.
               #+darwin (* :uid 0 :gid 0) ;; assume BSD tar on Darwin.
               (,name /)) :show t)
    (delete-directory-tree destination :validate #'(lambda (x) (equal x destination)))
    (values)))

(defun uiop-files ()
  "list files in uiop"
  (list* "README.md" "uiop.asd" "asdf-driver.asd" (system-source-files "uiop")))
(defun uiop-name ()
  (format nil "uiop-~A" *version*))
(defun make-uiop-tarball ()
  (make-tarball-under-build (uiop-name) *uiop-dir* (uiop-files)))

(defun asdf-defsystem-files ()
  "list files in asdf/defsystem"
  (list* "build/asdf.lisp" ;; for bootstrap purposes
         "asdf.asd" "version.lisp-expr" "header.lisp"
         (system-source-files "asdf/defsystem")))
(defun asdf-defsystem-name ()
  (format nil "asdf-defsystem-~A" *version*))
(defun make-asdf-defsystem-tarball ()
  (build-asdf)
  (make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files)))

(defun asdf-all-name ()
  (strcat "asdf-" *version*))
(defun asdf-all-files ()
  (remove-if #'(lambda (x) (string-prefix-p "ext/" x))
             (run/lines '(git ls-files))))
(defun make-asdf-all-tarball ()
  (build-asdf)
  (make-tarball-under-build (asdf-all-name) *asdf-dir* (asdf-all-files)))

(defun asdf-lisp-name ()
  (format nil "asdf-~A.lisp" *version*))
(defun make-asdf-lisp ()
  (build-asdf)
  (concatenate-files (list (pn "build/asdf.lisp"))
                     (pn "build/" (asdf-lisp-name))))

(defun make-archive ()
  (make-uiop-tarball)
  (make-asdf-defsystem-tarball)
  (make-asdf-all-tarball)
  (make-asdf-lisp)
  (values))

(defvar *clnet* "common-lisp.net")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")
(defun public-path (x) (strcat *clnet-asdf-public* x))

(defun publish-archive ()
  (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
    (run `(rsync "--times" "--chmod=a+rX,ug+w"
                  ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/")))
          :show t :directory (pn "build/")))
  (format t "~&To download the tarballs, point your browser at:~%
        http://common-lisp.net/project/asdf/archives/
~%")
  (values))

(defun link-archive ()
  (run (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
               (tarname (driver-name))
               (public-path "archives/uiop.tar.gz")
               (tarname (asdf-defsystem-name))
               (public-path "archives/asdf-defsystem.tar.gz")
               (tarname (asdf-git-name))
               (public-path "archives/asdf.tar.gz")
               (asdf-lisp-name)
               (public-path "archives/asdf.lisp"))
       :show t :host *clnet*)
  (values))

(defun make-and-publish-archive ()
  (make-archive)
  (publish-archive)
  (link-archive))

(defparameter *versioned-files*
  '(("version.lisp-expr" "\"" "\"")
    ("uiop/version.lisp-expr" "\"" "\"")
    ("asdf.asd" "  :version \"" "\" ;; to be automatically updated by make bump-version")
    ("header.lisp" "This is ASDF " ": Another System Definition Facility.")
    ("upgrade.lisp" "   (asdf-version \"" "\")")))

(defparameter *old-version* nil)
(defparameter *new-version* nil)

(defun next-version (v)
  (let ((pv (parse-version v 'error)))
    (assert (first pv))
    (assert (second pv))
    (unless (third pv) (appendf pv (list 0)))
    (unless (fourth pv) (appendf pv (list 0)))
    (incf (car (last pv)))
    (unparse-version pv)))

(defun version-from-file ()
  (safe-read-file-form *version-file*))

(defun versions-from-args (&optional v1 v2)
  (labels ((check (old new)
             (parse-version old 'error)
             (parse-version new 'error)
             (values old new)))
    (cond
      ((and v1 v2) (check v1 v2))
      (v1 (check (version-from-file) v1))
      (t (let ((old (version-from-file)))
           (check old (next-version old)))))))

(deftype byte-vector () '(array (unsigned-byte 8) (*)))

(defun maybe-replace-file (file transformer
                           &key (reader 'read-file-string)
                             (writer nil) (comparator 'equalp)
                             (external-format *utf-8-external-format*))
  (format t "Transforming file ~A... " (file-namestring file))
  (let* ((old-contents (funcall reader file))
         (new-contents (funcall transformer old-contents)))
    (if (funcall comparator old-contents new-contents)
        (format t "no changes needed!~%")
        (let ((written-contents
                (if writer
                    (with-output (s ())
                      (funcall writer s new-contents))
                    new-contents)))
          (check-type written-contents (or string (byte-vector)))
          (clobber-file-with-vector file written-contents :external-format external-format)
          (format t "done.~%")))))

(defun version-transformer (new-version file prefix suffix &optional dont-warn)
  (let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
         (versionrx "([0-9]+(\\.[0-9]+)+)")
         (qsuffix (cl-ppcre:quote-meta-chars suffix))
         (regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
         (replacement
           (constantly (strcat prefix new-version suffix))))
    (lambda (text)
      (multiple-value-bind (new-text foundp)
          (cl-ppcre:regex-replace regex text replacement)
        (unless (or foundp dont-warn)
          (warn "Missing version in ~A" (file-namestring file)))
        (values new-text foundp)))))

(defun transform-file (new-version file prefix suffix)
  (maybe-replace-file (pn file) (version-transformer new-version file prefix suffix)))

(defun transform-files (new-version)
  (loop :for f :in *versioned-files* :do (apply 'transform-file new-version f)))

(defun test-transform-file (new-version file prefix suffix)
  (let ((lines (read-file-lines (pn file))))
    (dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
      (multiple-value-bind (new-text foundp)
          (funcall (version-transformer new-version file prefix suffix t) l)
        (when foundp
          (format t "Found a match:~%  ==> ~A~%Replacing with~%  ==> ~A~%~%"
                  l new-text)
          (return t))))))

(defun test-transform (new-version)
  (apply 'test-transform-file new-version (first *versioned-files*)))

(defun bump-version (&optional v1 v2)
  (multiple-value-bind (old-version new-version)
      (versions-from-args v1 v2)
    (a "Bumping ASDF version from " old-version " to " new-version)
    (transform-files new-version)
    (a "Rebuilding ASDF with bumped version")
    (build-asdf)))

(defparameter *version-tag-glob* "[0-9][.][0-9]*")

(defun version-from-tag (&optional commit)
  (first (run/lines `("git" "describe" "--tags" "--match" ,*version-tag-glob* ,commit) :show t)))

(defun version-from-file (&optional commit)
  (if commit
      (run `("git" "show" (,commit":version.lisp-expr")) :output :form)
      (read-file-form *version-file*)))

(defun debian-version-from-file (&optional commit)
  (let ((line
          (if commit
              (run `("git" "show" (,commit":debian/changelog")) :output :line)
              (read-file-line "debian/changelog"))))
    (cl-ppcre:register-groups-bind (ver) ("^cl-asdf [(]([0-9.:-]+)[)] " line)
      ver)))

(defun clean ()
  (with-current-directory ((pn))
    (run '(git clean -xfd)))
  (values))

(defun debian-package (&optional (release "release"))
  (let* ((debian-version (debian-version-from-file release))
         (version (version-from-file release)))
    (unless (cl-ppcre:register-groups-bind (x epoch ver rel)
                ("^(([0-9]+):)?([0-9.]+)-([0-9]+)$" debian-version)
              (declare (ignorable x epoch rel))
              (equal ver version))
      (error "Debian version ~A doesn't match asdf version ~A" debian-version version))
    (clean)
    (format t "building package version ~A~%" (debian-version-from-file))
    (run `(git-buildpackage
           ;; --git-ignore-new ;; for testing purpose
           (--git-debian-branch= ,release)
           (--git-upstream-tag="%(version)s")
           ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
           ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
           --git-tag --git-retag
           ;; --git-no-pristine-tar
           --git-force-create
           --git-ignore-branch)
         :directory (pn) :show t)))

(defun re (arg)
  (eval (read-from-string arg)))

;;;; Main entry point
(defun main (args)
  (block nil
    (unless args
      (format t "No command provided~%")
      (return))
    (if-let (sym (find-symbol* (string-upcase (first args)) :asdf-builder nil))
      (let ((results (multiple-value-list (apply sym (rest args)))))
        (when results
          (format t "~&Results:~%~{  ~S~%~}" results)))
      (format t "Command ~A not found~%" (first args)))))

(main *command-line-arguments*)
