;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File		     - path-utils.lisp
;; Description	     - tfb's path utils
;; Author	     - Tim Bradshaw (tfb at lostwithiel)
;; Created On	     - Sun Jan 30 13:38:02 2000
;; Last Modified On  - Mon Jun 25 12:56:19 2001
;; Last Modified By  - Gail Anderson (ga at lostwithiel)
;; Update Count	     - 9
;; Status	     - Unknown
;; 
;; $Id: path-utils.lisp,v 1.1 2003/01/23 22:19:15 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Copyright (C) 2000, 2001 Cley Limited
;;; 
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
;;; 
;;; You can contact Cley Limited by emailing cley@cley.com.


(in-package :upt)

(defun split-string (string char)
  ;; split STRING on CHAR, returning a list of substrings.  Return the
  ;; list of substrings, and 2 additional values: whether the first
  ;; substring is null and whether the last one was.  This is not a
  ;; general tool.
  (declare (type string string)
	   (type character char))
  (let ((start 0))
    (flet ((next-chunk ()
	     (if (null start)
		 nil
		 (let ((next-break (position char string :start start)))
		   (if (null next-break)
		       (prog1
			   (subseq string start)
			 (setf start nil))
		       (prog1
			   (subseq string start next-break)
			 (setf start (1+ next-break))))))))
      (loop for tok = (next-chunk)
	  while tok
	  for last-null-p = (zerop (length tok))
	  for first-null-p = last-null-p then first-null-p
	  collect tok into toks
	  finally (return (values toks first-null-p last-null-p))))))

(defstruct urlpath
  (name nil)
  (directory '(:absolute)))

;;; this pair of functions are pretty ugly.
;;;

(defun urlpath->path-name (urlpath)
  "Return a string that corresponds to URLPATH."
  (declare (type urlpath urlpath))
  (let ((directory (urlpath-directory urlpath))
	(name (urlpath-name urlpath)))
    (labels ((doconc (length tail initial-slash-p)
	       (if (null tail)
		   (let* ((flen (length name))
			  (s (make-string (+ length flen 1))))
		     (setf (subseq s (1+ length)) name)
		     (setf (subseq s length) "/")
		     (values s length))
		   (let* ((cur (let ((the-cur (first tail)))
				 (case the-cur
				   ((:up :back) "..")
				   ((:wild) "*")
				   ((:wild-inferiors) "**")
				   (otherwise the-cur))))
			  (l (length cur))
			  (not-lastp (cdr tail))
			  (o (if not-lastp 1 0)))
		     (multiple-value-bind (s a)
			 (doconc (+ length l o) (cdr tail) nil)
		       (if not-lastp (setf (subseq s (1- a)) "/"))
		       (setf (subseq s (- a o l)) cur)
		       (if initial-slash-p
			   (progn
			     (setf (subseq s 0) "/")
			     (values s (- a l 1 o)))
			   (values s (- a l o))))))))
      (values (ecase (car directory)
		((:absolute)
		 (if (cdr directory)
		     (doconc 1 (cdr directory) t)
		     (doconc 0 nil nil)))
		((:relative)
		 (doconc 0 (cdr directory) nil)))))))


(defun path-name->urlpath (path-name)
  "Construct and return a URLPATH object corresponding to the string
PATH-NAME. A path-name starting with `/' is an absolute path-name;
one ending with `/' represents a directory. `.' components are
elided, but `..' components are not"
  (declare (type string path-name))
  (multiple-value-bind (split absolutep directoryp)
      (split-string path-name #\/)
    (when absolutep
      (if (null (cdr split))
	  (setf absolutep nil
		split '())
	  (setf split (cdr split))))
    ;; this is way fiddly.  SPLIT can be NULL or length 1, both of
    ;; which we must special case
    (let ((name
	   (let ((length (length split)))
	     (case length
	       ((0) nil)		;Bad if DIRECTORYP is non-NULL
	       ((1)
		(prog1 (if directoryp
			   nil
			   (car split))
		  (setf split '())))
	       (otherwise		;length > 1
		(let ((penultimate (nthcdr (- length 2) split)))
		  (prog1
		      (if directoryp
			  nil
			  (cadr penultimate))
		    (setf (cdr penultimate) nil))))))))
      (make-urlpath :name name
		 :directory (cons (if absolutep :absolute :relative)
				  (mapcan #'(lambda (e)
					      (cond ((or (zerop (length e))
							 (string= e "."))
						     nil)
						    ((string= e "..")
						     (list ':back))
						    (t (list e))))
					  split))))))