Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20175
Modified Files: util.lisp file-types.lisp Log Message: In keeping with McCLIM tradition, "clean up" code and see what breaks. Random pathname-related chanegs, and deleted chunks of old code from the bad old days when SBCL's cl:directory was useless and sb-posix didn't even have stat.
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/01/31 11:06:40 1.23 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/02/03 12:47:04 1.24 @@ -29,23 +29,6 @@ `(let ((,tmp (multiple-value-list ,(first forms)))) (if (first ,tmp) (values-list ,tmp) (mv-or ,@(rest forms)))))))
- -;; DEBUGF is useful, I can sleep better knowing it's in the image. -(defmacro debugf (&rest stuff) - `(progn (fresh-line *trace-output*) - ,@(reduce #'append - (mapcar #'(lambda (x) - (cond - ((stringp x) `((princ ,x *trace-output*))) - (t `((princ ',x *trace-output*) - (princ "=" *trace-output*) - (write ,x :stream *trace-output*) - (princ #\space *trace-output*))))) - - stuff)) - (terpri *trace-output*))) - - ; There has to be a better way.. (defun directoryp (pathname) "Returns pathname when supplied with a directory, otherwise nil" @@ -65,19 +48,18 @@ #+clisp (ext:getenv var) nil))
-;; Need to strip filename/type/version from directory?.. FIXME? (defun change-directory (pathname) "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*" #+CMU (unix:unix-chdir (namestring pathname)) #+scl (unix:unix-chdir (ext:unix-namestring pathname)) #+clisp (ext:cd pathname) - ; SBCL FIXME? + #+sbcl (sb-posix:chdir (namestring pathname)) (setf *default-pathname-defaults* pathname))
(defun resolve-stream-designator (desi default) (if (eq desi t) default - (or desi default))) + (or desi default)))
;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't ;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.) @@ -86,48 +68,10 @@ (defun list-directory (pathname) (directory pathname :truenamep nil))
- -#+SBCL -(defun sbcl-frob-to-pathname (pathname string) - "This just keeps getting more disgusting." - (let* ((parent (strip-filespec pathname)) - (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #. string :start 1 :from-end t)) - :type (let ((x (position #. string :start 1 :from-end t))) - (if x (subseq string (1+ x)) nil))) - parent)) - (dir (ignore-errors (sb-posix:opendir (namestring pn))))) - - - (cond ((or (string= string ".") - (string= string "..")) - (unless (or (null dir) (sb-alien:null-alien dir)) - (sb-posix:closedir dir)) - nil) - ((or (null dir) - (sb-alien:null-alien dir)) - pn) - (T - (sb-posix:closedir dir) - (merge-pathnames (parse-namestring (concatenate 'string string "/")) - parent))))) - #+SBCL (defun list-directory (pathname) - (directory pathname) - #+nil ;; ugh. is too ughy. (mgr) - (let* ((pathname (strip-filespec pathname)) ;; ugh. - (dir (sb-posix:opendir pathname)) - (list nil)) - (loop - (let ((dirent (sb-posix:readdir dir))) - (unwind-protect - (if (sb-alien:null-alien dirent) - (return-from list-directory - (nreverse list)) - (let ((pn (sbcl-frob-to-pathname pathname (sb-posix::dirent-name dirent)))) - (when pn (push pn list)))) - #+nil ; dirents should not be freed, they belong to the DIR. - (sb-posix::free-dirent dirent)))))) + ;; Wow. When did SBCL's cl:directory become sane? This is great news! + (directory pathname))
#+openmcl (defun list-directory (pathname) @@ -246,21 +190,11 @@ (add-output-record record (stream-output-history stream-pane)) (repaint-sheet stream-pane record)))
-;;; Pathname evil -;;; Fixme: Invent some more useful operators for manipulating pathnames, add a -;;; pinch of syntactic sugar, and cut the LOC here down to a fraction. +;;; Pathnames are awful.
(defun gen-wild-pathname (pathname) "Build a pathname with appropriate :wild components for the directory listing." - (make-pathname :name (or (pathname-name pathname) :wild) - :type (or (pathname-type pathname) :wild) - :version (or #+allegro :unspecific - :wild - ;#-SBCL (pathname-version pathname) - ;#+SBCL :newest - ) - #+scl :query #+scl nil - :defaults pathname)) + (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild)))
(defun strip-filespec (pathname) "Removes name, type, and version components from a pathname." @@ -283,6 +217,8 @@
;;;; Abbreviating item formatter
+;;; FIXME: This would work a lot better if the + (defparameter *abbreviating-minimum-items* 6 "Minimum number of items needed to invoke abbreviation. This must be at least one.") (defparameter *abbreviating-outlier-threshold* 2.0 @@ -315,11 +251,6 @@ (if (= count 1) result nil) (or text-style (medium-text-style (slot-value record 'climi::medium)))))))
-;; This logic could be useful in McCLIM's stream-output.lisp, for computing -;; line breaks. At the time, I didn't feel like writing it, but now I do. -;; Even so, the binary search I used there is probably good enough, but this -;; would improve the quality of the guess, particularly for the extreme case -;; of throwing many lines of text at CLIM within one string. (defun abbrev-guess-pos (medium string text-style desired-width start end) "Makes a guess where to split STRING between START and END in order to fit within WIDTH. Returns the ending character index." (let* ((length (- end start)) @@ -348,8 +279,6 @@ (subseq string 0 (abbrev-guess-pos medium string text-style working-width 0 (length string))) "...")))
-(defvar *tmp* nil) - (defun abbreviate-record (stream record width abbreviator) "Attempts to abbreviate the text contained in an output RECORD on STREAM to fit within WIDTH, using the function ABBREVIATOR to produce a shortened string." (declare (optimize (debug 3))) @@ -489,7 +418,10 @@ (run-program name (transform-program-arguments args) :wait *program-wait* :output (resolve-stream-designator *run-output* *standard-output*) - :input nil #+NIL (resolve-stream-designator *run-input* *standard-input*)))) + :input nil #+NIL (resolve-stream-designator *run-input* *standard-input*)) + ;; It might be useful to return the exit status of the process, but our run-program + ;; wrapper doesn't + (values)))
(defun read-stringlet (stream) (with-output-to-string (out) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2007/02/05 03:41:37 1.11 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2008/02/03 12:47:04 1.12 @@ -105,7 +105,6 @@ (key (if type (concatenate 'string name "." type) ; Why did I do it this way? name)) (item (gethash key *magic-name-mappings*))) -; (when item (hef:debugf item pathname)) item))
(defun pathname-mime-type (pathname) @@ -147,7 +146,6 @@ ; (call-next-method))) (let ((cpl (clim-mop:class-precedence-list (class-of obj)))) (dolist (class cpl) -; (debugf " " class) (let ((icon (gethash (class-name class) *icon-mapping*))) (when icon (return-from icon-of icon))))) (call-next-method)) @@ -547,7 +545,7 @@ (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) - (t (debugf "Ignoring unknown % syntax." d)))) + (t (format *trace-output* "Ignoring unknown syntax ~W" d)))) (write-char c out))))))
(defun find-viewspec (pathname) @@ -577,7 +575,7 @@ (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test - (debugf "Sorry, ignoring TEST option right now.. " test)) + (format *trace-output* "Sorry, ignoring TEST option ~W for ~A viewer " test type)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) (format t "~&No view-command!~%"))))))))