;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2004-06-06 09:10:03>
;;;   Touched: Mon May 24 10:41:45 2004 +0530
;;;   Bugs-To: (enometh@net.meer)
;;;
;;; Support for faking CMUCL style search-lists in string pathname
;;; designators. DO NOT USE. See WARNING below
;;;
(defpackage "SL"
  (:use "CL")
  (:export "SEARCH-LIST"))
(in-package "SL")

(defvar *search-lists* (make-hash-table :test #'equal))
(defstruct search-list name expansion)

(defun search-list (pathname &optional (error-p t))
  (etypecase pathname (string))
  (let ((colon-pos (position #\: pathname)))
    (unless colon-pos
      (if error-p
	  (error "Invalid search-list name ~s." pathname)
	  (return-from search-list nil)))
    (let* ((name (nstring-downcase (subseq pathname 0 colon-pos))))
      (when name
	(let ((search-list (gethash name *search-lists*)))
	  (when search-list
	    (values (search-list-expansion search-list) colon-pos)))))))

(defun %convert (pathname)
  (etypecase pathname (pathname))
  (when (or (pathname-name pathname)
	    (pathname-type pathname)
	    (pathname-version pathname))
    (error "Search-lists cannot expand into pathnames that have ~
		       a name, type, or ~%version specified:~%  ~S"
	   pathname))
  pathname)

(defun %set-search-list (pathname values)
  (etypecase pathname (string))
  (let ((colon-pos (position #\: pathname)))
    (unless colon-pos (error "Invalid search-list name ~s." pathname))
    (let* ((name (nstring-downcase (subseq pathname 0 colon-pos)))
	   (p (gethash name *search-lists*))
	   (search-list (or p (make-search-list :name name))))
      (setf (search-list-expansion search-list)
	    (if (listp values)
		(mapcar #'%convert values)
		(list (%convert values))))
      (unless p (setf (gethash name *search-lists*) search-list))))
  values)

(defsetf search-list %set-search-list)

(defun translated-pathnames (pathname)
  (etypecase pathname (string))
  (multiple-value-bind (expansions colon-pos) (search-list pathname nil)
    (when expansions
      (and (< (1+ colon-pos) (length pathname))	;kooky skip slashes
	   (or (char= (char pathname (1+ colon-pos)) #\/)
	       (char= (char pathname (1+ colon-pos)) #\\))
	   (incf colon-pos))
      (let ((rest (subseq pathname (1+ colon-pos))))
	(mapcar (lambda (path) (merge-pathnames rest path nil)) expansions)))))

(defvar *cl-probe-file* #'probe-file)

(defun translated-pathname (pathname)
  (let* ((translated-pathnames (translated-pathnames pathname))
	 (translated-pathname
	  (some (lambda (path) (ignore-errors (funcall *cl-probe-file* path)))
		translated-pathnames)))
    (if translated-pathname
	(values translated-pathname t)
	(values (car translated-pathnames) nil))))

;;;
;;; WARNING WARNING WARNING
;;;

(import 'seach-list :ext)
(export 'search-list :ext)

(defvar *cl-parse-namestring* #'parse-namestring)

(defun parse-namestring  (thing &optional host
			     (default-pathname *default-pathname-defaults*)
			     &rest keys &key (start 0) end junk-allowed)
  (declare (ignorable start end junk-allowed))
  (or (typecase thing (string (translated-pathname thing)))
      (apply *cl-parse-namestring* thing host default-pathname keys)))

;; the following adapted from mk's lp package

(defun real-filename (filename)		;completely fake
  (or (typecase filename (string (translated-pathname filename))) filename))

(defun %save-variable (symbol)
  (intern (apply #'concatenate 'string
		 (list "*CL-"  (symbol-name symbol) "*"))))

(defmacro convert-file-function (name &optional optionalp)
  (let ((old-name (%save-variable name)))
    `(progn
      (defvar ,old-name #',name)
      (defun ,name  ,(if optionalp
			 '(&optional filename &rest args)
			 '(filename &rest args))
	,(if optionalp
	     `(if filename
	       (apply ,old-name (real-filename filename) args)
	       (funcall ,old-name))
	     `(apply ,old-name (real-filename filename) args))))))

(defmacro convert-file-function-2-args (name)
  (let ((old-name (%save-variable name)))
    `(progn
      (defvar ,old-name #',name)
      (defun ,name (filename1 filename2 &rest args)
	(apply ,old-name (real-filename filename1)(real-filename filename2)
	       args)))))

(convert-file-function lisp::load)
(convert-file-function lisp::open)
(convert-file-function lisp::probe-file)
(convert-file-function lisp::delete-file)
(convert-file-function lisp::truename)
(convert-file-function lisp::directory)
(convert-file-function lisp::dribble t)
(convert-file-function lisp::ed t)
(convert-file-function lisp::file-author)
(convert-file-function lisp::file-write-date)

(convert-file-function-2-args lisp::rename-file)
;; should take care of :output-file as well
(convert-file-function lisp::compile-file)

;;; ----------------------------------------------------------------------
#+nil
(progn
(clrhash *search-lists*)
(search-list "home:")
(setf (search-list "home:") '(#p"c:/madhu/proj/" #p"e:/home/madhu/"))
(search-list "homebar:/madhu/foo")
(probe-file "home:lambda-ir/examples/test.lisp")
(format t "~:{~S => ~S~&~}"
	(loop for k being each hash-key in *search-lists*
	      using (hash-value v)
	      collect (list k v))))