new ops

To play a bit with ASDF I've been writing a couple of operations that
I find fairly useful, so I thought about sharing them.

Enjoy,

-- 
walter pelissero
http://www.pelissero.de


----------------------------------------------------------------------
;;;  asdfadd.lisp --- addenda to asdf

;;; This file adds three operations to ASDF standard repertoire:
;;; pack-op, tag-op and stat-op.  The first one creates a tar/zip
;;; archive of the files in a system.  The second one creates a tag
;;; file (Emacs or Vi compatible).  The last one, stat-op, gives some
;;; statistics on the system files.  Check the documentation of each
;;; class for further details.
;;;
;;; Usage:
;;;   (asdf:oos 'asdf:pack-op :sysname &key (archive-type :tgz) (output-file nil))
;;;   (asdf:oos 'asdf:tag-op :sysname &key (tags-type :etags))
;;;   (asdf:oos 'asdf:stat-op :sysname &key (source-only nil))

(in-package :asdf)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A few bits lifted from CLOCC's port system, so that ASDF can stay
;;; independent.

#+sbcl
(require :sb-posix)

(defun default-directory ()
  "The current working directory."
  #+allegro (excl:current-directory)
  #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
  #+cmu (ext:default-directory)
  #+cormanlisp (ccl:get-current-directory)
  #+lispworks (hcl:get-working-directory)
  #+lucid (lcl:working-directory)
  #+sbcl (pathname (sb-unix:posix-getcwd/))
  #-(or allegro clisp cmu cormanlisp lispworks lucid sbcl) (truename "."))

(defun chdir (dir)
  "Change current working directiory."
  #+allegro (excl:chdir dir)
  #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
  #+cmu (setf (ext:default-directory) dir)
  #+cormanlisp (ccl:set-current-directory dir)
  #+gcl (si:chdir dir)
  #+lispworks (hcl:change-directory dir)
  #+lucid (lcl:working-directory dir)
  #+sbcl (sb-posix:chdir dir)
  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
  (error "chdir not implemented"))

(defsetf default-directory chdir
    "Change the current directory.")

(defmacro with-cwd (dir &body body)
  "Execute BODY while in DIR directory."
  (let ((olddir (gensym)))
    `(let ((,olddir (default-directory)))
       (setf (default-directory) ,dir)
       (unwind-protect
	    (progn ,@body)
	 (setf (default-directory) ,olddir)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun common-path (path1 path2)
  "Return the common directory between two pathnames.  Examples:
  (common-path #P\"/usr/home/john/text.doc\" #P\"/usr/home/bill/me.jpg\") =>
  #P\"/usr/home/\""
  (do ((p1 (pathname-directory path1) (cdr p1))
       (p2 (pathname-directory path2) (cdr p2))
       (result nil))
      ((or (endp p1)
	   (endp p2)
	   (not (equal (car p1) (car p2))))
       (make-pathname :directory (reverse result)))
    (push (car p1) result)))

(defun make-relative-to-common-root (paths)
  "Given a list of pathnames try to find the common root directory.
Return the root and all the pathnames relative to that root."
  (let* ((root (reduce #'common-path paths))
	 (root-length (length (pathname-directory root))))
    (labels ((popn (list)
	       (dotimes (x root-length list)
		 (pop list)))
	     (strip-root (f)
	       (make-pathname :directory (cons :relative (popn (pathname-directory f)))
			      :defaults f)))
      (values root
	      (mapcar #'strip-root paths)))))

(defun default-version-string ()
  "Return a string made up like YYYYMMDD, which turns out to be a
sensible choice to version-tag the archive files."
  (multiple-value-bind (s m h dd mm yy)
      (get-decoded-time)
    (declare (ignore s m h))
    (format nil "~4D~2,'0D~2,'0D" yy mm dd)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass pack-op (operation)
  ((archive-type :type symbol
		 :initarg :archive-type
		 :initform :tgz
		 :reader pack-op-archive-type
		 :documentation
		 "Type of the archive file.  Either :TGZ, :TBZ2 or :ZIP.")
   (output-file :type (or pathname nil)
		:initarg :output-file
		:initform nil
		:reader pack-op-output-file
		:documentation
		"Pathname of the output file.  If NIL this is sensibly computed."))
  (:documentation
   "Operation class for ASDF to archive the complete collection of
files making up a system in a tar file.  Other archivers are
available; see the ARCHIVE-TYPE slot.  Currently supported formats are
:TGZ, TBZ2 and :ZIP. The output file can be chosen as well; see the
OUTPUT-FILE slot.

Example:

  (asdf:oos 'asdf:pack-op :foo-system :archive-type :zip
            :output-file #P\"foo.jar\")"))

(defmethod perform ((operation pack-op) (component system))
  (let ((system-file (truename (system-definition-pathname (component-system component))))
	(output-file (car (output-files operation component))))
    (multiple-value-bind (root files)
	(make-relative-to-common-root (cons system-file (input-files operation component)))
      (with-cwd root
	(run-shell-command "~A '~A'~{ '~A'~}"
			   (case (pack-op-archive-type operation)
			     (:tgz "tar czf")
			     (:tbz2 #+bsd "tar cyf" #-bsd "tar cjf")
			     (:zip "zip"))
			   (namestring output-file)
			   (mapcar #'namestring files))))))

(defmethod perform ((operation pack-op) component)
  nil)

(defmethod output-files ((operation pack-op) (component system))
  (let ((system-pathname (truename (system-definition-pathname (component-system component)))))
    (list (or (pack-op-output-file operation)
	      (make-pathname :defaults system-pathname
			     :name (format nil "~A-~A"
					   (pathname-name system-pathname)
					   (if (and (slot-boundp component 'version)
						    (component-version component))
					       (component-version component)
					       (default-version-string)))
			     :type (case (pack-op-archive-type operation)
				     (:tgz "tar.gz")
				     (:tbz2 "tar.bz2")
				     (:zip "zip")))))))

;; IMHO this should have been generalised to _any_ kind of operations
(defmethod input-files ((operation pack-op) (component module))
  (mapcan #'(lambda (c)
	      (input-files operation c))
	  (module-components component)))

(defmethod input-files ((operation pack-op) (component source-file))
  (list (component-pathname component)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass stat-op (operation)
  ((source-only :type boolean
		:initarg :source-only
		:initform nil
		:reader stat-op-source-only
		:documentation
		"If true do statistics about the source files only, excluding
documentation and such.  If false do statistics about the whole
system."))
  (:documentation
   "Operation class for ASDF to gather static statistics on the source
code making up a system.  Currently it simply counts lines, words and
characters with the Unix command \"wc\"."))

(defmethod perform ((operation stat-op) (component system))
  (let ((system-file (truename (system-definition-pathname (component-system component))))
	(files (input-files operation component)))
    (unless (stat-op-source-only operation)
      (push system-file files))
    (run-shell-command "wc ~{ '~A'~}"
		       (mapcar #'namestring files))))

(defmethod perform ((operation stat-op) component)
  nil)

;; IMHO this should have been generalised to _any_ kind of operations
(defmethod input-files ((operation stat-op) (component module))
  (mapcan #'(lambda (c)
	      (input-files operation c))
	  (module-components component)))

(defmethod input-files ((operation stat-op) (component source-file))
  (when (or (not (typep component 'static-file))
	    (not (stat-op-source-only operation)))
    (list (component-pathname component))))

(defmethod operation-done-p ((operation stat-op) (component component))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass tag-op (operation)
  ((tags-type :type symbol
	      :initarg :tags-type
	      :initform :etags
	      :reader tag-op-tags-type
	      :documentation
	      "Type of tags to be generated.  Either :ETAGS for Emacs or :CTAGS for Vi."))
  (:documentation
   "Operation class for ASDF to create tag files from the source code
making up a system.  Two formats are supported; see the TAGS-TYPE slot
for details."))

(defmethod perform ((operation tag-op) (component system))
  (run-shell-command "~A '~A' ~{ '~A'~}"
		     (case (tag-op-tags-type operation)
		       (:etags "etags -o")
		       (:ctags "ctags -f"))
		     (namestring (car (output-files operation component)))
		     (mapcar #'namestring (input-files operation component))))

(defmethod perform ((operation tag-op) component)
  nil)

(defmethod output-files ((operation tag-op) (component system))
  (let ((system-file (truename (system-definition-pathname (component-system component)))))
    (list (make-pathname :defaults system-file
			 :name (case (tag-op-tags-type operation)
				 (:etags "TAGS")
				 (:ctags "tags"))
			 :type nil))))

;; IMHO this should have been generalised to _any_ kind of operations
(defmethod input-files ((operation tag-op) (component module))
  (mapcan #'(lambda (c)
	      (input-files operation c))
	  (module-components component)))

(defmethod input-files ((operation tag-op) (component source-file))
  (list (component-pathname component)))

(defmethod input-files ((operation tag-op) (component static-file))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(export '(pack-op stat-op tag-op))


-------------------------------------------------------
This SF.net email is sponsored by: SF.net Giveback Program.
Does SourceForge.net help you be more productive?  Does it
help you create better code?  SHARE THE LOVE, and help us help
YOU!  Click Here: http://sourceforge.net/donate/