/usr/share/common-lisp/source/mcclim/Apps/Listener/wholine.lisp is in cl-mcclim 0.9.6.dfsg.cvs20100315-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | ;;; Listener "wholine"
;;; (C) Copyright 2003 by Andy Hefner (hefner1@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)
(draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (pane-background pane))
(climi::draw-bordered-rectangle* (sheet-medium pane)
x0 y0 x1 y1
:style :mickey-mouse-inset))
(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))
;; :sans-serif :roman :small is the best looking jaggy font.
;; But :small looks awful using freetype, perhaps because the
;; fonts are, for whatever reason, slightly smaller.
;; Very distressing.
(text-size (if (find-package :mcclim-truetype) :normal :small))
(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-style (t (make-text-style :sans-serif :roman text-size))
(formatting-table (t :x-spacing '(3 :character))
(formatting-row (t)
(macrolet ((cell ((align-x) &body body)
`(formatting-cell (t :align-x ,align-x) ,@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))
|