[mcclim-cvs] CVS mcclim/Apps/Listener
ahefner
ahefner at common-lisp.net
Mon Feb 5 03:27:14 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory clnet:/tmp/cvs-serv10098
Modified Files:
listener.lisp
Added Files:
wholine.lisp
Log Message:
Break the wholine off into its own file.
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/01/14 14:53:54 1.33
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/02/05 03:27:14 1.34
@@ -1,4 +1,3 @@
-(in-package :clim-listener)
;;; This is a lisp listener.
@@ -19,104 +18,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-(define-presentation-type listener-current-package () :inherit-from 'package)
-
-;; Wholine Pane
-
-(defclass wholine-pane (application-pane) ()
- (:default-initargs :background +gray90+))
-
-(defmethod compose-space ((pane wholine-pane) &key width height)
- (declare (ignore width height))
- (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding
- (make-space-requirement :height h
- :min-height h
- :max-height h)))
-
-;; When the pane is grown, we must repaint more than just the newly exposed
-;; regions, because the decoration within the previous region must move.
-;; Likewise, shrinking the pane requires repainting some of the interior.
-(defmethod allocate-space :after ((pane wholine-pane) width height)
- (repaint-sheet pane (sheet-region pane)))
-
-(defun print-package-name (stream)
- (let ((foo (package-name *package*)))
- (with-drawing-options (stream :ink +royalblue+)
- (format stream "~A" (reduce (lambda (&optional (a foo) (b foo))
- (if (< (length a) (length b)) a b))
- (package-nicknames *package*))))))
-
-(defun frob-pathname (pathname)
- (namestring (truename pathname)))
-
-;; How to add repaint-time decoration underneath the contents of a
-;; stream pane: Write your own handle-repaint that draws the
-;; decoration then replays the recorded output, and define a
-;; window-clear method which calls the next window-clear method,
-;; then calls handle-repaint to redraw the decoration.
-
-(defmethod handle-repaint ((pane wholine-pane) region)
- (declare (ignore region))
- (with-output-recording-options (pane :draw t :record nil)
- (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane)
- (climi::draw-bordered-rectangle* (sheet-medium pane)
- x0 y0 x1 y1
- :style :mickey-mouse-inset)
- #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+))
- (replay-output-record (stream-output-history pane) pane)))
-
-(defmethod window-clear ((pane wholine-pane))
- (call-next-method)
- (handle-repaint pane (sheet-region pane)))
-
-(defun generate-wholine-contents (frame pane)
- (declare (ignore frame))
- (let* ((*standard-output* pane)
- (username (or #+cmu (cdr (assoc :user ext:*environment-list*))
- #+scl (cdr (assoc "USER" ext:*environment-list*
- :test 'string=))
- #+allegro (sys:getenv "USER")
- #-(or allegro cmu scl) (getenv "USER")
- "luser")) ; sorry..
- (sitename (machine-instance))
- (memusage #+(or cmu scl) (lisp::dynamic-usage)
- #+sbcl (sb-kernel:dynamic-usage)
- #+lispworks (getf (system:room-values) :total-allocated)
- #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes))
- #+clisp (values (sys::%room))
- #-(or cmu scl sbcl lispworks openmcl clisp) 0))
- (with-text-family (t :serif)
- (formatting-table (t :x-spacing '(3 :character))
- (formatting-row (t)
- (macrolet ((cell ((align-x) &body body)
- `(formatting-cell (t :align-x ,align-x) , at body)))
- (cell (:left) (format t "~A@~A" username sitename))
- (cell (:center)
- (format t "Package ")
- (with-output-as-presentation (t *package* 'listener-current-package)
- (print-package-name t)))
- (cell (:center)
- ;; CLISP gives us an error when calling
- ;; `cl:probe-file' with a directory argument.
- (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*))
- (ignore-errors (probe-file *default-pathname-defaults*)))
- #-clisp (probe-file *default-pathname-defaults*)
- (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname)
- (format t "~A" (frob-pathname *default-pathname-defaults*))))
- (when *directory-stack*
- (with-output-as-presentation (t *directory-stack* 'directory-stack)
- (format t " (~D deep)" (length *directory-stack*)))))
- ;; Although the CLIM spec says the item formatter should try to fill
- ;; the available width, I can't get either the item or table formatters
- ;; to really do so such that the memory usage appears right justified.
- (cell (:center)
- (when (numberp memusage)
- (present memusage 'lisp-memory-usage)))))))))
-
-(defun display-wholine (frame pane)
- (invoke-and-center-output pane
- (lambda () (generate-wholine-contents frame pane))
- :horizontally nil :hpad 5))
+(in-package :clim-listener)
;;; Listener view
;;;
@@ -182,15 +84,15 @@
((system-command-reader :accessor system-command-reader
:initarg :system-command-reader
:initform t))
- (:panes (interactor-container
- (make-clim-stream-pane
- :type 'listener-interactor-pane
- :name 'interactor :scroll-bars t
- :default-view +listener-view+))
- (doc :pointer-documentation :default-view +listener-pointer-documentation-view+)
- (wholine (make-pane 'wholine-pane
- :display-function 'display-wholine :scroll-bars nil
- :display-time :command-loop :end-of-line-action :allow)))
+ (:panes (interactor-container
+ (make-clim-stream-pane
+ :type 'listener-interactor-pane
+ :name 'interactor :scroll-bars t
+ :default-view +listener-view+))
+ (doc :pointer-documentation :default-view +listener-pointer-documentation-view+)
+ (wholine (make-pane 'wholine-pane
+ :display-function 'display-wholine :scroll-bars nil
+ :display-time :command-loop :end-of-line-action :allow)))
(:top-level (default-frame-top-level :prompt 'print-listener-prompt))
(:command-table (listener
:inherit-from (application-commands lisp-commands filesystem-commands show-commands)
@@ -253,12 +155,12 @@
(defun run-listener (&key (new-process nil)
(width 760)
(height 550)
- (process-name "Listener"))
- (flet ((run ()
- (let ((frame (make-application-frame
- 'listener
- :width width :height height)))
- (run-frame-top-level frame))))
- (if new-process
- (clim-sys:make-process #'run :name process-name)
- (run))))
+ (process-name "Listener"))
+ (let ((frame (make-application-frame 'listener
+ :width width
+ :height height)))
+ (flet ((run () (run-frame-top-level frame)))
+ (if new-process
+ (values (clim-sys:make-process #'run :name process-name)
+ frame)
+ (run)))))
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/02/05 03:27:14 NONE
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/02/05 03:27:14 1.1
;;; Listener "wholine"
;;; (C) Copyright 2003 by Andy Hefner (hefner1 at umbc.edu)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-listener)
(define-presentation-type listener-current-package () :inherit-from 'package)
;; Wholine Pane
(defclass wholine-pane (application-pane) ()
(:default-initargs :background +gray90+))
(defmethod compose-space ((pane wholine-pane) &key width height)
(declare (ignore width height))
(let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding
(make-space-requirement :height h
:min-height h
:max-height h)))
;; When the pane is grown, we must repaint more than just the newly exposed
;; regions, because the decoration within the previous region must move.
;; Likewise, shrinking the pane requires repainting some of the interior.
(defmethod allocate-space :after ((pane wholine-pane) width height)
(repaint-sheet pane (sheet-region pane)))
(defun print-package-name (stream)
(let ((foo (package-name *package*)))
(with-drawing-options (stream :ink +royalblue+)
(format stream "~A" (reduce (lambda (&optional (a foo) (b foo))
(if (< (length a) (length b)) a b))
(package-nicknames *package*))))))
(defun frob-pathname (pathname)
(namestring (truename pathname)))
;; How to add repaint-time decoration underneath the contents of a
;; stream pane: Write your own handle-repaint that draws the
;; decoration then replays the recorded output, and define a
;; window-clear method which calls the next window-clear method,
;; then calls handle-repaint to redraw the decoration.
(defmethod handle-repaint ((pane wholine-pane) region)
(declare (ignore region))
(with-output-recording-options (pane :draw t :record nil)
(with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane)
(climi::draw-bordered-rectangle* (sheet-medium pane)
x0 y0 x1 y1
:style :mickey-mouse-inset)
#+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+))
(replay-output-record (stream-output-history pane) pane)))
(defmethod window-clear ((pane wholine-pane))
(call-next-method)
(handle-repaint pane (sheet-region pane)))
(defun generate-wholine-contents (frame pane)
(declare (ignore frame))
(let* ((*standard-output* pane)
(username (or #+cmu (cdr (assoc :user ext:*environment-list*))
#+scl (cdr (assoc "USER" ext:*environment-list*
:test 'string=))
#+allegro (sys:getenv "USER")
#-(or allegro cmu scl) (getenv "USER")
"luser")) ; sorry..
(sitename (machine-instance))
(memusage #+(or cmu scl) (lisp::dynamic-usage)
#+sbcl (sb-kernel:dynamic-usage)
#+lispworks (getf (system:room-values) :total-allocated)
#+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes))
#+clisp (values (sys::%room))
#-(or cmu scl sbcl lispworks openmcl clisp) 0))
(with-text-family (t :serif)
(formatting-table (t :x-spacing '(3 :character))
(formatting-row (t)
(macrolet ((cell ((align-x) &body body)
`(formatting-cell (t :align-x ,align-x) , at body)))
(cell (:left) (format t "~A@~A" username sitename))
(cell (:center)
(format t "Package ")
(with-output-as-presentation (t *package* 'listener-current-package)
(print-package-name t)))
(cell (:center)
;; CLISP gives us an error when calling
;; `cl:probe-file' with a directory argument.
(when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*))
(ignore-errors (probe-file *default-pathname-defaults*)))
#-clisp (probe-file *default-pathname-defaults*)
(with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname)
(format t "~A" (frob-pathname *default-pathname-defaults*))))
(when *directory-stack*
(with-output-as-presentation (t *directory-stack* 'directory-stack)
(format t " (~D deep)" (length *directory-stack*)))))
;; Although the CLIM spec says the item formatter should try to fill
;; the available width, I can't get either the item or table formatters
;; to really do so such that the memory usage appears right justified.
(cell (:center)
(when (numberp memusage)
(present memusage 'lisp-memory-usage)))))))))
(defun display-wholine (frame pane)
(invoke-and-center-output pane
(lambda () (generate-wholine-contents frame pane))
:horizontally nil :hpad 5))
More information about the Mcclim-cvs
mailing list