external/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: <2006-07-31 14:46:56 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   (cond ((string-equal (symbol-name (class-name (class-of module)))
  23                        "tinaa-directory")
  24          (list (pathname-in-parent (asdf:component-pathname module) system)))
  25         (t
  26          (append
  27           (typecase module
  28             (asdf:system (list
  29                           (pathname-in-parent
  30                            (truename (asdf:system-definition-pathname module))
  31                            system))))
  32           (mapcan #'(lambda (x)
  33                       (typecase x
  34                         (asdf:module (list-module-files x system))
  35                         (t (let ((path (asdf:component-pathname x)))
  36                              (when path
  37                                (list
  38                                 (pathname-in-parent
  39                                  path
  40                                  system)))))))
  41                   (asdf:module-components module))))))
  42
  43 (defun make-dist (&rest module-keywords)
  44   (let ((modules (mapcar
  45                   #'(lambda (k) (asdf:find-system k))
  46                   module-keywords)))
  47     (let ((module (car modules))
  48           (files-for-dist
  49            (mapcan
  50             #'(lambda (module)
  51                 (list-module-files module module))
  52             modules)))
  53       (with-open-file (gzip-file
  54                        (concatenate 'string
  55                                     (asdf:component-name module)
  56                                     "-"
  57                                     (asdf:component-version module)
  58                                   ".tar.gz")
  59                        :if-does-not-exist :create
  60                        :if-exists :supersede
  61                        :direction :output)
  62         (let ((*default-pathname-defaults*
  63                (truename
  64                 (merge-pathnames
  65                  (make-pathname :directory '(:relative :up))
  66                  (make-pathname
  67                   :directory
  68                   (pathname-directory
  69                    (asdf:system-definition-pathname module)))))))
  70           (with-current-directory *default-pathname-defaults*
  71             (ch-util:run-program
  72              "/usr/bin/gzip"
  73              '("-c")
  74              :input (ch-util:process-output-stream
  75                      (ch-util:run-program
  76                       "/usr/bin/tar"
  77                       (append
  78                        '("-cf" "-")
  79                        (print files-for-dist))
  80                       :wait nil
  81                       :output :stream
  82                       :error #p"/dev/null"
  83                       :if-error-exists :append))
  84              :output gzip-file)))))))
  85
  86 (defun unregister-system (name)
  87   (remhash name asdf::*defined-systems*))