Newer
Older
;; Moves the sheet to be near where the pointer is. It's safest to use this
;; on a top-level sheet.
(defun position-sheet-near-pointer (sheet &optional x y)
(unless (and x y)
(multiple-value-setq (x y)
(pointer-position (port-pointer (port sheet)))))
(defun display-title (frame stream &key max-width max-height)
(declare (ignore max-width max-height))
(with-slots (display-string) stream
(let ((title display-string))
(when (and (stringp title)
(not (string-equal title (frame-pretty-name frame))))
;; On some hosts this will update the title bar
(setf (frame-pretty-name frame) title))
(window-inside-size stream)
(draw-text* stream (or title (frame-pretty-name frame))
(/ width 2) (/ height 2)
:align-x :center :align-y :center)))))
(defun title-capitalize (string)
(let ((new-string (substitute #\Space #\- string)))
(when (eq new-string string)
(setq new-string (copy-seq new-string)))
(nstring-capitalize new-string)))
&key command-table max-width max-height &allow-other-keys)
(ignore max-width max-height))
(eq command-table t))
(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))
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
(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?
)
;;; This is the wrong modularity... Bury calls in commands for acl case later.
;;;-- pr Aug97
(defmacro with-menu-disabled (frame &body body)
#+(or aclpc acl86win32)
`(unwind-protect
(progn (enable-menu-items ,frame nil) ,@body)
(progn
(enable-menu-items ,frame t)
(setq *frame* ,frame)))
#-acl86win32 `(progn ,@body))
#+(or aclpc acl86win32)
(defmethod execute-frame-command ((frame standard-application-frame) command)
(with-menu-disabled frame ;; pr Aug97
(apply (command-name command) (command-arguments command))))
#-(or aclpc acl86win32)
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command)))
(defmethod execute-frame-command :around ((frame standard-application-frame) command)
activity)
(if #+(or aclpc acl86win32) (not *multiprocessing-p*)
#-(or aclpc acl86win32) nil
(call-next-method) ; treat single proc as top-level-process
(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)
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
(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)
#+(or aclpc acl86win32); unqualified first
(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)
#-aclpc (declare (ignore input-context x y))
(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))
#-(or aclpc acl86win32)
(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-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")))
(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)
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
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
1651
1652
(*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 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
(let ((bit #o20)
(shift-name '(:hyper :super :meta :control :shift)))
(declare (type fixnum bit))
(repeat 5 ;length of shift-name
(unless (zerop (logand bit modifier-state))
(write-string
(frame-modifier-key-documentation frame
(car shift-name))
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
:documentation-type :pointer)
(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)))))
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
(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)))