Changeset 12617 for trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

Timestamp:

04/15/10 14:54:55 (13 years ago)

Author:

Mark Evenson

Message:

Move pathname functions to EXT; implement DEFSETF for URL pathnames.

Implemented DEFSETF functions for HOST, AUTHORITY, QUERY, and FRAGMENT
sections of URL pathname.

Moved PATHNAME-JAR-P and PATHNAME-URL-P to EXT.

EXT::%INVALIDATE-NAMESTRING resets the namestring after changing the
internal structure. Having to monkey around with the internal
structure of Pathname is just wrong: we should implement the get/set
accessor pattern in Java even though it would make the code more
verbose.

File:

• trunk/abcl/src/org/armedbear/lisp/pathnames.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

@@ -434 +434 @@
             :format-control "~S cannot be converted to a pathname."
             :format-arguments (list thing)))))
+
+
+;;; Functions for dealing with URL Pathnames
+
+(in-package :extensions)
+
+(defun url-pathname-scheme (p)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (getf (pathname-host p) :scheme))
+
+(defun set-url-pathname-scheme (p v)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (let ((host (pathname-host p)))
+    (setf (getf host :scheme) v))
+  (%invalidate-namestring p))
+
+(defsetf url-pathname-scheme set-url-pathname-scheme)
+
+(defun url-pathname-authority (p)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (getf (pathname-host p) :authority))
+
+(defun set-url-pathname-authority (p v)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (let ((host (pathname-host p)))
+    (setf (getf host :authority) v))
+  (%invalidate-namestring p))
+
+(defsetf url-pathname-authority set-url-pathname-authority)
+
+(defun url-pathname-query (p)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (getf (pathname-host p) :query))
+
+(defun set-url-pathname-query (p v)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (let ((host (pathname-host p)))
+    (setf (getf host :query) v))
+  (%invalidate-namestring p))
+
+(defsetf url-pathname-query set-url-pathname-query)
+
+(defun url-pathname-fragment (p)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (getf (pathname-host p) :fragment))
+
+(defun set-url-pathname-fragment (p v)
+  (unless (pathname-url-p p)
+    (error "~A is not a URL pathname." p))
+  (let ((host (pathname-host p)))
+    (setf (getf host :fragment) v))
+  (%invalidate-namestring p))
+
+(defsetf url-pathname-query set-url-pathname-fragment)
+
+(export '(url-pathname-scheme
+          url-pathname-authority
+          url-pathname-query
+          url-pathname-fragment) 
+        'ext)