From rstrandh at common-lisp.net Sat Aug 1 05:22:52 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 01 Aug 2009 01:22:52 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv11826 Modified Files: stream-output.lisp Log Message: Removed some tabs at the request of Cyrus Harmon. There are lots of tabs in McCLIM source code, so I don't think it is practical to remove them all right away. Perhaps take the advantage when there are other modifications as well. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2009/07/31 11:32:21 1.64 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2009/08/01 05:22:51 1.65 @@ -198,12 +198,12 @@ :end-of-page-action :scroll :default-view +textual-view+)) (defmethod stream-force-output :after ((stream - standard-extended-output-stream)) + standard-extended-output-stream)) (with-sheet-medium (medium stream) (medium-force-output medium))) (defmethod stream-finish-output :after ((stream - standard-extended-output-stream)) + standard-extended-output-stream)) (with-sheet-medium (medium stream) (medium-finish-output medium))) From rstrandh at common-lisp.net Sat Aug 1 05:23:48 2009 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 01 Aug 2009 01:23:48 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv12186 Modified Files: recording.lisp Log Message: Patch from Nikodemus Siivola fixing a problem with missing unquotes. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2009/06/16 05:15:35 1.143 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2009/08/01 05:23:47 1.144 @@ -324,7 +324,7 @@ (,continuation (,stream ,record) ,(declare-ignorable-form* stream record) , at body)) - (declare (dynamic-extent #'constructor #'continuation)) + (declare (dynamic-extent #',constructor #',continuation)) (,',func-name ,stream #',continuation ,record-type #',constructor , at m-i-args))))))) From gbaumann at common-lisp.net Sat Aug 1 16:10:32 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 12:10:32 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv2833 Modified Files: frames.lisp incremental-redisplay.lisp package.lisp recording.lisp table-formatting.lisp text-selection.lisp Log Message: Use force-output instead of finish-output as the latter implies waiting for an answer from the display server, which is something we really do not want to do. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2009/02/28 16:49:40 1.136 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2009/08/01 16:10:31 1.137 @@ -466,62 +466,62 @@ (defmethod default-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) - (command-unparser 'command-line-command-unparser) - (partial-command-parser - 'command-line-read-remaining-arguments-for-partial-command) - (prompt "Command: ")) + (command-unparser 'command-line-command-unparser) + (partial-command-parser + 'command-line-read-remaining-arguments-for-partial-command) + (prompt "Command: ")) ;; Give each pane a fresh start first time through. (let ((first-time t)) (loop ;; The variables are rebound each time through the loop because the ;; values of frame-standard-input et al. might be changed by a command. (let* ((*standard-input* (or (frame-standard-input frame) - *standard-input*)) - (*standard-output* (or (frame-standard-output frame) - *standard-output*)) - (query-io (frame-query-io frame)) - (*query-io* (or query-io *query-io*)) - (*pointer-documentation-output* - (frame-pointer-documentation-output frame)) - ;; during development, don't alter *error-output* - ;; (*error-output* (frame-error-output frame)) - (*command-parser* command-parser) - (*command-unparser* command-unparser) - (*partial-command-parser* partial-command-parser) - (interactorp (typep *query-io* 'interactor-pane))) - (restart-case - (progn - (redisplay-frame-panes frame :force-p first-time) - (setq first-time nil) - (if query-io + *standard-input*)) + (*standard-output* (or (frame-standard-output frame) + *standard-output*)) + (query-io (frame-query-io frame)) + (*query-io* (or query-io *query-io*)) + (*pointer-documentation-output* + (frame-pointer-documentation-output frame)) + ;; during development, don't alter *error-output* + ;; (*error-output* (frame-error-output frame)) + (*command-parser* command-parser) + (*command-unparser* command-unparser) + (*partial-command-parser* partial-command-parser) + (interactorp (typep *query-io* 'interactor-pane))) + (restart-case + (progn + (redisplay-frame-panes frame :force-p first-time) + (setq first-time nil) + (if query-io ;; For frames with an interactor: - (progn + (progn ;; Hide cursor, so we don't need to toggle it during ;; command output. - (setf (cursor-visibility (stream-text-cursor *query-io*)) - nil) - (when (and prompt interactorp) - (with-text-style (*query-io* +default-prompt-style+) - (if (stringp prompt) - (write-string prompt *query-io*) - (funcall prompt *query-io* frame)) - (finish-output *query-io*))) - (let ((command (read-frame-command frame - :stream *query-io*))) - (when interactorp - (fresh-line *query-io*)) - (when command - (execute-frame-command frame command)) - (when interactorp - (fresh-line *query-io*)))) + (setf (cursor-visibility (stream-text-cursor *query-io*)) + nil) + (when (and prompt interactorp) + (with-text-style (*query-io* +default-prompt-style+) + (if (stringp prompt) + (write-string prompt *query-io*) + (funcall prompt *query-io* frame)) + (force-output *query-io*))) + (let ((command (read-frame-command frame + :stream *query-io*))) + (when interactorp + (fresh-line *query-io*)) + (when command + (execute-frame-command frame command)) + (when interactorp + (fresh-line *query-io*)))) ;; Frames without an interactor: (let ((command (read-frame-command frame :stream nil))) (when command (execute-frame-command frame command))))) - (abort () - :report "Return to application command loop" - (if interactorp - (format *query-io* "~&Command aborted.~&") - (beep)))))))) + (abort () + :report "Return to application command loop" + (if interactorp + (format *query-io* "~&Command aborted.~&") + (beep)))))))) (defmethod read-frame-command :around ((frame application-frame) &key (stream *standard-input*)) --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/09/25 00:30:01 1.65 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2009/08/01 16:10:32 1.66 @@ -513,7 +513,7 @@ (rectangle-edges* sub-record)))) record nil) - (finish-output stream) + (force-output stream) ;; Why is this binding here? We need the "environment" in this call that ;; computes the new records of an outer updating output record to resemble ;; that when a record's contents are computed in invoke-updating-output. @@ -860,7 +860,7 @@ unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) - (finish-output stream) + (force-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) (setq unique-id (incf (id-counter parent-cache)))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/08/21 22:34:28 1.70 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 16:10:32 1.71 @@ -234,7 +234,7 @@ nil))) packages) (progn (format t "~&there is no ~A." name) - (finish-output) + (force-output) nil))) (dump-defpackage (&aux imports export-ansi export-gray) (labels ((push-import-from (symbol package) @@ -255,7 +255,7 @@ (and sym2 (eq res :external)))) ;; (format t "~&;; ~S is patched." sym) - (finish-output) + (force-output) (push-import-from nam :clim-lisp-patch)) (t (setf sym (car sym)) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2009/08/01 05:23:47 1.144 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2009/08/01 16:10:32 1.145 @@ -2292,7 +2292,7 @@ (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) - (finish-output stream)) + (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) @@ -2309,7 +2309,7 @@ (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) - (finish-output stream)) + (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) @@ -2325,7 +2325,7 @@ (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) - (finish-output stream))) + (force-output stream))) new-record)) (defmethod invoke-with-output-to-output-record @@ -2337,7 +2337,7 @@ (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) - (finish-output stream))) + (force-output stream))) new-record)) (defmethod make-design-from-output-record (record) --- /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2008/11/09 19:58:26 1.41 +++ /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2009/08/01 16:10:32 1.42 @@ -319,7 +319,7 @@ (let ((*table-suppress-update* t)) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) - (finish-output stream)) + (force-output stream)) (with-output-recording-options (stream :record nil :draw nil) (adjust-table-cells table stream) (when multiple-columns (adjust-multiple-columns table stream)) @@ -427,7 +427,7 @@ (stream-cursor-position stream) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) - (finish-output stream)) + (force-output stream)) (adjust-item-list-cells item-list stream) (setf (output-record-position item-list) (stream-cursor-position stream)) --- /project/mcclim/cvsroot/mcclim/text-selection.lisp 2009/06/03 20:33:16 1.8 +++ /project/mcclim/cvsroot/mcclim/text-selection.lisp 2009/08/01 16:10:32 1.9 @@ -289,7 +289,7 @@ (push (setf q (cons y nil)) *lines*)) (push (list x y string ts record full-record) (cdr q))) - (finish-output *trace-output*))) + (force-output *trace-output*))) (setf *lines* (sort (mapcar (lambda (line) (cons (car line) From gbaumann at common-lisp.net Sat Aug 1 16:10:39 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 12:10:39 -0400 Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv2833/Backends/CLX Modified Files: port.lisp Log Message: Use force-output instead of finish-output as the latter implies waiting for an answer from the display server, which is something we really do not want to do. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:21:00 1.140 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/08/01 16:10:39 1.141 @@ -863,7 +863,7 @@ (port-client-message sheet time type data)) (t (unless (xlib:event-listen (clx-port-display *clx-port*)) - (xlib:display-finish-output (clx-port-display *clx-port*))) + (xlib:display-force-output (clx-port-display *clx-port*))) nil))))) @@ -908,7 +908,7 @@ (let* ((*clx-port* port) (display (clx-port-display port))) (unless (xlib:event-listen display) - (xlib:display-finish-output (clx-port-display port))) + (xlib:display-force-output (clx-port-display port))) ; temporary solution (or (xlib:process-event (clx-port-display port) :timeout timeout :handler #'event-handler :discard-p t) :timeout))) @@ -1386,7 +1386,7 @@ #+nil ; debugging output (progn (describe event *trace-output*) - (finish-output *trace-output*)) + (force-output *trace-output*)) (flet ((send-event (&key target (property property)) ;; debugging output, but the KDE Klipper client turns out ;; to poll other clients for selection, which means it From gbaumann at common-lisp.net Sat Aug 1 21:27:14 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 17:27:14 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv4992 Modified Files: package.lisp panes.lisp Log Message: I like my scroll bars left, Hefner wants them right. So I made it tweakable. Default is right though. CLIM-EXTENSIONS:*DEFAULT-VERTICAL-SCROLL-BAR-POSITION* New variable^Wparameter intented to be settable by the user. VERTICAL-SCROLL-BAR-POSITION slot of SCROLLER-PANE :VERTICAL-SCROLL-BAR-POSITION init arg of SCROLLER-PANE New. (ALLOCATE-SPACE SCROLLER-PANE T T) Use it. Do not use *SCROLLBAR-THICKNESS*, but rely on the space requirements of the scroll bars. --- /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 16:10:32 1.71 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 21:27:13 1.72 @@ -1973,7 +1973,8 @@ #:define-bitmap-file-reader #:unsupported-bitmap-format - #:bitmap-format)) + #:bitmap-format + #:*default-vertical-scroll-bar-position*)) ;;; Symbols that must be defined by a backend. ;;; --- /project/mcclim/cvsroot/mcclim/panes.lisp 2009/06/03 20:33:16 1.195 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 21:27:13 1.196 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.195 2009/06/03 20:33:16 ahefner Exp $ +;;; $Id: panes.lisp,v 1.196 2009/08/01 21:27:13 gbaumann Exp $ (in-package :clim-internals) @@ -1929,6 +1929,13 @@ (defparameter *scrollbar-thickness* 17) +(defvar clim-extensions:*default-vertical-scroll-bar-position* + :right + "Default for the :VERTICAL-SCROLL-BAR-POSITION init arg of a + SCROLLER-PANE. Set it to :LEFT to have the vertical scroll bar of a + SCROLLER-PANE appear on the ergonomic left hand side, or leave set to + :RIGHT to have it on the distant right hand side of the scroller.") + (defclass scroller-pane (composite-pane) ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil) ;; ### Note: I added NIL here, so that the application @@ -1951,7 +1958,13 @@ (vscrollbar :initform nil) (hscrollbar :initform nil) (suggested-width :initform 300 :initarg :suggested-width) - (suggested-height :initform 300 :initarg :suggested-height)) + (suggested-height :initform 300 :initarg :suggested-height) + (vertical-scroll-bar-position + :initform clim-extensions:*default-vertical-scroll-bar-position* + :initarg :vertical-scroll-bar-position + :type (member :left :right) + :documentation "Whether to put the vertical scroll bar on the left hand or + right hand side of the scroller pane.")) (:default-initargs :x-spacing 4 :y-spacing 4)) @@ -2028,23 +2041,29 @@ (make-space-requirement)))) (defmethod allocate-space ((pane scroller-pane) width height) - (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing) pane - (let ((viewport-width (if vscrollbar (- width *scrollbar-thickness*) width)) - (viewport-height (if hscrollbar (- height *scrollbar-thickness*) height))) - + (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing vertical-scroll-bar-position) pane + (let* ((vsbar-width (if vscrollbar (space-requirement-width (compose-space vscrollbar)) 0)) + (hsbar-height (if hscrollbar (space-requirement-height (compose-space hscrollbar)) 0)) + (viewport-width (- width vsbar-width)) + (viewport-height (- height hsbar-height))) (when vscrollbar - (setf (sheet-transformation vscrollbar) - (make-translation-transformation (- width *scrollbar-thickness*) 0)) + (move-sheet vscrollbar + (ecase vertical-scroll-bar-position + (:left 0) + (:right (- width vsbar-width))) + 0) (allocate-space vscrollbar - *scrollbar-thickness* - (if hscrollbar (- height *scrollbar-thickness*) height))) + vsbar-width + (- height hsbar-height))) (when hscrollbar (move-sheet hscrollbar - 0 + (ecase vertical-scroll-bar-position + (:left vsbar-width) + (:right 0)) (- height *scrollbar-thickness*)) (allocate-space hscrollbar - (if vscrollbar (- width *scrollbar-thickness*) width) - *scrollbar-thickness*)) + (- width vsbar-width) + hsbar-height)) ;; ;; Recalculate the gadget-values of the scrollbars ;; @@ -2073,10 +2092,12 @@ max)))) (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport - (setf (sheet-transformation viewport) - (make-translation-transformation - (+ x-spacing 0) - (+ y-spacing 0))) + (move-sheet viewport + (+ x-spacing + (ecase vertical-scroll-bar-position + (:left vsbar-width) + (:right 0))) + (+ y-spacing 0)) (allocate-space viewport (- viewport-width (* 2 x-spacing)) (- viewport-height (* 2 y-spacing))))))) From gbaumann at common-lisp.net Sat Aug 1 22:11:06 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 18:11:06 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv15258 Modified Files: panes.lisp Log Message: (ALLOCATE-SPACE SCROLLER-PANE T T) Missed one *SCROLLBAR-THICKNESS* SCROLL-AREA Removed this ticking bomb. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 21:27:13 1.196 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 22:11:06 1.197 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.196 2009/08/01 21:27:13 gbaumann Exp $ +;;; $Id: panes.lisp,v 1.197 2009/08/01 22:11:06 gbaumann Exp $ (in-package :clim-internals) @@ -2060,7 +2060,7 @@ (ecase vertical-scroll-bar-position (:left vsbar-width) (:right 0)) - (- height *scrollbar-thickness*)) + (- height hsbar-height)) (allocate-space hscrollbar (- width vsbar-width) hsbar-height)) @@ -2646,19 +2646,6 @@ (scroll-extent pane x y) (values x y)) -;; this function appears to be unused, however... -;; v-- does this handle scrolling with occlusion? ie, if another thing is overlapping -;; the area being scrolled, will we copy junk off the top? -- BTS -(defun scroll-area (pane dx dy) - (let ((transform (sheet-transformation pane))) - ;; Region has been "scrolled" already. - (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) - (multiple-value-bind (srcx srcy) - (untransform-position transform 0 0) - (multiple-value-bind (destx desty) - (untransform-position transform dx dy) - (copy-area pane srcx srcy (- x2 x1) (- y2 y1) destx desty)))))) - (defmethod stream-set-input-focus ((stream clim-stream-pane)) (with-slots (port) stream (prog1 (port-keyboard-input-focus port) From gbaumann at common-lisp.net Sat Aug 1 22:15:32 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 18:15:32 -0400 Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv16195 Modified Files: frame-manager.lisp Log Message: (ADOPT-FRAME :AFTER CLX-FRAME-MANAGER APPLICATION-FRAME) If the frame happens to have a non-null calling-frame slot, tell the window manager. That way pop up dialogs are recognized as such allowing the window manager to apply what ever special handling it does to pop up windows. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2009/01/28 19:27:22 1.23 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2009/08/01 22:15:32 1.24 @@ -117,6 +117,14 @@ (setf (xlib:window-event-mask mirror) (logior (xlib:window-event-mask mirror) (xlib:make-event-mask :structure-notify))) + ;; Care for calling-frame, be careful not to trip on missing bits + (let* ((calling-frame (frame-calling-frame frame)) + (tls (and calling-frame (frame-top-level-sheet calling-frame))) + (calling-mirror (and tls (sheet-mirror tls)))) + (when calling-mirror + (setf (xlib:transient-for mirror) + calling-mirror))) + ;; (when (sheet-enabled-p sheet) (xlib:map-window mirror) )))) From gbaumann at common-lisp.net Sat Aug 1 22:17:07 2009 From: gbaumann at common-lisp.net (gbaumann) Date: Sat, 01 Aug 2009 18:17:07 -0400 Subject: [mcclim-cvs] CVS mcclim Message-ID: Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv16322 Modified Files: dialog.lisp Log Message: FRAME-MANAGER-NOTIFY-USER Use :calling-frame, leave shareing the event queue to the calling frame to what ever magic does it correctly in that case. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2008/12/07 03:22:54 1.31 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2009/08/01 22:17:02 1.32 @@ -737,7 +737,7 @@ ;; Keywords from notify-user: ;; associated-window title documentation exit-boxes name style text-style (let ((frame (make-application-frame 'generic-notify-user-frame - :frame-event-queue (and frame (frame-event-queue frame)) + :calling-frame frame :pretty-name title :message-string message-string :frame-manager frame-manager