[portage-overlay-devel] asdf versus ebuilds

Thu Feb 1 20:12:48 UTC 2007

Here is my first attempt to make some progress in integrating
asdf-install and portage (in the way that g-cpan integrates
cpan-install and portage).  I hope that some people with more
experience and knowledge will get on board with this project!

I have tested this with sbcl, and with about 10 asdf systems.  I have
had no problems, although there is still an annoying amount of manual
intervention -- one has to make digests for the ebuilds and then
emerge manually.  But please be warned that this is experimental code,
and it could break your system.

Best wishes,
Hans

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

; (in-package :g-asdf)

;;; WARNING: Please use this program with caution, and only if you
;;; know what you are doing.  It modifies files on your hard drive.

;;; you must either run this program as root, or make sure that you
;;; have write permission for your portage overlay directories.

;;; Usage: instead of (asdf:install 'install 'cliki) do (ebuild
;;; "cliki"), and it will create an ebuild of the form
;;; "cl-cliki-N.ebuild", where N is the version number, in your local
;;; portage overlay.  Then you must manually make a digest (ebuild
;;; ... digest), and 
;;; emerge the thing.  Hopefully, in the future the digest-making
;;; and emerging can also be automated.

(require :asdf)

(require :asdf-install)

;; helper functions

(defun split-by-one-space (string)
    "Returns a list of substrings of string
divided by ONE space each.
Note: Two consecutive spaces will be seen as
if there were an empty string between them."
    (loop for i = 0 then (1+ j)
          as j = (position #\Space string :start i)
          collect (subseq string i j)
          while j))

(defun clp (string)
  "Check if string is prefixed by 'cl-'."
   (string-equal string (concatenate 'string "cl-" (subseq string 3))))

(defun prefix-cl (string)
  "Ensure that string is prefixed by 'cl-'."
  (if (clp string) string (concatenate 'string "cl-" string)))

(defun string-replace-all (old new big) 
  "Replace all occurences of OLD string with NEW string in BIG string."
  (do ((i (search old big) (search old big)))
      ((null i) big)
    (setq big
	  (concatenate 'string
		       (subseq big 0 i)
		       new
		       (subseq big (+ i (length old)))))))

(defun escape-quotes (string)
  (let ((escaped (with-output-to-string (o)
    (prin1 string o))))
    (subseq escaped 1 (- (length escaped) 1))))

;; currently we get portage information by invoking 'portageq' from a
;; shell.  Would it be preferable to have lisp parse /etc/make.conf
;; and /etc/make.globals?

(defparameter *portageq* "/usr/bin/portageq"
  "Gentoo portage information query tool.")

(defparameter *portage-overlays* 
  (let* ((string (with-output-to-string (o)
		   (sb-ext:run-program *portageq* '("portdir_overlay") :output o) o))
	 (foo (split-by-one-space string)))
    (loop for x in foo do
	 (setf x (string-trim '(#\Space #\Tab #\Newline) x))
       collect x))
  "A list of Gentoo portage overlay directories.")

;; we will put ebuilds in the first portage overlay, unless otherwise specified

;; convention: directory strings do not have final "/"

(defparameter *ebuild-dir*
  (concatenate 'string (car *portage-overlays*) "/dev-lisp"))

(defparameter *workdir* "/var/tmp/g-asdf"
  "Where we unpack and work on lisp systems in order to generate an ebuild.")

(defvar *temporary-files* nil
  "Files we can discard after ebuild construction is complete.")

;; we will put system tarballs in the Gentoo DISTDIR; then we will not
;; have to download again when we emerge

(defparameter *distdir*
  (string-trim '(#\Space #\Tab #\Newline) 
			       (with-output-to-string (o)
				 (sb-ext:run-program *portageq* 
					     '("distdir") :output o) o))
  "Gentoo portage DISTDIR.")

;;; load-time dependencies

;; question: does this always give every parent that would also be
;; fetched by asdf-install in the case of no previously installed
;; systems?

;; we always prefix a dependency's name with "cl-", assuming that
;; portage will always use this prefix for the names of
;; asdf-installable systems.  (I know of at least one exception:
;; stumpwm.)

(defun dependencies (systemname)
  (mapcar #'string-downcase (cdr (mapcar #'string (cadr (asdf:component-depends-on (make-instance 'asdf:load-op) (asdf:find-component nil systemname)))))))

;; following does not work until package can be found by asdf.

(defun version-number (systemname)
  (asdf::component-version (asdf:find-system systemname)))

(defun tar-save-name (packagename)
  "Full name of the downloaded tarball (in *distdir*)."
  (concatenate 'string *distdir* "/" packagename "-tmp.tar.gz"))

;; Caution: asdf-install has an internal symbol 'untar-package'.  Our
;; usage is slightly different.

(defun untar-file (filename destdir)
  "Untar file to destdir."
  (with-output-to-string (o)
    (or
     (sb-ext:run-program asdf-install::*tar-program*
                         (list "-xzvf" filename "-C" destdir)
                         :output o
                         :search t
                         :wait t)
     (error "can't untar"))))

(defun get-tar-directory (filename)
  "Check *distdir* for the relative name of folder to which files
will be unpacked."
  (let* ((tar (with-output-to-string (o)
                (or
                 (sb-ext:run-program asdf-install::*tar-program*
                                     (list "-tzf" filename)
                                     :output o
                                     :search t
                                     :wait t)
                 (error "can't list archive"))))
         (first-line (subseq tar 0 (position #\newline tar))))
    (if (find #\/ first-line)
        (subseq first-line 0 (position #\/ first-line))
        first-line)))

; this is the external entry point
(defun ebuild (systemname)
  ; download tarball to file called "systemname-tmp.tar.gz" in DISTDIR
  ; (will later replace 'tmp' with version number extracted from .asd file)
  ; TO DO: make sure this tarball is deleted if subsequent stages are not successful
  (let* ((filename (tar-save-name systemname))
	 (old-pathspec (pathname filename)))
    (asdf-install::download-files-for-package systemname filename)
    (let* ((unpackd (get-tar-directory filename))
	   (workdir (concatenate 'string *workdir* "/" unpackd))) ; the resulting unpacked directory
      (untar-file filename *workdir*) ; unpack the file into *workdir*
      (push (make-pathname :directory (subseq workdir 1)) asdf:*central-registry*) ; TO DO: make sure this goes away later, even in event of error
      (let* ((system-depends (dependencies systemname)) 
	     (version (version-number systemname))
	     (asd-files (mapcar 'pathname-name (loop for asd in (directory 
					  (make-pathname :directory `(:absolute ,workdir) :name :wild :type "asd"))
			   collect asd)))
	     ;; some system dependencies might be in the original tarball; so we don't need them
	     (ebuild-depends (mapcar #'prefix-cl (set-difference system-depends asd-files :test #'equal)))
	     (portage-systemname (prefix-cl systemname))
	     (ebuild-name (concatenate 'string portage-systemname "-" version ".ebuild"))
	     (ebuild-dir (concatenate 'string *ebuild-dir* "/" portage-systemname))
	     ;; move the tarball
	     (new-tarball (rename-file old-pathspec 
				       (make-pathname :defaults old-pathspec :type "gz" 
						      :name (prefix-cl (concatenate 'string systemname "-" version ".tar"))))))
	     (ensure-directories-exist (make-pathname :directory ebuild-dir))
	(with-open-file (out (concatenate 'string ebuild-dir "/" ebuild-name) 
			 :direction :output 
			 :if-exists :supersede)  
	  (format out 
"# Copyright 1999-2006 Gentoo Foundation
# Distributed under the terms of the GNU General Public License v2
# $Header: $

inherit common-lisp 

DESCRIPTION=\"~A\"
HOMEPAGE=\"http://www.cliki.net/~A\"
SRC_URI=\"http://www.cliki.net/~A\"      # fake URI, because \"ebuild foo digest\" needs this
RESTRICT=\" fetch mirror \"

LICENSE=\"\~A\"
SLOT=\"0\"
KEYWORDS=\" ~~amd64 ~~ppc ~~sparc ~~x86 \"  
IUSE=\"\"
VERSION=\"~A\"
DEPENDS=\" virtual/commonlisp ~{ dev-lisp/~A ~} \" 

S=${WORKDIR}/~A

CLPACKAGE=~A

src_unpack() {
	unpack ${A}        
}

src_install() {
	common-lisp-install -r *                # just install all files into ${CLSOURCEROOT}; this is what asdf-install would do
	~{ common-lisp-system-symlink ~A~%~}
}

" 
(or (asdf:system-description (asdf:find-system systemname)) "")  ; description of system
systemname ; cliki homepage
(file-namestring new-tarball) ; tarball name
(or (escape-quotes (asdf:system-license (asdf:find-system systemname))) "")   ; license (TO DO - truncate if too long, escape quotation marks)
version
ebuild-depends ; list of ebuild dependencies
unpackd ; directory to which the tarball unpacks files
systemname
asd-files ))))))

;; TO DO: how to ignore or fill in empty slots in package description:
;; license, etc..?

;; TO DO: (version-number ...) only gives one decimal place.  But some
;; packages (e.g. Gary King's asdf-system-connections) need two
;; places, e.g. 0.8.3

;; TO DO: use recursion -- ask the user if she wants to make ebuilds
;; for all of the dependencies; the smart way to do this (see g-cpan)
;; would be to search the portage tree, and ask only if the system is
;; not already in the portage tree

;; TO DO: download chokes if the tarball already exists.  Since asdf
;; packagers do not always include version numbers in their tarball
;; names, we have to do some manual comparison to check for updates
;; (e.g. compare checksums).

;; TO DO: be careful that the system has not already been loaded into
;; memory (e.g. if we are upgrading versions).

;; TO DO: make digests (ebuild foo.ebuild digest) for each new ebuild

;;; end of file g-asdf.lisp

; (ebuild "metatilities")