[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv3352/ESA

Modified Files:
	esa-io.lisp 
Log Message:
Added new presentation methods for pathnames, based on the ones in
ESA. We now have completion and an attempt at handling the multide of
evils that a programmer can inflict upon a poor CLIM implementations
attempt to textually represent a pathname object. I do not claim these
methods are fail-proof, so please show some restraints wrt. what kind
of nastyness you feed them.


--- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp	2006/11/08 01:10:16	1.1
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp	2006/11/22 14:53:12	1.2
@@ -43,97 +43,6 @@
 
 (make-command-table 'esa-io-table :errorp nil)
 
-(defun filename-completer (so-far mode)
-  (flet ((remove-trail (s)
-           (subseq s 0 (let ((pos (position #\/ s :from-end t)))
-                         (if pos (1+ pos) 0)))))
-    (let* ((directory-prefix
-            (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
-                ""
-                (namestring #+sbcl *default-pathname-defaults*
-                            #+cmu (ext:default-directory)
-                            #-(or sbcl cmu) *default-pathname-defaults*)))
-           (full-so-far (concatenate 'string directory-prefix so-far))
-           (pathnames
-            (loop with length = (length full-so-far)
-                  and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
-                  for path in
-                  #+(or sbcl cmu lispworks) (directory wildcard)
-                  #+openmcl (directory wildcard :directories t)
-                  #+allegro (directory wildcard :directories-are-files nil)
-                  #+cormanlisp (nconc (directory wildcard)
-                                      (cl::directory-subdirs dirname))
-                  #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
-                    (directory wildcard)
-                  when (let ((mismatch (mismatch (namestring path) full-so-far)))
-                         (or (null mismatch) (= mismatch length)))
-                    collect path))
-           (strings (mapcar #'namestring pathnames))
-           (first-string (car strings))
-           (length-common-prefix nil)
-           (completed-string nil)
-           (full-completed-string nil)
-           (input-is-directory-p (when (plusp (length so-far))
-                                   (char= (aref so-far (1- (length so-far))) #\/))))
-      (unless (null pathnames)
-        (setf length-common-prefix
-              (loop with length = (length first-string)
-                    for string in (cdr strings)
-                    do (setf length (min length (or (mismatch string first-string) length)))
-                    finally (return length))))
-      (unless (null pathnames)
-        (setf completed-string
-              (subseq first-string (length directory-prefix)
-                      (if (null (cdr pathnames)) nil length-common-prefix)))
-        (setf full-completed-string
-              (concatenate 'string directory-prefix completed-string)))
-      (case mode
-        ((:complete-limited :complete-maximal)
-         (cond ((null pathnames)
-                (values so-far nil nil 0 nil))
-               ((null (cdr pathnames))
-                (values completed-string t (car pathnames) 1 nil))
-               (input-is-directory-p
-                (values completed-string t (parse-namestring so-far) (length pathnames) nil))
-               (t
-                (values completed-string nil nil (length pathnames) nil))))
-        (:complete
-         (cond ((null pathnames)
-                (values so-far t so-far 1 nil))
-               ((null (cdr pathnames))
-                (values completed-string t (car pathnames) 1 nil))
-               ((find full-completed-string strings :test #'string-equal)
-                (let ((pos (position full-completed-string strings :test #'string-equal)))
-                  (values completed-string
-                          t (elt pathnames pos) (length pathnames) nil)))
-               (input-is-directory-p
-                (values completed-string t (parse-namestring so-far) (length pathnames) nil))
-               (t
-                (values completed-string nil nil (length pathnames) nil))))
-        (:possibilities
-         (values nil nil nil (length pathnames)
-                 (loop with length = (length directory-prefix)
-                       for name in pathnames
-                       collect (list (subseq (namestring name) length nil)
-                                     name))))))))
-
-(define-presentation-method present (object (type pathname)
-                                            stream (view textual-view) &key)
-  (princ (namestring object) stream))
-
-(define-presentation-method accept ((type pathname) stream (view textual-view)
-                                    &key (default nil defaultp) (default-type type))
-  (multiple-value-bind (pathname success string)
-      (complete-input stream
-                      #'filename-completer
-                      :allow-any-input t)
-    (cond (success
-           (values pathname type))
-          ((and (zerop (length string))
-                defaultp)
-           (values default default-type))
-          (t (values string 'string)))))
-
 ;;; Adapted from cl-fad/PCL
 (defun directory-pathname-p (pathspec)
   "Returns NIL if PATHSPEC does not designate a directory."