- mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 11 Sep '05

11 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv5189 Modified Files: regions.lisp Log Message: tests for lines and rectangles Date: Sun Sep 11 23:44:42 2005 Author: rstrandh Index: mcclim/Tests/regions.lisp diff -u mcclim/Tests/regions.lisp:1.2 mcclim/Tests/regions.lisp:1.3 --- mcclim/Tests/regions.lisp:1.2 Thu Sep 8 23:43:22 2005 +++ mcclim/Tests/regions.lisp Sun Sep 11 23:44:42 2005 @@ -143,7 +143,9 @@ (push (make-point x y) points)) pl1) (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) - (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal))) + (assert (polyline-closed pl3)) + (assert (not (polyline-closed pl2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -172,3 +174,57 @@ pg1) (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; line + +(assert (subtypep 'line 'polyline)) +(assert (subtypep 'standard-line 'line)) + +(let* ((x1 234) (y1 876) (x2 345) (y2 -55) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) + (l1 (make-line p1 p2)) (l2 (make-line* x1 y1 x2 y2))) + (assert (typep l1 'standard-line)) + (assert (linep l1)) + (assert (region-equal l1 l2)) + (multiple-value-bind (xx1 yy1) (line-start-point* l1) + (assert (= (coordinate x1) xx1)) + (assert (= (coordinate y1) yy1))) + (multiple-value-bind (xx2 yy2) (line-end-point* l1) + (assert (= (coordinate x2) xx2)) + (assert (= (coordinate y2)yy2))) + (assert (region-equal p1 (line-start-point l1))) + (assert (region-equal p2 (line-end-point l1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; rectangle + +(assert (subtypep 'rectangle 'polygon)) +(assert (subtypep 'standard-rectangle 'rectangle)) + +(let* ((x1 234) (y1 876) (x2 345) (y2 -55) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) + (r1 (make-rectangle p1 p2)) (r2 (make-rectangle* x1 y1 x2 y2))) + (assert (typep r1 'standard-rectangle)) + (assert (rectanglep r1)) + (assert (region-equal r1 r2)) + (multiple-value-bind (min-x min-y max-x max-y) (rectangle-edges* r1) + (assert (= (rectangle-min-x r1) min-x)) + (assert (= (rectangle-min-y r1) min-y)) + (assert (= (rectangle-max-x r1) max-x)) + (assert (= (rectangle-max-y r1) max-y)) + (assert (= (coordinate x1) min-x)) + (assert (= (coordinate y1) max-y)) + (assert (= (coordinate x2) max-x)) + (assert (= (coordinate y2) min-y)) + (multiple-value-bind (width height) (rectangle-size r1) + (assert (= width (rectangle-width r1))) + (assert (= height (rectangle-height r1))) + (assert (= width (- max-x min-x))) + (assert (= height (- max-y min-y))))) + (assert (region-equal (make-point x1 y2) (rectangle-min-point r1))) + (assert (region-equal (make-point x2 y1) (rectangle-max-point r1)))) + +

1 0

[mcclim-cvs] CVS update: mcclim/graphics.lisp
by rschlatte＠common-lisp.net 10 Sep '05

10 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26755 Modified Files: graphics.lisp Log Message: Implement with-output-to-pixmap with incomplete / missing size arguments Date: Sat Sep 10 13:53:15 2005 Author: rschlatte Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.50 mcclim/graphics.lisp:1.51 --- mcclim/graphics.lisp:1.50 Wed Feb 2 12:33:58 2005 +++ mcclim/graphics.lisp Sat Sep 10 13:53:15 2005 @@ -705,15 +705,28 @@ ;;; mess. I think we need a pixmap output recording stream in order to do this ;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) - `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) ; XXX size might be unspecified -- APD - (,medium-var (make-medium (port ,sheet) pixmap)) - (old-medium (sheet-medium ,sheet))) - (setf (slot-value pixmap 'medium) ,medium-var) ; hmm, [seems to work] -- BTS - (setf (%sheet-medium ,sheet) ,medium-var) ;is sheet a sheet-with-medium-mixin? --GB - (unwind-protect - (progn ,@body) - (setf (%sheet-medium ,sheet) old-medium));is sheet a sheet-with-medium-mixin? --GB - pixmap)) + (if (and width height) + `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) + (,medium-var (make-medium (port ,sheet) pixmap)) + (old-medium (sheet-medium ,sheet))) + (setf (slot-value pixmap 'medium) ,medium-var) ; hmm, [seems to work] -- BTS + (setf (%sheet-medium ,sheet) ,medium-var) ;is sheet a sheet-with-medium-mixin? --GB + (unwind-protect + (progn ,@body) + (setf (%sheet-medium ,sheet) old-medium)) ;is sheet a sheet-with-medium-mixin? --GB + pixmap) + (let ((record (gensym "OUTPUT-RECORD-"))) + ;; rudi (2005-09-05) What to do when only width or height are + ;; given? And what's the meaning of medium-var? + `(let* ((,medium-var ,sheet) + (,record (with-output-to-output-record (,medium-var) + ,@body))) + (with-output-to-pixmap + (,medium-var + ,sheet + :width ,(or width `(bounding-rectangle-width ,record)) + :height ,(or height `(bounding-rectangle-height ,record))) + (replay-output-record ,record ,sheet)))))) ;;; XXX This seems to be incorrect. ;;; This presumes that your drawing will completely fill the bounding rectangle

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 08 Sep '05

08 Sep '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv28792 Modified Files: regions.lisp Log Message: More tests for regions. Lines and rectangles are not done yet. Date: Thu Sep 8 23:43:23 2005 Author: rstrandh Index: mcclim/Tests/regions.lisp diff -u mcclim/Tests/regions.lisp:1.1 mcclim/Tests/regions.lisp:1.2 --- mcclim/Tests/regions.lisp:1.1 Fri Aug 26 21:58:37 2005 +++ mcclim/Tests/regions.lisp Thu Sep 8 23:43:22 2005 @@ -16,8 +16,6 @@ (assert (subtypep 'path 'region)) (assert (subtypep 'path 'bounding-rectangle)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; area @@ -27,7 +25,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; coordiante +;;; coordinate (assert (or (and (subtypep 'coordinate t) (subtypep t 'coordinate)) @@ -100,4 +98,77 @@ (assert (or (typep d 'standard-region-difference) (pointp d))) (assert (member (length regions) '(1 2))) - (assert (member p1 regions :test #'region-equal))) + (assert (member p1 regions :test #'region-equal)) + (let* ((regions2 '())) + (map-over-region-set-regions + (lambda (region) (push region regions2)) + d) + (assert (null (set-difference regions regions2 :test #'region-equal))) + (assert (null (set-difference regions2 regions :test #'region-equal))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; polyline + +(assert (subtypep 'polyline 'path)) +(assert (subtypep 'standard-polyline 'polyline)) + +(let* ((x1 10) (y1 22) (x2 30) (y2 30) (x3 50) (y3 5) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) (p3 (make-point x3 y3)) + (pl1 (make-polyline (list p1 p2 p3))) + (pl2 (make-polyline* (list x1 y1 x2 y2 x3 y3))) + (pl3 (make-polyline (list p1 p2 p3) :closed t)) + (pl4 (make-polyline* (list x1 y1 x2 y2 x3 y3) :closed t)) + (points '())) + (assert (typep pl1 'standard-polyline)) + (assert (polylinep pl1)) + (assert (typep pl2 'standard-polyline)) + (assert (polylinep pl2)) + (assert (region-equal pl1 pl2)) + (assert (typep pl3 'standard-polyline)) + (assert (polylinep pl3)) + (assert (typep pl4 'standard-polyline)) + (assert (polylinep pl4)) + (assert (region-equal pl3 pl4)) + (assert (null (set-difference (polygon-points pl1) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl1) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl2) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl2) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl3) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl3) :test #'region-equal))) + (assert (null (set-difference (polygon-points pl4) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pl4) :test #'region-equal))) + (map-over-polygon-coordinates + (lambda (x y) + (push (make-point x y) points)) + pl1) + (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; polygon + +(assert (subtypep 'polygon 'area)) +(assert (subtypep 'standard-polygon 'polygon)) + +(let* ((x1 10) (y1 22) (x2 30) (y2 30) (x3 50) (y3 5) + (p1 (make-point x1 y1)) (p2 (make-point x2 y2)) (p3 (make-point x3 y3)) + (pg1 (make-polygon (list p1 p2 p3))) + (pg2 (make-polygon* (list x1 y1 x2 y2 x3 y3))) + (points '())) + (assert (typep pg1 'standard-polygon)) + (assert (polygonp pg1)) + (assert (typep pg2 'standard-polygon)) + (assert (polygonp pg2)) + (assert (region-equal pg1 pg2)) + (assert (null (set-difference (polygon-points pg1) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pg1) :test #'region-equal))) + (assert (null (set-difference (polygon-points pg2) (list p1 p2 p3) :test #'region-equal))) + (assert (null (set-difference (list p1 p2 p3) (polygon-points pg2) :test #'region-equal))) + (map-over-polygon-coordinates + (lambda (x y) + (push (make-point x y) points)) + pg1) + (assert (null (set-difference (list p1 p2 p3) points :test #'region-equal))) + (assert (null (set-difference points (list p1 p2 p3) :test #'region-equal))))

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by mretzlaff＠common-lisp.net 02 Sep '05

02 Sep '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19729 Modified Files: presentation-defs.lisp Log Message: In response to: http://article.gmane.org/gmane.lisp.mcclim.devel/724 We reSIGNAL the condition now before the call to ABORT, to give outer handlers a chance to say "I know how to handle this" (as Christophe Rhodes has put it). Date: Fri Sep 2 13:36:48 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.47 mcclim/presentation-defs.lisp:1.48 --- mcclim/presentation-defs.lisp:1.47 Thu Sep 1 04:59:11 2005 +++ mcclim/presentation-defs.lisp Fri Sep 2 13:36:48 2005 @@ -664,7 +664,9 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (handler-bind ((abort-gesture #'abort)) + (handler-bind ((abort-gesture (lambda (condition) + (signal condition) ;; to give outer handlers a chance to say "I know how to handle this" + (abort condition)))) (let* ((real-type (expand-presentation-type-abbreviation type)) (real-default-type (cond (default-type-p (expand-presentation-type-abbreviation

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp mcclim/presentations.lisp
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10674 Modified Files: presentation-defs.lisp presentations.lisp Log Message: Section 23.7.1 "Defining Presentation Translators" of the clim spec says in the subsection on DEFINE-PRESENTATION-ACTION: Note that the tester for presentation actions is always assumed to be definitive. This hasn't been the case until now for McCLIM. In addition to this the lambda-list of DEFINE-DRAG-AND-DROP-TRANSLATOR has been revised a bit. (Note that I couldn't find a sentence in the spec that specifies the default value for the parameter MENU, but the other three define-translator macros have all t as the default. Nevertheless, most of the parameters are ignored right now.) Date: Thu Sep 1 04:59:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.46 mcclim/presentation-defs.lisp:1.47 --- mcclim/presentation-defs.lisp:1.46 Thu Aug 25 22:24:10 2005 +++ mcclim/presentation-defs.lisp Thu Sep 1 04:59:11 2005 @@ -2020,17 +2020,20 @@ (presentation-subtypep subtype-over over)))))) (defmacro define-drag-and-drop-translator - (name - (from-type to-type destination-type command-table - &rest args - &key (gesture :select) tester documentation - pointer-documentation menu priority - (feedback 'frame-drag-and-drop-feedback) - (highlighting 'frame-drag-and-drop-highlighting)) + (name (from-type to-type destination-type command-table + &rest args &key + (gesture :select) + (tester 'default-translator-tester) + documentation + (pointer-documentation nil pointer-documentation-p) + (menu t) + (priority 0) + (feedback 'frame-drag-and-drop-feedback) + (highlighting 'frame-drag-and-drop-highlighting)) arglist &body body) - (declare (ignore tester documentation pointer-documentation menu - priority)) + (declare (ignore tester documentation pointer-documentation pointer-documentation-p + menu priority)) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-dest-type (expand-presentation-type-abbreviation destination-type)) Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.70 mcclim/presentations.lisp:1.71 --- mcclim/presentations.lisp:1.70 Fri Jan 14 13:43:23 2005 +++ mcclim/presentations.lisp Thu Sep 1 04:59:11 2005 @@ -1357,6 +1357,7 @@ `',tester `#',(make-translator-fun (car tester) (cdr tester))) + :tester-definitive t :documentation #',(make-documentation-fun documentation) ,@(when pointer-documentation-p `(:pointer-documentation

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/icons/wild.xpm
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener/icons In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener/icons Added Files: wild.xpm Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:41 2005 Author: mretzlaff

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/file-types.lisp mcclim/Apps/Listener/util.lisp
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp util.lisp Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:38 2005 Author: mretzlaff Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.29 mcclim/Apps/Listener/dev-commands.lisp:1.30 --- mcclim/Apps/Listener/dev-commands.lisp:1.29 Thu Apr 21 05:41:24 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Wed Aug 31 07:50:37 2005 @@ -1028,7 +1028,9 @@ (terpri stream)) (defun sort-pathnames (list sort-by) - list) ; <--- FIXME + (case sort-by ; <--- FIXME + ('name (sort list #'string-lessp :key #'file-namestring)) + (t list))) (defun split-sort-pathnames (list group-dirs sort-by) (mapcar (lambda (x) (sort-pathnames x sort-by)) @@ -1064,31 +1066,37 @@ :provide-output-destination-keyword t) ((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname") &key - #+NIL (sort-by '(member name size modify none) :default 'name) + (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default T :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") (group-directories 'boolean :default T :prompt "group directories?") - (full-names 'boolean :default nil :prompt "show full name?")) + (full-names 'boolean :default nil :prompt "show full name?") + (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this.. (merge-pathnames pathname) pathname)) - (dir (list-directory (gen-wild-pathname pathname)))) + (wild-pathname (gen-wild-pathname pathname)) + (dir (if list-all-direct-subdirectories + (list-directory-with-all-direct-subdirectories wild-pathname) + (list-directory wild-pathname)))) (with-text-family (T :sans-serif) (invoke-as-heading (lambda () (format T "Directory contents of ") - (present pathname))) + (present (directory-namestring pathname) 'pathname) + (when (pathname-type pathname) + (format T " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (parent-directory pathname) 'clim:pathname) + (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) (format T "Parent Directory~%"))) - (dolist (group (split-sort-pathnames dir group-directories :none #+NIL sort-by)) + (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style @@ -1105,7 +1113,8 @@ (goatee::reposition-stream-cursor *standard-output*) (vertical-gap T)) (list (dolist (ent group) - (let ((ent (merge-pathnames ent pathname))) ; This is for CMUCL, see above. (fixme!) + (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) + ;; And breaks some things for SBCL.. (mgr) (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) #+nil ; OBSOLETE Index: mcclim/Apps/Listener/file-types.lisp diff -u mcclim/Apps/Listener/file-types.lisp:1.7 mcclim/Apps/Listener/file-types.lisp:1.8 --- mcclim/Apps/Listener/file-types.lisp:1.7 Sun Nov 9 22:12:05 2003 +++ mcclim/Apps/Listener/file-types.lisp Wed Aug 31 07:50:37 2005 @@ -133,7 +133,8 @@ ;; ICON-OF is measurably slow here in CMUCL. Interesting.. (defmethod icon-of ((pathname pathname)) - (cond ((not (probe-file pathname)) (standard-icon "invalid.xpm")) + (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) + ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.17 mcclim/Apps/Listener/util.lisp:1.18 --- mcclim/Apps/Listener/util.lisp:1.17 Tue Feb 22 04:10:27 2005 +++ mcclim/Apps/Listener/util.lisp Wed Aug 31 07:50:37 2005 @@ -118,6 +118,8 @@ #+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)) @@ -141,6 +143,19 @@ (defun list-directory (pathname) (directory pathname)) +;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory +;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname. + +(defun list-directory-with-all-direct-subdirectories (pathname) + (let ((file-list (list-directory pathname))) + (if (wild-pathname-p pathname) + (nconc file-list + (delete-if (lambda (directory) + (member directory file-list :test #'equal)) + (delete-if-not #'directoryp + (list-directory (gen-wild-pathname + (strip-filespec pathname)))))) + file-list))) ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program.

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by mretzlaff＠common-lisp.net 29 Aug '05

29 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15426 Modified Files: panes.lisp Log Message: Added a method PANE-BORDER that works just like PANE-VIEWPORT and PANE-SCROLLER, only for BORDER-PANEs. It is not in the spec, but so is the BORDER-PANE as a whole. (And, yes, I needed it.) In addition to this it changes the IFs in PANE-VIEWPORT and PANE-SCROLLER to WHENs (both had no else-forms). (Minor change: Five changes in the comments: The section titles of the different panes are made consistent. (Most of them were of the pattern "FOO PANE", only five of them "FOO-PANE"; as I liked the former pattern more, they are now all of that pattern.)) Date: Tue Aug 30 00:39:31 2005 Author: mretzlaff Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.154 mcclim/panes.lisp:1.155 --- mcclim/panes.lisp:1.154 Fri Aug 19 04:20:35 2005 +++ mcclim/panes.lisp Tue Aug 30 00:39:31 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.155 2005/08/29 22:39:31 mretzlaff Exp $ (in-package :clim-internals) @@ -795,7 +795,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; BASIC-PANE +;;; BASIC PANE (defclass basic-pane (;; layout-protocol-mixin standard-space-requirement-options-mixin @@ -957,7 +957,7 @@ (event window-manager-delete-event)) (frame-exit (pane-frame (event-sheet event)))) -;;;; UNMANAGED-TOP-LEVEL-SHEET-PANE +;;;; UNMANAGED-TOP-LEVEL-SHEET PANE (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane) () @@ -1643,7 +1643,7 @@ (- width border-width border-width) (- height border-width border-width))))) -;;; OUTLINED-PANE +;;; OUTLINED PANE ;; same as SPACING-PANE but a different default background. @@ -1654,7 +1654,7 @@ (defmacro outlining ((&rest options) &body contents) `(make-pane 'outlined-pane ,@options :contents (list ,@contents))) -;;; BORDER-PANE +;;; BORDER PANE ;; same as outlined-pane, but thickness is now called border-width. @@ -1667,6 +1667,11 @@ (defmacro bordering ((&rest options) &body contents) `(make-pane 'border-pane ,@options :contents (list ,@contents))) +(defmethod pane-border ((pane basic-pane)) + (let ((parent (sheet-parent pane))) + (when (and parent (typep parent 'border-pane)) + parent))) + ;;; RAISED PANE (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin) @@ -1751,7 +1756,7 @@ (note-input-focus-changed (sheet-child pane) state)) ;;;; -;;;; SCROLLER-PANE +;;;; SCROLLER PANE ;;;; ;;; How scrolling is done @@ -2033,9 +2038,8 @@ (defmethod pane-viewport ((pane basic-pane)) (let ((parent (sheet-parent pane))) - (if (and parent (typep parent 'viewport-pane)) - parent - nil))) + (when (and parent (typep parent 'viewport-pane)) + parent))) ;;; Default for streams that aren't even panes. @@ -2051,7 +2055,7 @@ (defmethod pane-scroller ((pane basic-pane)) (let ((viewport (pane-viewport pane))) - (if viewport + (when viewport (sheet-parent viewport)))) (defmethod scroll-extent ((pane basic-pane) x y)

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30153/Tests Added Files: regions.lisp Log Message: Hopefully the beginning of a testing framework for McCLIM. Date: Fri Aug 26 21:58:38 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Tests
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30107/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Tests added to the repository Date: Fri Aug 26 21:56:59 2005 Author: rstrandh New directory mcclim/Tests added

1 0