Changeset 12617

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.

Location:

trunk/abcl

Files:

• src/org/armedbear/lisp/Pathname.java (modified) (3 diffs)
• src/org/armedbear/lisp/Symbol.java (modified) (2 diffs)
• src/org/armedbear/lisp/asdf-abcl.lisp (modified) (1 diff)
• src/org/armedbear/lisp/pathnames.lisp (modified) (1 diff)
• test/lisp/abcl/jar-pathname.lisp (modified) (2 diffs)
• test/lisp/abcl/url-pathname.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/Pathname.java

@@ -75 +75 @@
         namestring = null;
     }
+    
+    // ### %invalidate-namestring
+    private static final Primitive _INVALIDATE_NAMESTRING = new pf_invalidate_namestring();
+    private static class pf_invalidate_namestring extends Primitive {
+        pf_invalidate_namestring() {
+            super("%invalidate-namestring", PACKAGE_EXT, false);
+        }
+        @Override
+        public LispObject execute(LispObject first) {
+            ((Pathname)coerceToPathname(first)).invalidateNamestring();
+            return first;
+        }
+    }
 
     protected Pathname() {}
@@ -1611 +1624 @@
     private static class pf_pathname_jar_p extends Primitive {
         pf_pathname_jar_p() {
-            super("pathname-jar-p", PACKAGE_SYS, true, "pathname",
+            super("pathname-jar-p", PACKAGE_EXT, true, "pathname",
                   "Predicate for whether PATHNAME references a JAR.");
         }
@@ -1629 +1642 @@
     private static class pf_pathname_url_p extends Primitive {
         pf_pathname_url_p() {
-            super("pathname-url-p", PACKAGE_SYS, true, "pathname",
+            super("pathname-url-p", PACKAGE_EXT, true, "pathname",
                   "Predicate for whether PATHNAME references a URL.");
         }

trunk/abcl/src/org/armedbear/lisp/Symbol.java

@@ -2921 +2921 @@
   public static final Symbol SLIME_OUTPUT_STREAM =
     PACKAGE_EXT.addExternalSymbol("SLIME-OUTPUT-STREAM");
+  public static final Symbol JAR_PATHNAME =
+    PACKAGE_EXT.addExternalSymbol("JAR-PATHNAME");
+  public static final Symbol URL_PATHNAME =
+    PACKAGE_EXT.addExternalSymbol("URL-PATHNAME");
 
   // MOP.
@@ -3066 +3070 @@
   public static final Symbol JAVA_STACK_FRAME =
     PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME");
-  public static final Symbol JAR_PATHNAME =
-    PACKAGE_SYS.addExternalSymbol("JAR-PATHNAME");
-  public static final Symbol URL_PATHNAME =
-    PACKAGE_SYS.addExternalSymbol("URL-PATHNAME");
 
   // CDR6

trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp

@@ -42 +42 @@
                                      (c cl-source-file)) 
   (let ((files (output-files o c)))
-    (if (every #'sys:pathname-jar-p files) 
+    (if (every #'ext:pathname-jar-p files) 
         t
         (call-next-method))))

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)

trunk/abcl/test/lisp/abcl/jar-pathname.lisp

@@ -279 +279 @@
            (d (first (pathname-device p))))
       (values 
-       (system:pathname-url-p d)
+       (ext:pathname-url-p d)
        (namestring d)
        (pathname-directory p) (pathname-name p) (pathname-type p)))
@@ -292 +292 @@
            (d1 (second d)))
       (values
-       (system:pathname-url-p d0)
+       (ext:pathname-url-p d0)
        (namestring d0)
        (pathname-name d1) (pathname-type d1)

trunk/abcl/test/lisp/abcl/url-pathname.lisp

@@ -30 +30 @@
   "query=this"  
   "that-fragment")
+
+(deftest url-pathname.3
+    (let* ((p (pathname
+               "http://example.org/a/b/foo.lisp?query=this#that-fragment")))
+      (values 
+       (ext:url-pathname-scheme p)
+       (ext:url-pathname-authority p)
+       (ext:url-pathname-query p)
+       (ext:url-pathname-fragment p)))
+  "http"
+  "example.org"
+  "query=this"  
+  "that-fragment")