Renamed the system; some changes. Published on gitorious.

Pascal J. Bourguignon [2013-03-15 19:31]
Renamed the system; some changes. Published on gitorious.
Filename
com.informatimago.common-lisp.virtual-file-system.asd
com.informatimago.vfs.asd
filenames.lisp
general.lisp
loader.lisp
streams.lisp
utility.lisp
vfs-file-stream.lisp
vfs-packages.lisp
diff --git a/com.informatimago.common-lisp.virtual-file-system.asd b/com.informatimago.common-lisp.virtual-file-system.asd
deleted file mode 100644
index 59d963f..0000000
--- a/com.informatimago.common-lisp.virtual-file-system.asd
+++ /dev/null
@@ -1,42 +0,0 @@
-;;;; -*- mode:lisp; coding:utf-8 -*-
-
-(asdf:defsystem :com.informatimago.common-lisp.virtual-file-system
-    :name "Virtual File System"
-    :description  "Implements a RAM-based Virtual File System."
-    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
-    :version "0.0.4"
-    :licence "GPL"
-    :properties ((#:author-email                   . "pjb@informatimago.com")
-                 (#:date                           . "Spring 2011")
-                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.common-lisp.virtual-file-system/")
-                 ((#:albert #:formats)             . ("docbook"))
-                 ((#:albert #:docbook #:template)  . "book")
-                 ((#:albert #:docbook #:bgcolor)   . "white")
-                 ((#:albert #:docbook #:textcolor) . "black"))
-    :depends-on (:split-sequence
-                 :cl-ppcre
-                 :com.informatimago.common-lisp.cesarum)
-    :components ((:file "vfs-packages")
-                 (:file "utility"              :depends-on ("vfs-packages"))
-                 (:file "filenames"            :depends-on ("utility"))
-                 (:file "streams"              :depends-on ("utility"))
-
-                 (:file "virtual-fs"           :depends-on ("filenames"))
-                 (:file "files"                :depends-on ("streams" "filenames" "virtual-fs"))
-                 (:file "vfs-file-stream"      :depends-on ("streams" "filenames" "virtual-fs"))
-
-                 (:file "string-input"         :depends-on ("streams" "filenames"))
-                 (:file "string-output"        :depends-on ("streams" "filenames"))
-                 (:file "concatenated-stream"  :depends-on ("streams" "filenames"))
-                 (:file "broadcast-stream"     :depends-on ("streams" "filenames"))
-                 (:file "synonym-stream"       :depends-on ("streams" "filenames"))
-                 (:file "two-way-stream"       :depends-on ("streams" "filenames"))
-                 (:file "echo-stream"          :depends-on ("streams" "filenames"))
-                 (:file "standard-streams"     :depends-on ("string-input" "string-output" "two-way-stream"))
-                 (:file "cl-stream"            :depends-on ("standard-streams"))
-                 ;; ---
-                 (:file "initialize"           :depends-on ("cl-stream" "virtual-fs"))
-                 ))
-
-
-;;;; THE END ;;;;
diff --git a/com.informatimago.vfs.asd b/com.informatimago.vfs.asd
new file mode 100644
index 0000000..28d70a1
--- /dev/null
+++ b/com.informatimago.vfs.asd
@@ -0,0 +1,43 @@
+;;;; -*- mode:lisp; coding:utf-8 -*-
+
+(asdf:defsystem :com.informatimago.vfs
+    :name "Virtual File System"
+    :description  "Implements a RAM-based Virtual File System."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com>"
+    :version "0.0.4"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Spring 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.vfs/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on (:split-sequence
+                 :cl-ppcre
+                 :com.informatimago.common-lisp.cesarum)
+    :components ((:file "vfs-packages")
+                 (:file "utility"              :depends-on ("vfs-packages"))
+                 (:file "filenames"            :depends-on ("utility"))
+                 (:file "streams"              :depends-on ("utility"))
+
+                 (:file "virtual-fs"           :depends-on ("filenames"))
+                 (:file "files"                :depends-on ("streams" "filenames" "virtual-fs"))
+                 (:file "vfs-file-stream"      :depends-on ("streams" "filenames" "virtual-fs"))
+
+                 (:file "string-input"         :depends-on ("streams" "filenames"))
+                 (:file "string-output"        :depends-on ("streams" "filenames"))
+                 (:file "concatenated-stream"  :depends-on ("streams" "filenames"))
+                 (:file "broadcast-stream"     :depends-on ("streams" "filenames"))
+                 (:file "synonym-stream"       :depends-on ("streams" "filenames"))
+                 (:file "two-way-stream"       :depends-on ("streams" "filenames"))
+                 (:file "echo-stream"          :depends-on ("streams" "filenames"))
+                 (:file "standard-streams"     :depends-on ("string-input" "string-output" "two-way-stream"))
+                 (:file "cl-stream"            :depends-on ("standard-streams"))
+                 (:file "general"              :depends-on ("streams" "filenames" "files"))
+                 ;; ---
+                 (:file "initialize"           :depends-on ("cl-stream" "virtual-fs"))
+                 ))
+
+
+;;;; THE END ;;;;
diff --git a/filenames.lisp b/filenames.lisp
index d125f2b..30e63a0 100644
--- a/filenames.lisp
+++ b/filenames.lisp
@@ -60,7 +60,9 @@
                 :extended t)))


-(defun parse-logical-pathname (string)
+(defun parse-logical-pathname (string &key (start 0) (end nil))
+  ;; TODO: implement junk-allowed
+  ;; TODO: return new position.
   (flet ((wild (item part wild-inferiors-p)
            (cond ((string= "*"  item) :wild)
                  ((and wild-inferiors-p (string= "**" item)) :wild-inferiors)
@@ -70,12 +72,12 @@
                          part item))
                  ((position #\* item) (list :wild-word item))
                  (t item))))
-    (multiple-value-bind (all
-                          dummy0 host
-                          relative directories dummy1
-                          name
-                          dummy2 type dummy3 version)
-        (re-exec *logical-pathname-regexp* string)
+    (destructuring-bind (all
+                         dummy0 host
+                         relative directories dummy1
+                         name
+                         dummy2 type dummy3 version)
+        (re-exec *logical-pathname-regexp* string :start start :end end)
       (if all
           (list (and host        (re-match-string string host))
                 (if relative :relative :absolute)
@@ -164,28 +166,7 @@
   (:documentation "A physical pathname."))

 (defmethod print-object ((self pathname) stream)
-  (flet ((present-item (item)
-           (cond ((null item) item)
-                 ((listp item) (second item))
-                 ((eq :wild item) "*")
-                 ((eq :wild-inferiors item) "**")
-                 (t item))))
-    #+(or)
-    (dolist (s '(*print-array* *print-base* *print-case*
-                 *print-circle* *print-escape* *print-gensym* *print-length*
-                 *print-level* *print-lines* *print-miser-width*
-                 *print-pprint-dispatch* *print-pretty* *print-radix*
-                 *print-readably* *print-right-margin*))
-      (format t "~A = ~A~%" s (symbol-value s)))
-    (format stream "~:[~;#P\"~]~A:~:[~;;~]~{~A;~}~:[~;~:*~A~]~
-                    ~:[~;.~:*~A~:[~;.~:*~A~]~]~0@*~:[~;\"~]"
-            *print-escape*
-            (pathname-host self)
-            (eq :relative (first (pathname-directory self)))
-            (mapcar (function present-item) (rest (pathname-directory self)))
-            (present-item (pathname-name self))
-            (present-item (pathname-type self))
-            (present-item (pathname-version self))))
+  (format stream "~:[~;#P\"~]~A~0@*~:[~;\"~]" *print-escape* (namestring self))
   self)


@@ -272,6 +253,7 @@ file). Implementations can define other special version symbols.")



+(defun pathnamep (object) (typep object 'pathname))



@@ -302,6 +284,51 @@ file). Implementations can define other special version symbols.")



+(defun present-item (item)
+  (cond ((null item) item)
+        ((listp item) (second item))
+        ((eq :wild item) "*")
+        ((eq :wild-inferiors item) "**")
+        (t item)))
+
+
+(defun namestring (pathname)
+  (let ((pathname (pathname pathname)))
+   (format nil "~A:~:[~;;~]~{~A;~}~:[~;~:*~A~]~
+                    ~:[~;.~:*~A~:[~;.~:*~A~]~]"
+           (pathname-host pathname)
+           (eq :relative (first (pathname-directory pathname)))
+           (mapcar (function present-item) (rest (pathname-directory pathname)))
+           (present-item (pathname-name pathname))
+           (present-item (pathname-type pathname))
+           (present-item (pathname-version pathname)))))
+
+
+(defun file-namestring (pathname)
+  (let ((pathname (pathname pathname)))
+   (format nil "~:[~;~:*~A~]~:[~;.~:*~A~:[~;.~:*~A~]~]"
+           (present-item (pathname-name pathname))
+           (present-item (pathname-type pathname))
+           (present-item (pathname-version pathname)))))
+
+
+(defun directory-namestring (pathname)
+  (let ((pathname (pathname pathname)))
+   (format nil "~:[~;;~]~{~A;~}"
+           (eq :relative (first (pathname-directory pathname)))
+           (mapcar (function present-item) (rest (pathname-directory pathname))))))
+
+
+(defun host-namestring (pathname)
+  (let ((pathname (pathname pathname)))
+   (format nil "~@[~A~]" (pathname-host pathname))))
+
+
+(defun enough-namestring (pathname &optional defaults)
+  (error "enough-namestring not implemented yet"))
+
+
+


 (defun check-host (host)
@@ -311,6 +338,7 @@ file). Implementations can define other special version symbols.")
     ((file-system-named host) host)
     (t                        (error "Invalid host ~S" host))))

+
 (defun make-pathname (&key host device directory name type version (case :local)
                       (defaults nil defaults-p))
   (cond ((stringp directory)  (setf directory (list :absolute directory)))
@@ -330,20 +358,28 @@ file). Implementations can define other special version symbols.")
         :version     (or version   (and defaults (pathname-version   defaults))))))


-(defun pathnamep (object) (typep object 'pathname))



 (defparameter *logical-pathname-translations*
   (make-hash-table :test (function equal)))

+
 (defun logical-host-p (host)
+  "
+RETURN: whether HOST is a logical hosts.
+"
   (nth-value 1 (gethash host *logical-pathname-translations*)))

+
 (defun logical-pathname-translations (host)
+  "
+RETURN: The logical pathname translations for the HOST.
+"
   (assert-type host 'string)
   (gethash host *logical-pathname-translations*))

+
 (defun (setf logical-pathname-translations) (value host)
   (assert-type host 'string)
   (assert (and (proper-list-p value)
@@ -372,16 +408,52 @@ file). Implementations can define other special version symbols.")


 (defun logical-pathname (pathspec)
-  (warn "LOGICAL-PATHNAME is not implemented correctly.")
-  (pathname pathspec))
+  (let ((path (pathname pathspec)))
+    (if (logical-pathname-p path)
+        path
+        (error "~S: pathspec ~S is not a logical pathname."
+               'logical-pathname pathspec))))


 (defun parse-namestring (thing &optional host
                          (default-pathname *default-pathname-defaults*)
                          &key (start 0) (end nil) (junk-allowed nil))
-  (when (typep thing 'file-stream)
-    (setf thing (pathname thing)))
-  (error "parse-namestring not implemented yet"))
+  (let ((default-host (and host (check-host host))))
+    (etypecase thing
+      (file-stream
+       (parse-namestring  (pathname thing) default-host default-pathname
+                          :start start :end end :junk-allowed junk-allowed))
+      (pathname
+       (if (equal (pathname-host thing :case :common) default-host)
+           (values thing start)
+           (error 'simple-type-error
+                  :format-control "~S: pathname has a different host ~S than given host ~S"
+                  :format-arguments (list 'parse-namestring
+                                          (pathname-host thing :case :common)
+                                          default-host))))
+      (string
+       (if (string= thing "" :start start :end end)
+           (values (make-instance 'pathname :host nil :directory nil :name nil :type nil :version nil)
+                   start)
+           ;; TODO: implement junk-allowed
+           (let ((result (ignore-errors (parse-logical-pathname thing :start start :end end))))
+             (if result
+                 (destructuring-bind (host relative directory name type version) result
+                   (when (and host default-host)
+                     (unless (equal host default-hosts)
+                       (error 'simple-type-error
+                              :format-control "~S: pathname has a different host ~S than given host ~S"
+                              :format-arguments (list 'parse-namestring host default-host))))
+                   (let ((host (or host default-hosts (pathname-host default-pathname :case :common))))
+                     (values
+                      (make-instance (cond
+                                       ((eql :wild host)       'pathname)
+                                       ((logical-host-p host)  'logical-pathname)
+                                       (t                      'pathname))
+                          :host host :directory (cons relative directory)
+                          :name name :type type :version version)
+                      (or end (length thing)))))
+                 (values nil start))))))))


 (defun wild-pathname-p (pathname &optional field-key)
@@ -456,13 +528,67 @@ file). Implementations can define other special version symbols.")
                                            (rest (pathname-directory wild))))))))


+
 (defun translate-logical-pathname (pathname &key)
   (warn "translate-logical-pathname not implemented yet")
   (pathname pathname))


+(defun pathname-components (pathname)
+  (list (pathname-host      pathname)
+        (pathname-device    pathname)
+        (pathname-directory pathname)
+        (pathname-name      pathname)
+        (pathname-type      pathname)
+        (pathname-version   pathname)))
+
 (defun translate-pathname (source from-wildcard to-wildcard &key)
-  (error "translate-pathname not implemented yet"))
+  (assert-type source        '(or string pathname file-stream))
+  (assert-type from-wildcard '(or string pathname file-stream))
+  (assert-type to-wildcard   '(or string pathname file-stream))
+  (let ((source        (pathname-components (pathname source)))
+        (from-wildcard (pathname-components (pathname from-wildcard)))
+        (to-wildcard   (pathname-components (pathname to-wildcard))))
+    (loop
+       :for dirp    :in '(nil nil t nil nil nil)
+       :for s-compo :in source
+       :for f-compo :in from-wildcard
+       :for t-compo :in to-wildcard
+       :collect (if dirp
+
+
+                    ))))
+
+
+
+(defun join (sep strlist)
+  (if strlist
+      (cl:with-output-to-string (out)
+        (cl:princ (first strlist) out)
+        (dolist (str (rest strlist))
+          (cl:princ sep out)
+          (cl:princ str out)))
+      ""))
+
+(defun test ()
+  (let* ((source "CRACKBOOMHUH")
+         (source "FOOZIMBAR")
+         (from      (split-sequence #\* "FOO*BAR"))
+         (to        (split-sequence #\* "Z(O)OM*ZOOM"))
+         (from-re   (join "(.*)" (mapcar (lambda (item) (re-quote item :extended t)) from)))
+         (matches   (re-match from-re source)))
+    (assert (= (length  from) (length to)))
+    (if matches
+        (cl:with-output-to-string (out)
+          (pop matches)
+          (cl:princ (first to) out)
+          (dolist (item (rest to))
+            (let ((range (pop matches)))
+              (cl:princ (subseq source (first range) (second range)) out))
+            (cl:princ item out)))
+        source)))
+
+


 (defun delete-back (dir)
diff --git a/general.lisp b/general.lisp
index f3d6b99..1407735 100644
--- a/general.lisp
+++ b/general.lisp
@@ -1,3 +1,4 @@
+
 ;;;; -*- mode:lisp;coding:utf-8 -*-
 ;;;;**************************************************************************
 ;;;;FILE:               general.lisp
@@ -132,4 +133,5 @@
                 (progn ,@body-rest (get-output-stream-string ,var))
              (close ,var))))))

+
 ;;;; THE END ;;;;
diff --git a/loader.lisp b/loader.lisp
index 2065c5c..ef42004 100644
--- a/loader.lisp
+++ b/loader.lisp
@@ -1,9 +1,10 @@

 (in-package "COMMON-LISP-USER")

-(pushnew (make-pathname :name nil :type nil :version nil
-                        :defaults (load-time-value *load-pathname*))
-         asdf:*central-registry*)
+(cd (make-pathname :name nil :type nil :version nil
+                    :defaults (load-time-value *load-pathname*)))
+(pushnew (pwd) asdf:*central-registry*)

 (ql:quickload :com.informatimago.common-lisp.virtual-file-system)

+(in-package "VFS-USER")
diff --git a/streams.lisp b/streams.lisp
index 7602d98..8143bdb 100644
--- a/streams.lisp
+++ b/streams.lisp
@@ -268,12 +268,14 @@ DO:     Specifies the name and parameter list of methods.
                          (if (lambda-list-rest-p lambda-list)
                              `(apply (function ,cl-name) ,@arguments)
                              `(,cl-name ,@(butlast arguments)))))
-                 (defmethod ,m-name
-                     ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
-                   ,(let ((arguments (make-argument-list lambda-list)))
-                         (if (lambda-list-rest-p lambda-list)
-                             `(apply (function ,cl-name) ,@arguments)
-                             `(,cl-name ,@(butlast arguments)))))))
+                 ;; We don't want to allow access to CL:STREAM from a sandbox.
+                 ;; (defmethod ,m-name
+                 ;;     ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
+                 ;;   ,(let ((arguments (make-argument-list lambda-list)))
+                 ;;         (if (lambda-list-rest-p lambda-list)
+                 ;;             `(apply (function ,cl-name) ,@arguments)
+                 ;;             `(,cl-name ,@(butlast arguments)))))
+                 ))
        ,@(when check-stream-type
                `((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
                    (raise-type-error ,stream-name ',check-stream-type))))
@@ -445,8 +447,7 @@ DO:     Expands to a bunch of defmethod forms, with the parameter
 (define-forward file-length (stream)
   (declare (stream-argument stream)
            (check-stream-type file-stream)
-           (cl-forward t))
-  (:method stream (error "not implemented yet")))
+           (cl-forward t)))


 (define-forward file-position (stream &optional (position-spec nil))
diff --git a/utility.lisp b/utility.lisp
index 6b06173..4396402 100644
--- a/utility.lisp
+++ b/utility.lisp
@@ -116,6 +116,7 @@ NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.
 ;;; regular expressions
 ;;;

+
 (defun re-compile (re &key extended)
   #+clisp
   (regexp:regexp-compile   re :extended      extended)
@@ -124,16 +125,21 @@ NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.
   #-(or clisp cl-ppcre)
   (error "Please implement RE-COMPILE"))

-(defun re-exec (re string)
+(defun re-exec (re string &key (start 0) (end nil))
   #+clisp
-  (regexp:regexp-exec re string)
+  (mapcar (lambda (match)
+            (list (regexp:match-start match)
+                  (regexp:match-end   match)
+                  match))
+          (multiple-value-list (regexp:regexp-exec re string :start start :end (or end (length string)))))
   #+(and (not clisp) cl-ppcre)
-  (multiple-value-bind (start end starts ends) (cl-ppcre:scan re string)
+  (multiple-value-bind (start end starts ends)
+      (cl-ppcre:scan re string :start start :end (or end (length string)))
     (and start end
-         (values-list  (cons (cons start end)
+         (values-list  (cons (list start end)
                              (map 'list (lambda (s e)
                                           (if (or s e)
-                                              (cons s e)
+                                              (list s e)
                                               nil))
                                   starts ends)))))
   #-(or clisp cl-ppcre)
@@ -141,9 +147,9 @@ NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.

 (defun re-match-string (string match)
   #+clisp
-  (regexp:match-string string match)
+  (regexp:match-string string (third match))
   #+(and (not clisp) cl-ppcre)
-  (subseq string (car match) (cdr match))
+  (subseq string (first match) (second match))
   #-(or clisp cl-ppcre)
   (error "Please implement RE-MATCH-STRING"))

@@ -151,4 +157,15 @@ NOTICE: CHECK-TYPE signals a PROGRAM-ERROR.
   (re-exec (re-compile regexp :extended t) string))


+(defun re-quote (re &key extended)
+  (assert extended (extended) "re-quote is not implemented yet for non-extended regexps.")
+  (cl:with-output-to-string (out)
+    (loop
+       :for ch :across re
+       :do (cond
+             ((alphanumericp ch) (princ ch out))
+             (t (princ "\\" out) (princ ch out))))))
+
+
+
 ;;;; THE END ;;;;
diff --git a/vfs-file-stream.lisp b/vfs-file-stream.lisp
index 655e81d..6d3e8bd 100644
--- a/vfs-file-stream.lisp
+++ b/vfs-file-stream.lisp
@@ -110,7 +110,6 @@
   (check-type if-does-not-exist (member :error :create nil))
   (check-type external-format (member :default))

-  ;; (error "Not implemented yet")

   (let ((path (resolve-pathspec filespec)))
     (labels ((make-stream (file openp inputp outputp overridep position)
diff --git a/vfs-packages.lisp b/vfs-packages.lisp
index 996adc1..fefa3a3 100644
--- a/vfs-packages.lisp
+++ b/vfs-packages.lisp
@@ -48,6 +48,7 @@
       "*DEFAULT-PATHNAME-DEFAULTS*" "PARSE-NAMESTRING"
       "WILD-PATHNAME-P" "PATHNAME-MATCH-P"
       "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "MERGE-PATHNAMES"
+      "NAMESTRING" "FILE-NAMESTRING" "DIRECTORY-NAMESTRING" "HOST-NAMESTRING" "ENOUGH-NAMESTRING"
       ;; 20. Files
       "DIRECTORY" "PROBE-FILE" "ENSURE-DIRECTORIES-EXIST" "TRUENAME"
       "FILE-AUTHOR" "FILE-WRITE-DATE" "RENAME-FILE" "DELETE-FILE"
ViewGit