[port-template] portable PROBE-DIRECTORY for SBCL

--Apple-Mail-11-421535913
Content-Transfer-Encoding: quoted-printable
Content-Type: text/plain;
	charset=us-ascii

Hi, www-cl

Current definition of PROBE-DIRECTORY from port-template [1] didn't work =
in SBCL. When CL-HTTP started, it need to create #p"HTTP:PROXY-CACHE;" =
and #p"HTTP:LOG;" but actually these directories won't be created, and =
CL-HTTP won't start:

The solution is to replace PROBE-DIRECTORY with a more portable version =
from CL-FAD. I see related source code [1] already contains some code =
from CL-FAD, but it need more. That's what I did in this patch, and it =
works.

Regards,

Chun Tian (binghe)


--Apple-Mail-11-421535913
Content-Disposition: attachment;
	filename=cl-http-port-template-probe-directory.patch
Content-Type: application/octet-stream;
	name="cl-http-port-template-probe-directory.patch"
Content-Transfer-Encoding: 7bit

Index: contrib/kpoeck/port-template/allegro/files.lisp
===================================================================
--- contrib/kpoeck/port-template/allegro/files.lisp	(revision 73)
+++ contrib/kpoeck/port-template/allegro/files.lisp	(working copy)
@@ -120,6 +120,74 @@
     (not (%component-present-p (pathname-name pathspec)))
     (not (%component-present-p (pathname-type pathspec)))
     pathspec))
+
+(defun %pathname-as-directory (pathspec)
+  "Converts the non-wild pathname designator PATHSPEC to directory
+form."
+  (let ((pathname (pathname pathspec)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (cond ((not (%directory-pathname-p pathspec))
+           (make-pathname :directory (append (or (pathname-directory pathname)
+                                                 (list :relative))
+                                             (list (file-namestring pathname)))
+                          :name nil
+                          :type nil
+                          :defaults pathname))
+          (t pathname))))
+
+(defun %pathname-as-file (pathspec)
+  "Converts the non-wild pathname designator PATHSPEC to file form."
+  (let ((pathname (pathname pathspec)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (cond ((%directory-pathname-p pathspec)
+           (let* ((directory (pathname-directory pathname))
+                  (name-and-type (pathname (first (last directory)))))
+             (make-pathname :directory (butlast directory)
+                            :name (pathname-name name-and-type)
+                            :type (pathname-type name-and-type)
+                            :defaults pathname)))
+          (t pathname))))
+
+(defun %file-exists-p (pathspec)
+  "Checks whether the file named by the pathname designator PATHSPEC
+exists and returns its truename if this is the case, NIL otherwise.
+The truename is returned in `canonical' form, i.e. the truename of a
+directory is returned as if by PATHNAME-AS-DIRECTORY."
+  #+(or :sbcl :lispworks :openmcl :ecl :digitool) (probe-file pathspec)
+  #+:allegro (or (excl:probe-directory (%pathname-as-directory pathspec))
+                 (probe-file pathspec))
+  #+(or :cmu :scl :abcl) (or (probe-file (%pathname-as-directory pathspec))
+                             (probe-file pathspec))
+  #+:cormanlisp (or (and (ccl:directory-p pathspec)
+                         (%pathname-as-directory pathspec))
+                    (probe-file pathspec))
+  #+:clisp (or (ignore-errors
+                 (let ((directory-form (%pathname-as-directory pathspec)))
+                   (when (ext:probe-directory directory-form)
+                     directory-form)))
+               (ignore-errors
+                 (probe-file (pathname-as-file pathspec))))
+  #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+  (error "FILE-EXISTS-P not implemented"))
+
+(defun %directory-exists-p (pathspec)
+  "Checks whether the file named by the pathname designator PATHSPEC
+exists and if it is a directory.  Returns its truename if this is the
+case, NIL otherwise.  The truename is returned in directory form as if
+by PATHNAME-AS-DIRECTORY."
+  #+:allegro
+  (and (excl:probe-directory pathspec)
+       (%pathname-as-directory (truename pathspec)))
+  #+:lispworks
+  (and (lw:file-directory-p pathspec)
+       (%pathname-as-directory (truename pathspec)))
+  #-(or :allegro :lispworks)
+  (let ((result (%file-exists-p pathspec)))
+    (and result
+         (%directory-pathname-p result)
+         result)))
 ;;; End code from cl-fad
 
 (defun pathname-directory-p (pathname)
@@ -299,14 +367,8 @@
 (defgeneric probe-directory (pathname)
   (:documentation "Returns non-null if the directory pathname exists."))
 
-;;;Fixme, do I need all this
-;;; can't I simply call pathname-directory-p
-
 (defmethod probe-directory ((pathname pathname))
-  (setq pathname (translate-logical-pathname pathname))
-  (pathname-directory-p (make-pathname :host (pathname-host pathname)
-                                       :device (pathname-device pathname)
-                                       :directory (pathname-directory pathname))))
+  (%directory-exists-p (translate-logical-pathname pathname)))
 
 (defmethod probe-directory ((pathname string))
   (probe-directory (pathname pathname)))

--Apple-Mail-11-421535913
Content-Transfer-Encoding: 7bit
Content-Type: text/plain;
	charset=us-ascii



[1] line contrib/kpoeck/port-template/allegro/files.lisp


--Apple-Mail-11-421535913
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
WWW-CL mailing list
[email protected]
https://lists.csail.mit.edu/mailman/listinfo/www-cl

--Apple-Mail-11-421535913--