[mcclim-cvs] CVS mcclim/Apps/Listener
ahefner
ahefner at common-lisp.net
Sun Feb 3 12:47:04 UTC 2008
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!~%"))))))))
More information about the Mcclim-cvs
mailing list