Index: dialog.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/dialog.lisp,v retrieving revision 1.29 diff -u -r1.29 dialog.lisp --- dialog.lisp 1 Feb 2008 00:22:04 -0000 1.29 +++ dialog.lisp 13 May 2008 17:36:31 -0000 @@ -103,17 +103,26 @@ (selected-query :accessor selected-query :initform nil) (align-prompts :accessor align-prompts :initarg :align-prompts :initform nil) + (exit-boxes :accessor exit-boxes :initarg :exit-boxes + :initform +default-exit-boxes+) (last-pass :accessor last-pass :initform nil :documentation "Flag that indicates the last pass through the body of ACCEPTING-VALUES, after the user has chosen to exit. This controls when conditions will be signalled from calls to ACCEPT."))) (defmethod stream-default-view ((stream accepting-values-stream)) - +textual-dialog-view+) + (frame-manager-dialog-view (frame-manager *application-frame*))) (define-condition av-exit (condition) ()) +;;; According to <19920824220337.9.SWM@SUMMER.SCRC.Symbolics.COM> this +;;; default ought to be accessed (frame-manager-default-exit-boxes +;;; MANAGER) and (frame-manager-exit-box-labels MANAGER FRAME VIEW), +;;; but those are undocumented CLIM internals so this works for now +(defvar +default-exit-boxes+ '((:exit "Ok") + (:abort "Cancel"))) + ;;; The accepting-values state machine is controlled by commands. Each ;;; action (e.g., "select a text field") terminates @@ -158,7 +167,7 @@ align-prompts label scroll-bars x-position y-position width height command-table frame-class) &body body) - (declare (ignorable exit-boxes initially-select-query-identifier + (declare (ignorable initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts scroll-bars x-position y-position width height command-table frame-class)) @@ -181,6 +190,13 @@ ,true-form ,return-form)))))) +(defgeneric finally-finalize-query-record (record) + (:documentation "Clean up output record after the final run of an + accepting-values body")) + +(defmethod finally-finalize-query-record (record) + nil) + (defun invoke-accepting-values (stream body &key own-window exit-boxes @@ -190,7 +206,7 @@ x-position y-position width height (command-table 'accept-values) (frame-class 'accept-values)) - (declare (ignore own-window exit-boxes modify-initial-query + (declare (ignore own-window modify-initial-query resize-frame label scroll-bars x-position y-position width height frame-class)) (when (and align-prompts ;; t means the same as :right @@ -200,6 +216,7 @@ (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream :stream stream + :exit-boxes (or exit-boxes +default-exit-boxes+) :align-prompts align-prompts)) (arecord (updating-output (stream :record-type 'accepting-values-record) @@ -241,7 +258,7 @@ (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) (dolist (query (queries *accepting-values-stream*)) - (finalize (editing-stream (record query)) nil)) + (finally-finalize-query-record (record query))) (erase-output-record arecord stream) (setf (stream-cursor-position stream) (values cx cy))))))) @@ -254,11 +271,13 @@ (fresh-line stream) (with-output-as-presentation (stream nil 'exit-button) - (format stream "OK")) + (format stream + (second (assoc :exit (exit-boxes *accepting-values-stream*))))) (write-char #\space stream) (with-output-as-presentation (stream nil 'abort-button) - (format stream "Cancel")) + (format stream + (second (assoc :abort (exit-boxes *accepting-values-stream*))))) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type @@ -423,25 +442,10 @@ :documentation "A copy of the stream buffer before accept is called. Used to determine if any editing has been done by user"))) -(defparameter *no-default-cache-value* (cons nil nil)) +(defmethod finally-finalize-query-record ((record av-text-record)) + (finalize (editing-stream record) nil)) -;;; Hack until more views / dialog gadgets are defined. - -(define-default-presentation-method accept-present-default - (type stream (view text-field-view) default default-supplied-p - present-p query-identifier) - (if (width view) - (multiple-value-bind (cx cy) - (stream-cursor-position stream) - (declare (ignore cy)) - (letf (((stream-text-margin stream) (+ cx (width view)))) - (funcall-presentation-generic-function accept-present-default - type - stream - +textual-dialog-view+ - default default-supplied-p - present-p - query-identifier))))) +(defparameter *no-default-cache-value* (cons nil nil)) (define-default-presentation-method accept-present-default (type stream (view textual-dialog-view) default default-supplied-p Index: encapsulate.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/encapsulate.lisp,v retrieving revision 1.20 diff -u -r1.20 encapsulate.lisp --- encapsulate.lisp 13 Jun 2006 02:00:31 -0000 1.20 +++ encapsulate.lisp 13 May 2008 17:36:31 -0000 @@ -657,7 +657,9 @@ constructor initargs)) - +;;; Incremental Redisplay + + ;;; Presentation type generics Index: package.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v retrieving revision 1.69 diff -u -r1.69 package.lisp --- package.lisp 1 May 2008 06:48:23 -0000 1.69 +++ package.lisp 13 May 2008 17:36:32 -0000 @@ -385,6 +385,7 @@ #:+background-ink+ ;constant #:+black+ ;constant #:+blue+ ;constant + #:+check-box-view+ ;constant #:+control-key+ ;constant #:+cyan+ ;constant #:+everywhere+ ;constant @@ -397,19 +398,27 @@ #:+green+ ;constant #:+hyper-key+ ;constant #:+identity-transformation+ ;constant + #:+list-pane-view+ ;constant #:+magenta+ ;constant #:+meta-key+ ;constant #:+nowhere+ ;constant + #:+option-pane-view+ ;constant #:+pointer-documentation-view+ ;constant #:+pointer-left-button+ ;constant #:+pointer-middle-button+ ;constant #:+pointer-right-button+ ;constant + #:+push-button-view+ ;constant #:+red+ ;constant + #:+radio-box-view+ ;constant #:+shift-key+ ;constant + #:+slider-view+ ;constant #:+super-key+ ;constant + #:+text-editor-view+ ;constant + #:+text-field-view+ ;constant #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant + #:+toggle-button-view+ ;constant #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant @@ -496,6 +505,7 @@ #:check-box-current-selection ;generic function #:check-box-pane ;class #:check-box-selections ;generic function + #:check-box-view ;class #:child-containing-position ;generic function #:children-overlapping-rectangle* ;generic function #:children-overlapping-region ;generic function @@ -733,6 +743,7 @@ #:frame-maintain-presentation-histories ;generic function #:frame-manager ;protocol class #:frame-manager ;generic function + #:frame-manager-dialog-view ;generic function #:frame-manager-frames ;generic function #:frame-manager-menu-choose ;generic function #:frame-manager-notify-user ;generic function @@ -868,6 +879,7 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class + #:list-pane-view ;class #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1034,6 +1046,7 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class + #:option-pane-view ;class #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1158,6 +1171,7 @@ #:push-button ;class #:push-button-pane ;class #:push-button-show-as-default ;generic function + #:push-button-view ;class #:queue-event ;generic function #:queue-repaint ;generic function #:queue-rescan ;generic function @@ -1165,6 +1179,7 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function + #:radio-box-view ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1303,6 +1318,7 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class + #:slider-view ;class #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1454,8 +1470,10 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class + #:text-editor-view ;class #:text-field ;class #:text-field-pane ;class + #:text-field-view ;class #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function @@ -1478,6 +1496,7 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class + #:toggle-button-view ;class #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function Index: protocol-classes.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/protocol-classes.lisp,v retrieving revision 1.4 diff -u -r1.4 protocol-classes.lisp --- protocol-classes.lisp 29 Oct 2006 12:56:13 -0000 1.4 +++ protocol-classes.lisp 13 May 2008 17:36:32 -0000 @@ -191,7 +191,9 @@ ((port :initarg :port :reader frame-manager-port) (frames :initform nil - :reader frame-manager-frames))) + :reader frame-manager-frames) + (dialog-view :initform +textual-dialog-view+ + :accessor frame-manager-dialog-view))) ;;; 30.3 Basic Gadget Classes ;;; XXX Slots definitions should be banished. Index: views.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/views.lisp,v retrieving revision 1.8 diff -u -r1.8 views.lisp --- views.lisp 12 Jan 2008 11:04:05 -0000 1.8 +++ views.lisp 13 May 2008 17:36:32 -0000 @@ -31,7 +31,7 @@ ()) (defclass gadget-view (view) - ()) + ((gadget-initargs :initform nil :reader view-gadget-initargs))) (defclass gadget-menu-view (gadget-view) ()) @@ -59,10 +59,10 @@ (defclass slider-view (gadget-view) ()) -(defclass text-field-view (gadget-dialog-view) +(defclass text-field-view (gadget-view) ((width :accessor width :initarg :width :initform nil))) -(defclass text-editor-view (gadget-view) +(defclass text-editor-view () ()) (defclass list-pane-view (gadget-view) @@ -91,6 +91,8 @@ (defparameter +radio-box-view+ (make-instance 'radio-box-view)) +(defparameter +check-box-view+ (make-instance 'check-box-view)) + (defparameter +slider-view+ (make-instance 'slider-view)) (defparameter +text-field-view+ (make-instance 'text-field-view)) @@ -105,3 +107,6 @@ (declare (ignore stream)) +textual-view+) +(defmethod initialize-instance :after ((view gadget-view) &rest initargs + &key &allow-other-keys) + (setf (slot-value view 'gadget-initargs) initargs))