;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Thu May 01 08:33:57 2008 -0600 <enometh@net.meer>
;;;   Time-stamp: <2008-05-02 12:43:26 madhu>
;;;   Bugs-To: enometh@net.meer
;;;   Status: Experimental.  Do not redistribute
;;;   Copyright (C) 2008 Madhu.  All Rights Reserved.
;;;
;;; Remove the search-host "home:" and define a logical host called "HOME".
;;; Redefines USER-HOMEDIR-PATHNAME to use this.  Adds a feature
;;; :LOGICAL-HOME-P.
;;;
;;; NOTE: Currently, (19e), the file-compiler will barf on reading
;;; (ext:search-list "XXX") forms, where "XXX" is a logical host. So we need
;;; to conditionalize the reading of such forms on the newly added feature.
;;;
(in-package "CL-USER")

#+cmu
(when (handler-case
	  (funcall (find-symbol "SEARCH-LIST-DEFINED-P" "EXT") "home:")
	(simple-error (c)
	  (warn "~S: ~?" c (simple-condition-format-control c)
		(simple-condition-format-arguments c))))
  (LISP::%SET-SEARCH-LIST
   "lair:" (funcall (find-symbol "SEARCH-LIST" "EXT") "home:"))
  (funcall (find-symbol "CLEAR-SEARCH-LIST" "EXT") "home"))

#+cmu
(setf (logical-pathname-translations "HOME")
      `(("*.*.*" ,(make-pathname :name :wild :version :wild :type :wild
				 :defaults "lair:"))
	("**;*.*.*" ,(merge-pathnames
		      (make-pathname :name :wild :version :wild :type :wild
				     :host nil :directory
				     '(:relative :wild-inferiors))
		      "lair:" nil))))

#+cmu
(pushnew :logical-home-p *features*)

#+cmu
(ext:without-package-locks
    (defun user-homedir-pathname (&optional host)
      (declare (ignore host))
      #p"HOME:"))

#+cmu
(eval-when (:load-toplevel :execute)
  (assert (string-equal (pathname-host (user-homedir-pathname)) "HOME")))


;;; ----------------------------------------------------------------------
#||
(user-homedir-pathname)			;=> #p"home:" (cmucl)
(translate-logical-pathname "HOME:cmu;")
(truename "HOME:clisp;")
(truename "HOME:cl;")
(ext:search-list "trunk:")
(ext:search-list-defined-p "home:")
(ext:search-list-defined-p "lair:")
(make-pathname :host "HOME" :name nil :type nil :version nil
	       :directory '(:absolute))
(setf (logical-pathname-translations "PROJECTS")
      `(("*.*.*" ,(wildify #p"HOME:clisp;"))
	("**;*.*.*" ,(wildify #p"HOME:clisp;" :wild-inferiors))))
||#