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."