[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Wed Nov 22 14:53:13 UTC 2006
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv3352
Modified Files:
presentation-defs.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/presentation-defs.lisp 2006/11/20 09:00:56 1.59
+++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/22 14:53:12 1.60
@@ -1448,27 +1448,144 @@
(define-presentation-method presentation-typep (object (type pathname))
(pathnamep object))
+(define-presentation-method present ((object pathname) (type pathname)
+ stream (view textual-view) &key)
+ ;; XXX: We can only visually represent the pathname if it has a name
+ ;; - making it wild is a compromise. If the pathname is completely
+ ;; blank, we leave it as-is, though.
+ (let ((pathname (if (equal object #.(make-pathname))
+ object
+ (merge-pathnames object (make-pathname :name :wild)))))
+ (princ pathname stream)))
+
+(define-presentation-method present ((object string) (type pathname)
+ stream (view textual-view)
+ &rest args &key)
+ (apply-presentation-generic-function
+ present (pathname object) type stream view args))
+
(defmethod presentation-type-of ((object pathname))
'pathname)
-(define-presentation-method present (object (type pathname) stream
- (view textual-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (princ object stream))
-
-(define-presentation-method accept
- ((type pathname) stream (view textual-view)
- &key (default *default-pathname-defaults*))
- (let* ((namestring (read-token stream))
- (path (parse-namestring namestring)))
- (if merge-default
- (merge-pathnames
- path
- (merge-pathnames (make-pathname :type default-type
- :version default-version)
- default))
- path)))
+(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 (plusp (length so-far)) (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
+ ;; This is reached when input is activated, if we did
+ ;; completion, that would mean that an input of "foo" would
+ ;; be expanded to "foobar" if "foobar" exists, even if the
+ ;; user actually *wants* the "foo" pathname (to create the
+ ;; file, for example).
+ (values so-far t so-far 1 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 accept ((type pathname) stream (view textual-view)
+ &key (default *default-pathname-defaults* defaultp)
+ ((:default-type accept-default-type) type))
+ (multiple-value-bind (pathname success string)
+ (complete-input stream
+ #'filename-completer
+ :allow-any-input t)
+ (cond ((and pathname success)
+ (values (if merge-default
+ (progn
+ (unless (or (pathname-type pathname)
+ (null default-type))
+ (setf pathname (make-pathname :defaults pathname
+ :type default-type)))
+ (merge-pathnames pathname default default-version))
+ pathname)
+ type))
+ ((and (zerop (length string))
+ defaultp)
+ (values default accept-default-type))
+ (t (values string 'string)))))
+
+(defmethod presentation-replace-input :around
+ ((stream input-editing-stream)
+ (object pathname) (type (eql 'pathname))
+ view &rest args &key &allow-other-keys)
+ ;; This is fully valid and compliant, but it still smells slightly
+ ;; like a hack.
+ (let ((name (pathname-name object))
+ (directory (when (pathname-directory object)
+ (directory-namestring object)))
+ (type (pathname-type object))
+ (string "")
+ (old-insp (stream-insertion-pointer stream)))
+ (setf string (or directory string))
+ (setf string (concatenate 'string string
+ (cond ((and name type)
+ (file-namestring object))
+ (name name)
+ (type (subseq
+ (namestring
+ (make-pathname
+ :name " "
+ :type type))
+ 1)))))
+ (apply #'replace-input stream string args)
+ (when directory
+ (setf (stream-insertion-pointer stream)
+ (+ old-insp (if directory (length directory) 0)))
+ ;; If we moved the insertion pointer, this might be a good idea.
+ (redraw-input-buffer stream old-insp))))
(defgeneric default-completion-name-key (item))
More information about the Mcclim-cvs
mailing list