Newer
Older
(apply #'display-command-menu-1 stream command-table keys)
(apply #'display-command-table-menu command-table stream keys))))
;; Split out to avoid consing unnecessary closure environments.
(defun display-command-menu-1 (stream command-table &rest keys)
(declare (dynamic-extent keys))
(updating-output (stream :unique-id stream
:cache-value (slot-value command-table 'menu-tick))
(apply #'display-command-table-menu command-table stream keys)))
(defmethod find-pane-named ((frame standard-application-frame) pane-name &optional (errorp t))
(with-slots (all-panes) frame
(cond ((second (assoc pane-name all-panes)))
(errorp (error "There is no pane named ~S in frame ~S" pane-name frame)))))
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
(with-slots (all-panes) frame
(let ((pane (assoc pane-name all-panes)))
(when pane
(map-over-sheets #'(lambda (sheet)
(when (typep sheet 'clim-stream-pane)
(return-from get-frame-pane sheet)))
(second pane)))
(error "There is no CLIM stream pane named ~S in frame ~S" pane-name frame)))))
#+ignore
(defmethod pane-name ((pane basic-pane))
(let ((frame (pane-frame pane)))
(and frame
(dolist (name-and-pane (slot-value frame 'all-panes))
(destructuring-bind (name apane) name-and-pane
(when (sheet-ancestor-p pane apane)
(return name)))))))
(defmethod frame-current-panes ((frame standard-application-frame))
(let ((panes nil)
(top (frame-panes frame)))
(when (panep sheet)
(push sheet panes)))
top))
(defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p)
;; First display all the :accept-values panes, then display the rest.
;; We do this to ensure that all side-effects from :accept-values panes
;; have taken place.
#+moved ;; pr Aug97
(when *frame-layout-changing-p* (setq force-p t))
(when (typep sheet 'accept-values-pane)
(redisplay-frame-pane frame sheet :force-p force-p)))
(frame-top-level-sheet frame))
(when (and (typep sheet 'clim-stream-pane)
(not (typep sheet 'accept-values-pane)))
(redisplay-frame-pane frame sheet :force-p force-p)))
(frame-top-level-sheet frame))
;; Once we've redisplayed everything, the layout is done changing
(setq *frame-layout-changing-p* nil))
(defmethod redisplay-frame-pane ((frame standard-application-frame) pane &key force-p)
(ir (slot-value pane 'incremental-redisplay-p))
(redisplay-p (if (listp ir) (first ir) ir))
(check-overlapping (or (atom ir) ;default is T
(getf (rest ir) :check-overlapping
t)))
needs-display
clear)
(with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
(with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
#-moved ;; pr Aug97
(when *frame-layout-changing-p*
(setq force-p t))
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
(unless *sizing-application-frame*
(unless (member pane (slot-value frame 'initialized-panes))
(setq force-p t)
(push pane (slot-value frame 'initialized-panes))))
(return
(cond (display-function
(cond
;; display function with incremental redisplay
(redisplay-p
(let ((redisplay-record
(let ((history (stream-output-history pane)))
(when history
#+compulsive-redisplay
(when (> (output-record-count history :fastp t) 1)
(cerror "Clear the output history and proceed"
"There is more than one element in this redisplay pane")
(window-clear pane))
(unless (zerop (output-record-count history :fastp t))
(output-record-element history 0))))))
(cond ((or (null redisplay-record) force-p)
(when force-p
(window-clear pane))
(invoke-pane-redisplay-function frame pane))
(t
(redisplay redisplay-record pane
:check-overlapping check-overlapping)))))
;; display function without incremental redisplay
((or force-p (progn (multiple-value-setq (needs-display clear)
(pane-needs-redisplay pane))
needs-display))
(when (or force-p clear)
(window-clear pane))
(invoke-pane-display-function frame pane)))
(force-output pane))
;; no display function
(force-p
;; If refilling from scratch, give the application a chance
;; to draw stuff
(frame-replay frame pane))
;; Otherwise do nothing, the bits will still be on display
;; and will be refreshed properly if there's a damage event.
)))))))
(defun invoke-pane-redisplay-function (frame pane &rest args)
(declare (dynamic-extent args))
(updating-output (pane)
(apply #'invoke-pane-display-function frame pane args)))
(defun invoke-pane-display-function (frame pane &rest args)
(declare (dynamic-extent args))
(let* ((df (pane-display-function pane))
(display-args (if (listp df) (rest df) nil))
(display-function (if (listp df) (first df) df)))
;; Cons as little as possible...
(cond ((and (null args) (null display-args))
(funcall display-function frame pane))
((null display-args)
(apply display-function frame pane args))
((null args)
(apply display-function frame pane display-args))
(t
(apply display-function frame pane (append args display-args))))))
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
(when (null region)
(setq region (or (pane-viewport-region stream) (sheet-region stream))))
(defmethod read-frame-command ((frame standard-application-frame)
&key (stream *standard-input*) ;--- FRAME-STANDARD-INPUT?
;; should the rest of the *command-parser*
;; etc. variables be passed as keywords or bound?
)
(defmacro with-menu-disabled (frame &body body)
#-mswindows (declare (ignore frame))
#-mswindows `(progn ,@body)
`(unwind-protect
(progn
(disable-all-menu-items ,frame)
,@body)
(re-enable-menu-items ,frame)))
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command))
#+ignore ;; from jeff on 4/8/99
(with-menu-disabled frame
(apply (command-name command) (command-arguments command))))
(defmethod execute-frame-command :around ((frame standard-application-frame)
command)
activity)
(if (or (and top-level-process
(eq top-level-process (current-process)))
(and (typep frame 'activity-frame)
(setq activity (frame-activity frame))
(eq (slot-value activity 'top-level-process)
(current-process))))
;; If we're in the process for the frame, just execute the command
;; Or the process for the frames activity
(call-next-method)
;; Otherwise arrange to run the command in the frame's process
(execute-command-in-frame frame command :queuep t))))
cer
committed
(defmethod command-defined-p ((frame standard-application-frame) command)
(or (not (symbolp command))
(fboundp command)))
(defmethod command-enabled (command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(or *assume-all-commands-enabled*
(and (command-defined-p frame command-name)
(not (member command-name disabled-commands))
(command-accessible-in-command-table-p
command-name (frame-command-table frame))))))
(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(cond (enabled
(setf disabled-commands (delete command-name disabled-commands))
(note-command-enabled (frame-manager frame) frame command-name))
(t
(push command-name disabled-commands)
(note-command-disabled (frame-manager frame) frame command-name)))))
;;--- There is the compiler bug with (eval-when (compile load eval) ...)
;;--- DEFMETHOD with a CALL-NEXT-METHOD. See to incorporate this patch.
(eval-when (#-Allegro compile load eval)
((command :initarg :command :reader synchronous-command-event-command)
(echo :initarg :echo :reader synchronous-command-event-echo-p))
(format stream "Command event condition signalled for ~S"
(synchronous-command-event-command condition)))))
) ;eval-when
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
(flet ((maybe-echo-command (command)
(let ((ptype `(command :command-table ,(frame-command-table frame))))
(when (eq *command-parser* #'command-line-command-parser)
(present command ptype :stream *standard-input* :allow-sensitive-inferiors nil))
(when (frame-maintain-presentation-histories frame)
(push-history-element (presentation-type-history ptype)
(make-presentation-history-element :object command :type ptype))))))
(let* ((command-and-options (queue-pop (frame-command-queue frame))))
(if command-and-options
(destructuring-bind (command &key echo) command-and-options
(when echo (maybe-echo-command command))
command)
(handler-bind ((synchronous-command-event
#'(lambda (c)
(let ((command (synchronous-command-event-command c)))
(when (synchronous-command-event-echo-p c)
(maybe-echo-command command))
(return-from read-frame-command command)))))
(let ((*reading-frame-command* t))
(call-next-method)))))))
((value :initarg :value :reader presentation-event-value)
(sheet :initarg :sheet :reader event-sheet)
(frame :initarg :frame :reader event-frame)
(queuep :initarg :queuep :initform nil)
(echo :initarg :echo :initform t :reader presentation-event-echo-p)
(presentation-type :initarg :presentation-type :reader event-presentation-type))
(defmethod handle-event (sheet (event presentation-event))
(process-command-event sheet event))
;;;#+(or aclpc acl86win32)
;;;(eval-when (compile load eval)
;;; ;;mm: 11Jan95 - this is defined later in ???
;;; (unless (ignore-errors (find-class 'activity-frame))
;;; (defclass activity-frame () ())))
(defun process-command-event (sheet event)
;;--- This code is as bad as I feel.
(let ((command (presentation-event-value event)))
(if (partial-command-p command)
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
(throw-highlighted-presentation
(make-instance 'standard-presentation
:object command
:type (event-presentation-type event))
*input-context*
(allocate-event 'pointer-button-press-event
:sheet sheet
:x 0 :y 0
:modifier-state 0
:button +pointer-left-button+))
(let ((frame (event-frame event))
(activity nil))
(when (and *input-buffer-empty*
(or (eq *application-frame* frame)
(and (typep frame 'activity-frame)
(eq (frame-activity frame) *activity*)
(setq activity *activity*))))
(signal 'synchronous-command-event
:echo (presentation-event-echo-p event)
:command command))
;; Perhaps if this results directly from a user action then either
;; we should do it right away, ie. lose the input buffer or beep if
;; it has to be deferred,
(if (slot-value event 'queuep)
(queue-frame-command (if activity (activity-active-frame activity) frame)
(presentation-event-value event)
(presentation-event-echo-p event))
(beep sheet))))))
(defun command-callback (function &rest arguments)
(cons #'(lambda (widget &rest args) (apply #'command-callback-1 function widget args)) arguments))
(defun command-callback-1 (function sheet &rest arguments)
(let ((frame (pane-frame sheet)))
(process-command-event
sheet
(make-instance 'presentation-event
:frame frame
:value (list* function sheet arguments)
:presentation-type `(command :command-table ,(frame-command-table frame))))))
(defun queue-frame-command (frame command &optional (echo t))
(queue-push (frame-command-queue frame) (list command :echo echo)))
(defmethod execute-command-in-frame
((frame standard-application-frame) command &rest initargs)
(apply #'allocate-event 'presentation-event
:frame frame
:sheet (frame-top-level-sheet frame)
:value command
initargs)))
(defun make-command-timer (frame command
&key (delay 0) interval
(command-table (frame-command-table frame)))
(declare (ignore timer))
(execute-command-in-frame
frame command
:echo nil
:queuep t
:presentation-type `(command :command-table ,command-table))))
:function #'queue-command-event
:delay delay :interval interval)))
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE. Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
((frame standard-application-frame) input-context stream x y &key event)
(find-innermost-applicable-presentation
input-context stream x y
:frame frame
:modifier-state (window-modifier-state stream) :event event))
((frame standard-application-frame) stream button-press-event)
(declare (ignore stream))
(let* ((window (event-sheet button-press-event))
(x (pointer-event-x button-press-event))
(y (pointer-event-y button-press-event))
(highlighted-presentation (highlighted-presentation window nil))
(input-context *input-context*))
(output-recording-stream-p window)
(not (region-contains-position-p (stream-output-history window) x y)))
(funcall *click-outside-menu-handler*))
(when highlighted-presentation
;; Unhighlight on the way out.
;; But only unhighlight the window that the click is from.
(throw-highlighted-presentation
(frame-find-innermost-applicable-presentation
frame input-context window x y
:event button-press-event))
*null-presentation*)
input-context
button-press-event)))
(defun find-frame-pane-of-type (frame type)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defmethod frame-standard-output ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane)))
(defmethod frame-standard-input ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame)))
(defmethod frame-error-output ((frame standard-application-frame))
(frame-standard-output frame))
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories. Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(defmethod notify-user (frame message &rest options)
(declare (dynamic-extent options))
(when frame
(setf (getf options :frame) frame))
(apply #'frame-manager-notify-user
(if frame (frame-manager frame) (find-frame-manager)) message options))
(defmethod select-file (frame &rest options)
(declare (dynamic-extent options))
(when frame
(setf (getf options :frame) frame))
(apply #'frame-manager-select-file
(if frame (frame-manager frame) (find-frame-manager)) options))
#-makes-things-fail 0
#+makes-things-fail
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(setq *pointer-documentation-interval* 0)
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame)
presentation input-context window x y stream)
(let ((frame-manager (frame-manager frame)))
#+(or aclpc acl86win32)
(unless frame-manager
(setq frame (pane-frame window))
(setq frame-manager (or (frame-manager frame)(find-frame-manager))))
(frame-manager-display-pointer-documentation
frame-manager frame presentation input-context window x y stream)))
(defmethod frame-manager-pointer-documentation-stream
((framem standard-frame-manager) frame stream)
(defmethod frame-manager-display-pointer-documentation
((framem standard-frame-manager)
frame presentation input-context window x y stream)
(let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
(when presentation
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(force-output stream)))))))
(defmethod frame-manager-display-pointer-documentation :around
((framem standard-frame-manager)
frame presentation input-context window x y stream)
(declare (ignore x y input-context))
(when (frame-manager-pointer-documentation-stream framem frame stream)
;; The documentation should never say anything if we're not over a presentation
(frame-manager-display-pointer-documentation-string
framem frame stream nil))
;; Cheap test to not do this work too often
(let ((old-modifier-state *last-pointer-documentation-modifier-state*)
(modifier-state (window-modifier-state window))
(last-time *last-pointer-documentation-time*)
(time (get-internal-real-time)))
(setq *last-pointer-documentation-modifier-state* modifier-state)
(when (and (< time (+ last-time *pointer-documentation-interval*))
(= modifier-state old-modifier-state))
(defmethod frame-manager-display-pointer-documentation-string
((framem standard-frame-manager) frame stream string)
(let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
(when stream
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when string
(write-string string stream))))))))
(defmethod frame-pointer-button-documentation
((frame standard-application-frame) button)
(case button
(:left "L")
(:middle "M")
(:right "R")))
(defmethod frame-modifier-key-documentation
((frame standard-application-frame) modifier)
(case modifier
(:shift "sh")
(:control "c")
(:meta "m")
(:super "s")
(:hyper "h")
(:double "dbl")))
(defun frame-document-highlighted-presentation-1
(frame presentation input-context window x y stream)
(let ((modifier-state (window-modifier-state window)))
(multiple-value-bind (left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)
(find-applicable-translators-for-documentation presentation
input-context
frame window x y
modifier-state)
(*print-level* 2)
(*print-circle* nil)
(*print-array* nil)
(*print-readably* nil)
(*print-pretty* nil))
(flet ((document-translator (translator presentation context-type
button-names separator)
;; Assumes 6 modifier keys and the reverse ordering of
*MODIFIER-KEYS*
(let ((bit #b100000)
(shift-name '(:double :hyper :super :meta :control
:shift)))
(declare (type fixnum bit))
(repeat 6 ;length of shift-name
(unless (zerop (logand bit modifier-state))
(write-string
(frame-modifier-key-documentation frame
stream)
(write-string "-" stream))
(pop shift-name)
(setq bit (the fixnum (ash bit -1)))))
(write-string
(frame-pointer-button-documentation frame (car
button-names))
stream)
(dolist (button-name (cdr button-names))
(write-string "," stream)
(write-string
(frame-pointer-button-documentation frame button-name)
stream))
(write-string ": " stream)
(document-presentation-translator translator presentation
context-type
frame nil window x y
:stream stream
(write-string separator stream)))
(declare (dynamic-extent #'document-translator))
;;--- The button names should be hard-wired in. Consider 1-button
;;--- Macs and 2-button PCs...
(when left
(let ((button-name (cond ((and (eq left middle)
(eq left right))
(setq middle nil
right nil)
'(:left :middle :right))
((eq left middle)
(setq middle nil)
'(:left :middle))
(t '(:left)))))
(document-translator left left-presentation left-context
button-name (if (or middle right) "; "
"."))))
(when middle
(let ((button-name (cond ((eq middle right)
(setq right nil)
(list :middle :right))
(t '(:middle)))))
(document-translator middle middle-presentation middle-context
button-name (if right "; " "."))))
(when right
(document-translator right right-presentation right-context
'(:right) "."))
;; Return non-NIL if any pointer documentation was produced
(or left middle right))))))
;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
(presentation input-context frame window x y modifier-state)
;; Assume a maximum of three pointer buttons
(let ((left nil) (left-presentation nil) (left-context nil)
(middle nil) (middle-presentation nil) (middle-context nil)
(right nil) (right-presentation nil) (right-context nil))
(macrolet ((match (translator presentation context-type button)
(let* ((symbol (symbol-name button))
(button-translator (intern symbol))
(button-presentation (fintern "~A-~A" symbol 'presentation))
(button-context (fintern "~A-~A" symbol 'context)))
`(when (and (null ,button-translator)
(button-and-modifier-state-matches-gesture-name-p
(button-index ,button) modifier-state
(presentation-translator-gesture-name ,translator)))
(setq ,button-translator ,translator
,button-presentation ,presentation
,button-context ,context-type)))))
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
(parent-presentation-with-shared-box presentation window)))
((null presentation))
(let ((from-type (presentation-type presentation)))
(dolist (context input-context)
(let ((context-type (pop context))) ;input-context-type = first
(let ((translators (find-presentation-translators
from-type context-type (frame-command-table frame))))
(when translators
(dolist (translator translators)
(when (test-presentation-translator translator
presentation context-type
frame window x y
:modifier-state modifier-state)
(match translator presentation context-type :left)
(match translator presentation context-type :middle)
(match translator presentation context-type :right)))))
(when (and (or left middle right)
*presentation-menu-translator*
(test-presentation-translator *presentation-menu-translator*
presentation context-type
frame window x y
:modifier-state modifier-state))
(match *presentation-menu-translator* presentation context-type :left)
(match *presentation-menu-translator* presentation context-type :middle)
(match *presentation-menu-translator* presentation context-type :right)))))))
middle middle-presentation middle-context
right right-presentation right-context)))