clsr/ch-util/src/ch-asdf.cl

   1 ;;;
   2 ;;; ch-asdf.cl -- various lisp utilities that make my life easier
   3 ;;;
   4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
   5 ;;; Time-stamp: <2005-07-01 08:12:53 sly>
   6 ;;;
   7
   8 (in-package :ch-util)
   9
  10 (defun pathname-in-parent (path system)
  11   (enough-namestring
  12    path
  13    (truename
  14     (merge-pathnames
  15      (make-pathname :directory '(:relative :up))
  16      (make-pathname
  17       :directory
  18       (pathname-directory
  19        (asdf:system-definition-pathname system)))))))
  20
  21 (defun list-module-files (module system)
  22   (append
  23    (typecase module
  24      (asdf:system (list
  25                    (pathname-in-parent
  26                     (truename (asdf:system-definition-pathname module))
  27                     system))))
  28    (mapcan #'(lambda (x)
  29                (typecase x
  30                  (asdf:module (list-module-files x system))
  31                  (t (list
  32                      (pathname-in-parent (asdf:component-pathname x)
  33                                          system)))))
  34            (asdf:module-components module))))
  35
  36 (defun make-dist (&rest module-keywords)
  37   (let ((modules (mapcar
  38                   #'(lambda (k) (asdf:find-system k))
  39                   module-keywords)))
  40     (let ((module (car modules))
  41           (files-for-dist
  42            (mapcan
  43             #'(lambda (module) (list-module-files module module))
  44             modules)))
  45       (with-open-file (gzip-file
  46                        (concatenate 'string
  47                                     (asdf:component-name module)
  48                                     "-"
  49                                     (asdf:component-version module)
  50                                   ".tar.gz")
  51                        :if-does-not-exist :create
  52                        :if-exists :supersede
  53                        :direction :output)
  54         (let ((*default-pathname-defaults*
  55                (truename
  56                 (merge-pathnames
  57                  (make-pathname :directory '(:relative :up))
  58                  (make-pathname
  59                   :directory
  60                   (pathname-directory
  61                    (asdf:system-definition-pathname module)))))))
  62           (with-current-directory *default-pathname-defaults*
  63             (ch-util:run-program
  64              "/usr/bin/gzip"
  65              '("-c")
  66              :input (ch-util:process-output-stream
  67                      (ch-util:run-program
  68                       "/usr/bin/tar"
  69                       (append
  70                        '("-cf" "-")
  71                        files-for-dist)
  72                       :wait nil
  73                       :output :stream
  74                       :error #p"/dev/null"
  75                       :if-error-exists :append))
  76              :output gzip-file)))))))
  77
  78 (defun unregister-system (name)
  79   (remhash name asdf::*defined-systems*))