source: cl-darcs/trunk/upath.lisp

Last change on this file was 184, checked in by Magnus Henoch, 14 years ago

Add TRUENAME argument to MAKE-UPATH

File size: 3.5 KB
Line 
1;;; Copyright (C) 2006, 2008 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19;; "Universal pathname" - can refer to either a local or a remote
20;; file.  For local files, just use pathnames.  For remote files, use
21;; the PURI library.  (Or the real thing, if we're using ACL)
22
23(defun make-upath (path &key truename)
24  "Turn PATH into a \"universal pathname\".
25If PATH is a pathname or URI, return it unchanged.
26If PATH starts with \"http://\" or \"https://\", return a URI.
27Else, return a pathname.
28
29If TRUENAME is provided and true, give an absolute path."
30  (ctypecase path
31    (pathname
32     (if truename
33         (truename path)
34         path))
35    (net.uri:uri
36     path)
37    (string
38     (if (or (and (>= (length path) 7)
39                  (string= path "http://" :end1 7))
40             (and (>= (length path) 8)
41                  (string= path "https://" :end1 8)))
42         (net.uri:parse-uri path)
43         (if truename
44             (truename (pathname path))
45             (pathname path))))))
46
47(defun upath-subdir (base subdirs &optional filename)
48  "From BASE, descend into SUBDIRS and FILENAME.
49PATH is assumed to refer to a directory, not a file."
50  (setf base (make-upath base))
51  (let* ((subdirs-list (remove-if #'keywordp 
52                                  (if (pathnamep subdirs)
53                                      (pathname-directory subdirs)
54                                      subdirs))))
55    (ctypecase base
56      (net.uri:uri
57       (let* ((current-path (net.uri:uri-parsed-path base))
58              (new-path
59               (cond
60                 ((null current-path)
61                  (cons :absolute subdirs-list))
62                 (t
63                  (append current-path subdirs-list))))
64              (new-uri (net.uri:copy-uri base)))
65         (setf (net.uri:uri-parsed-path new-uri) (if filename 
66                                                  (append new-path (list filename))
67                                                  new-path))
68         new-uri))
69      ;; this won't work correctly if BASE has a filename
70      (pathname
71       (setf base (fad:pathname-as-directory base))
72       (merge-pathnames
73        (make-pathname :directory (cons :relative subdirs-list)
74                       :name filename)
75        base)))))
76
77(defun open-upath (upath &key binary (redirect-max-depth 5))
78  "Open UPATH for reading.  Return a stream.
79If BINARY is true, use an element type of (UNSIGNED-BYTE 8),
80else CHARACTER."
81  (setf upath (make-upath upath))
82  (ctypecase upath
83    (net.uri:uri 
84     (dformat "~&Opening ~A..." upath)
85     (apply #'drakma:http-request upath :redirect redirect-max-depth
86            :want-stream t (when *http-proxy* `(:proxy ,*http-proxy*))))
87
88    (pathname
89     (open upath :direction :input :if-does-not-exist :error
90           :element-type (if binary '(unsigned-byte 8) 'character)))))
91
92(defun upath-to-string (upath &key truename)
93  "Convert UPATH to a string.
94This string can be read with MAKE-UPATH.
95When TRUENAME is provided and true, give absolute/canonical form."
96  (ctypecase upath
97    (string
98     upath)
99    (pathname
100     (namestring (if truename
101                     (truename upath)
102                     upath)))
103    (net.uri:uri
104     (with-output-to-string (s)
105       (net.uri:render-uri upath s)))))
Note: See TracBrowser for help on using the repository browser.