package-net.uri.lisp 3.01 KB
Newer Older
Zach Beane's avatar
Zach Beane committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
;;;; package-net.uri.lisp

(in-package #:zacl)

(defclass net.uri:uri ()
  ((real-uri
    :reader real-uri
    :initarg :real-uri)
   (plist
    :accessor net.uri:uri-plist
    :initarg :plist))
  (:default-initargs
   :plist nil))

Zach Beane's avatar
Zach Beane committed
15
16
17
(defmethod real-uri ((uri quri:uri))
  uri)

18
19
20
(defmethod print-object ((uri net.uri:uri)  stream)
  (print-unreadable-object (uri stream :type t)
    (format stream "~S" (render-uri (real-uri uri)))))
Zach Beane's avatar
Zach Beane committed
21
22
23
24

(defun net.uri:parse-uri (uri-string)
  (make-instance 'net.uri:uri :real-uri (uri uri-string)))

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
(macrolet ((net-uri-accessors (&rest names)
             `(progn
                ,@(mapcan (lambda (name)
                            (let ((net-name (find-symbol (symbol-name name)
                                                         :net.uri)))
                              (unless net-name
                                (error "Unknown net.uri symbol ~A" name))
                              (list
                               `(defun ,net-name (uri)
                                  (,name (real-uri uri)))
                               `(defun (setf ,net-name) (new-value uri)
                                  (setf (,name uri ) new-value)))))
                          names))))
  (net-uri-accessors uri-path
                     uri-host
                     uri-port
                     uri-userinfo
                     uri-fragment
                     uri-query))

;;; uri-scheme isn't as simple as the other accessors

Zach Beane's avatar
Zach Beane committed
47
(defun net.uri:uri-scheme (uri)
48
49
50
  (let ((scheme (uri-scheme (real-uri uri))))
    (when scheme
      (values (find-symbol (string-upcase scheme) :keyword)))))
Zach Beane's avatar
Zach Beane committed
51

52
53
54
55
(defun (setf net.uri:uri-scheme) (new-value uri)
  (setf (uri-scheme (real-uri uri)) new-value))


56
57
58
59
60
61
62
63
64
(defun net.uri:copy-uri (uri
                         &key
                           (scheme (net.uri:uri-scheme uri))
                           (userinfo (net.uri:uri-userinfo uri))
                           (host (net.uri:uri-host uri))
                           (port (net.uri:uri-port uri))
                           (path (net.uri:uri-path uri))
                           (query (net.uri:uri-query uri))
                           (fragment (net.uri:uri-fragment uri)))
65
66
67
68
69
70
71
72
  (copy-uri (real-uri uri)
            :scheme scheme
            :userinfo userinfo
            :host host
            :port port
            :path path
            :query query
            :fragment fragment))
Zach Beane's avatar
Zach Beane committed
73

74
75
(defun net.uri:render-uri (uri &optional stream)
  (render-uri (real-uri uri) stream))
Zach Beane's avatar
Zach Beane committed
76

77
78
(defun net.uri:merge-uris (new-uri uri)
  (merge-uris (real-uri new-uri) (real-uri uri)))
Zach Beane's avatar
Zach Beane committed
79

80
81
(defun net.uri::uri-string (uri)
  (render-uri (real-uri uri)))
Zach Beane's avatar
Zach Beane committed
82
83
84
85
86
87
88
89
90
91
92
93
94

(defun net.uri::uri-path-etc (uri)
  (let ((uri (real-uri uri)))
    (with-output-to-string (s)
      (format s "~A" (uri-path uri))
      (when (uri-query uri)
        (format s "?~A" (uri-query uri)))
      (when (uri-fragment uri)
        (format s "#~A" (uri-fragment uri))))))

(defun net.uri::.uri-parsed-path (uri)
  ;; XXX What is this slot for, anyway? Fake it for now.
  (net.uri:uri-path uri))