;; #P"jar:file:/Users/alanr/repos/lsw/trunk/patches/test.jar!/test.abcl" is an object of type PATHNAME:
;;   HOST         NIL
;;   DEVICE       #P"jar:file:/Users/alanr/repos/lsw/trunk/patches/test.jar"
;;   DIRECTORY    (:ABSOLUTE)
;;   NAME         "test"
;;   TYPE         "abcl"
;;   VERSION      NIL

'(advise probe-file
	(let* ((translated (translate-logical-pathname (car arglist)))
	       (device (pathname-device translated)))
	  (if (and device (eql 0 (search "jar:file:" (namestring device))))
	      (probe-file-in-jar translated)
	      (:do-it)))
	:when :around :name  jar-file)

'(defun probe-file-in-jar (pathname)
  (let ((jarfile (subseq (namestring (pathname-device pathname)) 9))
	(rest-pathname (namestring (make-pathname :directory (pathname-directory pathname)
						  :name (pathname-name pathname)
						  :type (pathname-type pathname)))))
    (and (probe-file jarfile)
	 (if (equal rest-pathname "/")
	     pathname
	     (let ((jar (jnew  "java.util.zip.ZipFile" jarfile)))
	       (let ((found (jcall "getEntry" jar (subseq rest-pathname 1))))
		 (and found pathname)))))))

'(defun open-jar-entry-for-read-as-character-stream (pathname)
  (let ((jarfile (subseq (namestring (pathname-device pathname)) 9))
	(rest-pathname (namestring (make-pathname :directory (pathname-directory pathname)
						  :name (pathname-name pathname)
						  :type (pathname-type pathname)))))
    (let ((jar (jnew  "java.util.zip.ZipFile" jarfile)))
      (jnew "org.armedbear.lisp.Stream"
	    (jnew "java.io.InputStreamReader"
		  (jcall "getInputStream" jar (jcall "getEntry" jar (subseq rest-pathname 1)))
		  )))))

;; nope. Needs to be a FileStream
;; (defun load-lisp-file-from-jar-file (pathname)
;;   (let ((translated (translate-logical-pathname pathname)))
;;     (let ((stream (open-jar-entry-for-read-as-character-stream translated)))
;;       (let ((*load-truename* translated))
;; 	(unwind-protect (load stream)
;; 	  (close stream))))))
  
'(advise directory
	(let* ((translated (translate-logical-pathname (car arglist)))
	       (device (pathname-device translated)))
	  (if (and device (eql 0 (search "jar:file:" (namestring (if (consp device) (car device) device)))))
	      (directory-in-jar translated)
	      (:do-it)))
	:when :around :name  jar-file)

(advise directory
	(let* ((translated (translate-logical-pathname (car arglist)))
	       (device (pathname-device translated)))
	  (if (and (consp device) (equal "jar" (pathname-type (car device))))
	      (directory-in-jar translated)
	      (:do-it)))
	:when :around :name  jar-file)

(defun directory-in-jar (pathname)
  (let* ((device (pathname-device pathname))
	 (jarfile (namestring (car device)))
	 (rest-pathname (namestring (make-pathname :directory `(:absolute ,@(cdr (pathname-directory pathname)))
						   :name (pathname-name pathname)
						   :type (pathname-type pathname)))))
    (if (or (position #\* (namestring rest-pathname))
	    (wild-pathname-p rest-pathname))
	(let ((jar (jnew  "java.util.zip.ZipFile" jarfile)))
	  (let ((els (jcall "entries" jar)))
	    (loop while (#"hasMoreElements" els)
	       for name = (jcall "getName" (#"nextElement" els))
	       when (pathname-match-p (concatenate 'string "/" name) rest-pathname)
	       collect (make-pathname :device (pathname-device pathname)
				      :name (pathname-name name)
				      :type (pathname-type name)
				      :directory `(:relative ,@(cdr (pathname-directory name)))))))
	(let ((truename (probe-file pathname)))
	  (if truename
              (list truename)
              nil)))))

'(advise truename
	(let* ((translated (translate-logical-pathname (car arglist)))
	       (device (pathname-device translated)))
	  (if (and device (eql 0 (search "jar:file:" (namestring device))))
	      (let ((probed (probe-file translated)))
		(assert probed (probed) "~s does not exist" (car arglist))
		probed)
	      (:do-it)))
	:when :around :name  jar-file)

;; ug. in a tie, asdf chooses the lisp file. hack for the moment, but not really good enough.
;; (advise file-write-date
;; 	(let* ((translated (truename (car arglist)))
;; 	       (device (pathname-device translated)))
;; 	  (if (and device (eql 0 (search "jar:file:" (namestring device))))
;; 	      (+ (file-write-date (subseq (namestring (pathname-device translated)) 9))
;; 		 (if (equal (pathname-type translated) "abcl") 1 0))
;; 	      (:do-it)))
;; 	:when :around :name  jar-file)
  
;; use this op to load fasls from jars

(defclass asdf::load-just-fasls-op (asdf::load-op))

(defmethod asdf::component-depends-on ((operation asdf::load-just-fasls-op) (c asdf::component))
  (remove 'asdf::compile-op (call-next-method) :key 'car))

(defmethod asdf::perform ((o asdf::load-just-fasls-op) (c asdf::cl-source-file))
  (mapcar #'load 
	  (mapcar (lambda(e)
		    (let ((compiled (compile-file-pathname e)))
		      (if (fboundp 'asdf::implementation-specific-directory-name)
			  (merge-pathnames
			   (make-pathname :directory `(:relative ,(asdf::implementation-specific-directory-name)))
			   compiled)
			  compiled)))
		  (asdf::input-files o c))))