kmx git

;; cpkg
;; Copyright 2022 kmx.io <contact@kmx.io>
;;
;; Permission is hereby granted to use this software granted
;; the above copyright notice and this permission paragraph
;; are included in all copies and substantial portions of this
;; software.
;;
;; THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT ANY GUARANTEE OF
;; PURPOSE AND PERFORMANCE. IN NO EVENT WHATSOEVER SHALL THE
;; AUTHOR BE CONSIDERED LIABLE FOR THE USE AND PERFORMANCE OF
;; THIS SOFTWARE.

(in-package :cl-user)

(defpackage :cpkg
  (:use :cl :str)
  (:import-from :repo
                #:basename
                #:dirname
                #:$git
                #:link-submodules
                #:repo-local-dir
                #:run-program
                #:sh
                #:sh-quote
                #:string-ends-with
                #:translate-home)
  (:export
   #:boot
   #:build
   #:clean
   #:clear
   #:configure
   #:define-system
   #:find-repo
   #:find-system
   #:*index*
   #:install
   #:reset
   #:system
   #:*system-definition-search-functions*))

(in-package :cpkg)

#+sbcl
(require :sb-posix)

;; variables

(defvar *index*)

(defvar *repos* ())

(defvar *systems* ())

;; repo

(defun find-repo (repo)
  (let ((repo:*repos* *repos*))
    (repo:find-repo repo)))

(defun install (repo)
  (let ((repo:*index* *index*))
    (repo:install repo)))

;; system

(defvar *system-definition-search-functions*
  '())

(defclass system ()
  ((author :accessor system-author
           :initarg :author
           :type string)
   (description :accessor system-description
                :initarg :description
                :type string)
   (direct-dependencies :accessor system-direct-dependencies
                        :initarg :depends-on
                        :type list)
   (dir :accessor system-dir
        :initarg :dir
        :type string)
   (name :accessor system-name
         :initarg :name
         :initform (error "system name is missing")
         :type symbol)
   (sysdef :accessor system-definition-file
           :initarg :sysdef
           :type string)
   (version :accessor system-version
            :initarg :version
            :type string)))

(defgeneric build (system))
(defgeneric clean (system))
(defgeneric clear (system))
(defgeneric configure (system))
(defgeneric reset (system))
(defgeneric system-dependencies (system))
(defgeneric system-file (system file))

(defmethod print-object ((system system) stream)
  (print-unreadable-object (system stream :type t :identity t)
    (with-slots (name dir) system
      (format stream "~S ~S" name dir))))

(defmethod system-file ((system system) (file string))
  (str (system-dir system) "/" file))

(defun remove-trailing-/ (string)
  (declare (type string string))
  (when (string-ends-with "/" string)
    (subseq string 0 (1- (length string)))))

(defun find-system-by-sysdef (sysdef)
  (find sysdef *systems*
        :key #'system-definition-file
        :test #'string=))

(defun find-system (x)
  (dolist (search-fun *system-definition-search-functions*)
    (let ((sysdef (funcall search-fun x)))
      (when sysdef
        (let* ((sysdef (namestring sysdef))
               (system (or (find-system-by-sysdef sysdef)
                           (progn
                             (load sysdef)
                             (find-system-by-sysdef sysdef)))))
          (when system
            (return system)))))))

(defmethod system-direct-dependencies (x)
  (system-direct-dependencies (the system (find-system x))))

(defmethod system-dependencies ((system system))
  (let (deps)
    (labels ((deep-first-search (s)
               (let ((direct-deps (system-direct-dependencies s)))
                 (when direct-deps
                   (dolist (d direct-deps)
                     (unless (find d deps)
                       (push d deps)
                       (deep-first-search d)))))))
      (deep-first-search system)
      deps)))

(defmethod system-dependencies (x)
  (system-dependencies (the system (find-system x))))

;; file operations

(defun append-to-file (file &rest parts)
  (with-open-file (out file
                       :direction :output
                       :element-type 'character
                       :if-exists :append
                       :if-does-not-exist :create
                       :external-format :utf-8)
    (write-string (str parts) out)))

(defun file-content (file &optional (max-size 1024))
  (when (probe-file file)
    (with-open-file (in file
                        :element-type 'character
                        :external-format :utf-8)
      (let* ((seq (make-sequence 'string max-size))
             (len (read-sequence seq in)))
        (subseq seq 0 len)))))

(defun write-file (file &rest parts)
  (with-open-file (out file
                       :direction :output
                       :element-type 'character
                       :external-format :utf-8
                       :if-exists :supersede)
    (write-string (str parts) out)))

;; make

(defvar *make*
  #+sbcl (sb-posix:getenv "MAKE"))

(defun system-make (system)
  (or (file-content (system-file system ".cpkg/MAKE"))
      *make*
      "make"))

;; clean

(defmethod clean ((system system))
  (let ((clean (system-file system ".cpkg/clean")))
    (when (probe-file clean)
      (return-from clean (sh clean)))
    (sh (system-make system) " clean")))

(defmethod clean (x)
  (clean (the system (find-system x))))

;; configure

(defun system-autogen (system)
  (dolist (filename '("autogen.sh"
                      "autogen"))
    (let ((path (system-file system filename)))
      (when (probe-file path)
        (return filename)))))

(defun system-configure (system)
  (dolist (filename '("configure.sh"
                      "configure"))
    (let ((path (system-file system filename)))
      (when (probe-file path)
        (return filename)))))

(defmethod configure ((system system))
  (let ((cpkg-dir (system-file system ".cpkg/"))
        (configure-done (system-file system ".cpkg/configure-done"))
        (log (system-file system ".cpkg/log")))
    (unless (probe-file configure-done)
      (let ((autogen (system-autogen system)))
        (ensure-directories-exist cpkg-dir)
        (write-file log "#!/bin/sh" #\Newline
                    "set -e" #\Newline
                    "cd \"$0\"/../.." #\Newline)
        (when autogen
          (unless (sh "cd " (sh-quote (translate-home
                                       (system-dir system)))
                      " && ./" autogen)
            (error "autogen failed"))
          (append-to-file log "./" autogen #\Newline))
        (let ((configure (system-configure system)))
          (when configure
            (or (sh "cd " (sh-quote (translate-home
                                     (system-dir system)))
                    " && ./" configure)
                (error "configure failed"))
            (append-to-file log "./" configure #\Newline))
          (write-file configure-done ""))))))

(defmethod configure (system)
  (configure (the system (find-system system))))

;; build

(defmethod build ((system system))
  (let ((build-done (system-file system ".cpkg/build-done"))
        (log (system-file system ".cpkg/log"))
        (make (system-make system)))
    (unless (probe-file build-done)
      (configure system)
      (when (or (probe-file (system-file system "Makefile"))
                (probe-file (system-file system "makefile")))
        (unless (sh make " "
                    "-C "
                    (sh-quote (translate-home
                               (system-dir system))))
          (error "build failed"))
        (append-to-file log make #\Newline)
        (write-file build-done "")))))

(defmethod build (x)
  (build (the system (find-system x))))

;; clear : remove all files except .git and .cpkg

(defmethod clear ((system system))
  (let ((system-dir-sh (sh-quote
                              (translate-home
                               (system-dir system)))))
    (sh "find " system-dir-sh " -name '.git' -prune "
        ""                       "-or -name '.cpkg' -prune "
        ""                       "-or -type f -print0 "
        "| xargs -0 rm -f")
    (sh "rm -f " system-dir-sh "/.cpkg/*-done")
    (sh "find " system-dir-sh " -name '.git' -prune "
        ""                       "-or -name '.cpkg' -prune "
        ""                       "-or -type d -print0 "
        "| xargs -0 rmdir 2>/dev/null || true")))

(defmethod clear (x)
  (clear (the system (find-system x))))

;; reset

(defmethod reset ((system system))
  (clear system)
  (let ((system-dir (translate-home (system-dir system))))
    ($git "-C" system-dir "reset" "--hard")
    (link-submodules (system-name system))))

(defmethod reset (x)
  (reset (the system (find-system x))))

;; start cpkg : load index and link with repo

(defun repo-local-dir-sysdef (repo x)
  (str (repo-local-dir repo) "/.cpkg/" (string-downcase x) ".sysdef.lisp"))

(defun sysdef-cpkg (x)
  (let ((repo:*index* *index*))
    (repo:sysdef x #'repo-local-dir-sysdef)))

(defun boot (&optional (dir "~/cpkg"))
  (let ((index-file (str dir "/repo-index.lisp")))
    (when (probe-file index-file)
      (setq *index* (repo:index index-file))
      (setq *repos* (repo:index-repos *index*))
      (when (find-package :cpkg)
        (pushnew 'sysdef-cpkg
                 (symbol-value
                  (intern "*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*"
                          :cpkg)))))))

;; sysdef

(defmacro define-system (name &key
                                author
                                depends-on
                                description
                                version)
  (let ((sysdef (gensym "SYSDEF-"))
        (system (gensym "SYSTEM-")))
    `(let* ((,sysdef ,(namestring *load-pathname*))
            (,system (make-instance 'system
                                    :author ',author
                                    :depends-on ',depends-on
                                    :dir (dirname (dirname ,sysdef))
                                    :description ',description
                                    :name ',name
                                    :sysdef ,sysdef
                                    :version ',version)))
       (setf *systems* (cons ,system
                             (delete ,sysdef
                                     *systems*
                                     :key #'system-definition-file
                                     :test #'string=))))))
kmx.io/cpkg/cpkg.lisp

Commit

cpkg.lisp
