[asdf-devel] Guard against (push "/foo/bar" asdf:*central-registry*)

[Gary King]

New (more complicate) code:

(defun directory-pathname-p (pathname)
   (and (member (pathname-name pathname) (list nil :unspecific))
        (member (pathname-type pathname) (list nil :unspecific))))

(defun pathname-name+type (pathname)
   "Returns a new pathname consisting of only the name and type from
a non-wild pathname."
   (make-pathname :name (pathname-name pathname)
                  :type (pathname-type pathname)))

(defun ensure-directory-pathname (pathname)
   (if (directory-pathname-p pathname)
       pathname
       (make-pathname
        :directory `(,@(pathname-directory pathname)
		      ,(namestring (pathname-name+type pathname))))))

(defun sysdef-central-registry-search (system)
   (let ((name (coerce-name system))
	(to-remove nil)
	(to-replace nil))
     (block nil
       (unwind-protect
	   (dolist (dir *central-registry*)
	     (let ((defaults (eval dir)))
	       (cond ((directory-pathname-p defaults)
		      (let ((file (and defaults
				       (make-pathname
					:defaults defaults :version :newest
					:name name :type "asd" :case :local))))
			(if (and file (probe-file file))
			    (return file))))
		     (t
		      (restart-case
			  (let ((*print-circle* nil))
			    (error "~@<While searching for system `~a`: `~a` evaluated to  
`~a` which is not a directory.~@:>" system dir defaults))
			(remove-entry-from-registry ()
			    :report "Remove entry from *central-registry* and continue"
			    (push dir to-remove))
			(coerce-entry-to-directory ()
			    :report (lambda (s)
				      (format s "Coerce entry to ~a, replace ~a and continue."
					      (ensure-directory-pathname defaults) dir))
			    (push (cons dir (ensure-directory-pathname defaults)) to- 
replace)))))))
	;; cleanup
	(dolist (dir to-remove)
	  (setf *central-registry* (remove dir *central-registry*)))
	(dolist (pair to-replace)
	  (let* ((current (car pair))
		 (new (cdr pair))
		 (position (position current *central-registry*)))
	    (setf *central-registry*
		  (append (subseq *central-registry* 0 position)
			  (list new)
			  (subseq *central-registry* (1+ position))))))))))






On Jul 9, 2009, at 4:04 PM, Tobias C. Rittweiler wrote:

> Richard M Kreuter writes:
>
>> Wouldn't it be more user-friendly to coerce such pathnames to ones  
>> that
>> denote directory names?
>
> Small addendum to my previous mail:
>
> Even in the case of automatic coercing, I think ASDF should signal a
> style-warning for educational purposes.
>
>  -T.
>
>
> _______________________________________________
> asdf-devel mailing list
> asdf-devel at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel

--
Gary Warren King, metabang.com
Cell: (413) 559 8738
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM * gwking on twitter