source: cl-darcs/trunk/upath.lisp

;;; Copyright (C) 2006, 2008 Magnus Henoch
;;;
;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

;; "Universal pathname" - can refer to either a local or a remote
;; file.  For local files, just use pathnames.  For remote files, use
;; the PURI library.  (Or the real thing, if we're using ACL)

(defun make-upath (path &key truename)
  "Turn PATH into a \"universal pathname\".
If PATH is a pathname or URI, return it unchanged.
If PATH starts with \"http://\" or \"https://\", return a URI.
Else, return a pathname.

If TRUENAME is provided and true, give an absolute path."
  (ctypecase path
    (pathname
     (if truename
         (truename path)
         path))
    (net.uri:uri
     path)
    (string
     (if (or (and (>= (length path) 7)
                  (string= path "http://" :end1 7))
             (and (>= (length path) 8)
                  (string= path "https://" :end1 8)))
         (net.uri:parse-uri path)
         (if truename
             (truename (pathname path))
             (pathname path))))))

(defun upath-subdir (base subdirs &optional filename)
  "From BASE, descend into SUBDIRS and FILENAME.
PATH is assumed to refer to a directory, not a file."
  (setf base (make-upath base))
  (let* ((subdirs-list (remove-if #'keywordp 
                                  (if (pathnamep subdirs)
                                      (pathname-directory subdirs)
                                      subdirs))))
    (ctypecase base
      (net.uri:uri
       (let* ((current-path (net.uri:uri-parsed-path base))
              (new-path
               (cond
                 ((null current-path)
                  (cons :absolute subdirs-list))
                 (t
                  (append current-path subdirs-list))))
              (new-uri (net.uri:copy-uri base)))
         (setf (net.uri:uri-parsed-path new-uri) (if filename 
                                                  (append new-path (list filename))
                                                  new-path))
         new-uri))
      ;; this won't work correctly if BASE has a filename
      (pathname
       (setf base (fad:pathname-as-directory base))
       (merge-pathnames
        (make-pathname :directory (cons :relative subdirs-list)
                       :name filename)
        base)))))

(defun open-upath (upath &key binary (redirect-max-depth 5))
  "Open UPATH for reading.  Return a stream.
If BINARY is true, use an element type of (UNSIGNED-BYTE 8),
else CHARACTER."
  (setf upath (make-upath upath))
  (ctypecase upath
    (net.uri:uri 
     (dformat "~&Opening ~A..." upath)
     (apply #'drakma:http-request upath :redirect redirect-max-depth
            :want-stream t (when *http-proxy* `(:proxy ,*http-proxy*))))

    (pathname
     (open upath :direction :input :if-does-not-exist :error
           :element-type (if binary '(unsigned-byte 8) 'character)))))

(defun upath-to-string (upath &key truename)
  "Convert UPATH to a string.
This string can be read with MAKE-UPATH.
When TRUENAME is provided and true, give absolute/canonical form."
  (ctypecase upath
    (string
     upath)
    (pathname
     (namestring (if truename
                     (truename upath)
                     upath)))
    (net.uri:uri
     (with-output-to-string (s)
       (net.uri:render-uri upath s)))))