blob: b5673c874ae4a5c7fd9f6ad0094e57bf83453e76 (
plain)
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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
;;; ---------------------------------------------------------------------------
;;; License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 1998-2001 by Michael McDonald <mikemac@mikemac.com>
;;; (c) copyright 2000 by Iban Hatchondo <hatchond@emi.u-bordeaux.fr>
;;; (c) copyright 2000 by Julien Boninfante <boninfan@emi.u-bordeaux.fr>
;;; (c) copyright 2001 by Lionel Salabartan <salabart@emi.u-bordeaux.fr>
;;; (c) copyright 2001 by Arnaud Rouanet <rouanet@emi.u-bordeaux.fr>
;;; (c) copyright 2001-2002, 2014 by Robert Strandh <robert.strandh@gmail.com>
;;; (c) copyright 2002-2003 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; (c) copyright 2020 by Daniel Kochmański <daniel@turtleware.eu>
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Implementation of the 29.2 Basic Pane Construction protocol.
;;;
(in-package #:clim-internals)
;; For each of the builtin CLIM gadgets there is an abstract gadget class and
;; at least one "concrete" subclass which can be chosen by the frame
;; manager. The CLIM 2.0 spec names one concrete class for each abstract
;; class. Frame managers need a mechanism to look up these concrete
;; classes. The current practice of the CLX backend is to search for classes
;; of various names based on the name of the abstract class. This mostly works
;; as all but two of the specified concrete class names can be produced by
;; appending "-PANE" to the abstract class name. The classes GENERIC-LIST-PANE
;; and GENERIC-OPTION-PANE break this convention.
;; I've extended the CLX frame manager to additionally search the property
;; list of the pane class name when searching for a concrete pane class. The
;; function below can be used where needed to place the concrete class name
;; where it needs to go.
;; This could be easily extended to allow mappings for specific backends..
(defun define-abstract-pane-mapping (abstract-class-name concrete-class-name)
(setf (get abstract-class-name 'concrete-pane-class-name)
concrete-class-name))
(defgeneric find-concrete-pane-class (pane-realizer pane-type &optional errorp)
(:documentation "Resolves abstract pane type PANE-TYPE to a concrete
pane class. Methods defined in backends should specialize on the
PANE-REALIZER argument. When the PANE-TYPE can't be resolved NIL is
returned or error is signaled depending on the argument ERRORP.")
(:method ((realizer t) pane-type &optional (errorp t))
;; Default method tries to resolve the abstract pane type
;; PANE-TYPE as specified by a convention mentioned in the
;; spec. Function is a little complicated because we preserve old
;; semantics adding rules to the class name resolution. Resolution
;; works as follows:
;;
;; 1. Abstract mapping always takes a priority. When it exists we
;; don't look further.
;; 2. When the symbol is in clim/climi/keyword package:
;; - look for a class `climi::{SYMBOL-NAME}-pane'
;; - look for a class `climi::{SYMBOL-NAME}'
;; 3. Otherwise find a class named by the symbol.
(check-type pane-type symbol)
(flet ((try-mapped (symbol)
(when-let ((mapped (get symbol 'concrete-pane-class-name)))
(return-from find-concrete-pane-class
(find-class mapped errorp)))))
(try-mapped pane-type)
(if (let ((symbol-package (symbol-package pane-type)))
(or (eql symbol-package (find-package '#:clim))
(eql symbol-package (find-package '#:climi))
(eql symbol-package (find-package '#:keyword))))
(let* ((symbol-name (symbol-name pane-type))
(clim-symbol (find-symbol symbol-name '#:climi)))
(try-mapped clim-symbol)
(let* ((proper-name (concatenate 'string symbol-name (string '#:-pane)))
(proper-symbol (find-symbol proper-name '#:climi)))
(try-mapped proper-symbol)
(or (and proper-symbol (find-class proper-symbol nil))
(and clim-symbol (find-class clim-symbol nil))
(when errorp
(error "Concrete class for a pane ~s not found." pane-type)))))
(find-class pane-type errorp)))))
(defvar *pane-realizer* nil)
(defun make-pane (type &rest args)
(apply #'make-pane-1 (or *pane-realizer*
(frame-manager *application-frame*))
*application-frame* type args))
(defconstant +clim-pane-wrapper-initargs+
'(:label :label-alignment :scroll-bars :borders))
(defconstant +space-requirement-initargs+
'(:width :min-width :max-width :height :min-height :max-height))
(defun separate-clim-pane-initargs (initargs)
;; If all wrapper initargs are _not_ a cons then the user space requirement
;; options belong to the outermost container of the stream. Otherwise the
;; user space requirement options belong to the inner pane and it is
;; possible to set space requirements of containers using the cdr of the
;; value, for example :SCROLL-BARS '(:VERTICAL 300). -- jd 2023-02-03
(loop with any-wrapper-p = nil
with complex-size-p = nil
for (key value) on initargs by #'cddr
if (and (member key +space-requirement-initargs+ :test #'eq)
(not (eq value :compute)))
nconc (list key value) into space-options
else if (member key +clim-pane-wrapper-initargs+)
nconc (list key value) into wrapper-options
and do (when (member key '(:borders :label :scroll-bars))
(when value
(setf any-wrapper-p t))
(when (consp value)
(setf complex-size-p t)))
else
nconc (list key value) into pane-options
finally
(return
(if (or (not any-wrapper-p) complex-size-p)
(values (append pane-options space-options) wrapper-options '())
(values pane-options wrapper-options space-options)))))
;;; Default is "no wrapper".
(defun wrap-clim-pane (wrapped-pane user-space-requirements
&key borders
label
(label-alignment :top)
scroll-bars)
(let ((pane wrapped-pane))
(when scroll-bars
(setf pane (make-pane 'viewport-pane :contents (list pane)))
(setf pane (apply #'make-pane 'scroller-pane
:contents (list pane)
(append
;; From the Franz manual if :scroll-bars is a cons the
;; car is treated as the non-cons argument and the cdr
;; is a list of keyword argument pairs to be used as
;; options of the scroller-pane.
(if (consp scroll-bars)
`(:scroll-bars ,@scroll-bars)
`(:scroll-bars ,scroll-bars))
(when (and user-space-requirements
(not (or label borders)))
user-space-requirements)))))
(when label
(setf pane (apply #'make-pane 'label-pane
:contents (list pane)
(append
(if (consp label)
`(:label ,@label :label-alignment ,label-alignment)
`(:label ,label :label-alignment ,label-alignment))
(when (and user-space-requirements (not borders))
user-space-requirements)))))
(when borders
(setf pane (apply #'make-pane 'outlined-pane
:contents (list pane)
(append
(if (consp borders)
`(:thickness ,@borders)
`(:thickness ,(if (numberp borders) borders 1)))
user-space-requirements))))
(values pane wrapped-pane)))
(defun make-clim-pane (type &rest options)
(multiple-value-bind (pane-options wrapper-options wrapper-space-options)
(separate-clim-pane-initargs options)
(let ((pane (apply #'make-pane type pane-options)))
(apply #'wrap-clim-pane pane wrapper-space-options wrapper-options))))
(defmethod medium-foreground ((pane pane))
(medium-foreground (sheet-medium pane)))
(defmethod (setf medium-foreground) (ink (pane pane))
(setf (medium-foreground (sheet-medium pane)) ink))
(defmethod medium-background ((pane pane))
(medium-background (sheet-medium pane)))
(defmethod (setf medium-background) (ink (pane pane))
(setf (medium-background (sheet-medium pane)) ink))
(defmethod compose-space ((pane pane) &key (width 100) (height 100))
(make-space-requirement :width width :height height))
(defmethod allocate-space ((pane pane) width height)
(resize-sheet pane width height))
(defmethod pane-needs-redisplay ((pane pane))
(let ((do-redisplay (pane-redisplay-needed pane)))
(values do-redisplay
(and do-redisplay (not (eq do-redisplay :no-clear))))))
(defmethod (setf pane-needs-redisplay) (value (pane pane))
(setf (pane-redisplay-needed pane) value))
(defmethod window-clear ((pane pane))
nil)
(defclass basic-pane (standard-space-requirement-options-mixin
sheet-parent-mixin ;mirrored-sheet-mixin
;; UX mixins
always-repaint-background-mixin
mouse-wheel-scroll-mixin
permanent-medium-sheet-output-mixin
immediate-repainting-mixin
standard-sheet-input-mixin
sheet-transformation-mixin
layout-protocol-mixin
pane
basic-sheet)
((name :initarg :name
:reader pane-name
:initform nil)
;; Context
(port :initarg :port)
(manager :initarg :manager)
(frame :initarg :frame
:initform *application-frame*
:reader pane-frame)
;; Drawing defaults
(foreground :initarg :foreground
:reader pane-foreground
:reader foreground)
(background :initarg :background
:accessor pane-background
:reader background)
(text-style :initarg :text-style
:reader pane-text-style
:type text-style)
;; Display state
(redisplay-needed :accessor pane-redisplay-needed
:initarg :redisplay-needed :initform nil))
(:default-initargs
:foreground +black+
:background *3d-normal-color*
:text-style *default-text-style*))
;;; XXX this is for code ported from other CLIM implementations that seem to
;;; allow text-style being passed as a cons. -- jd 2022-09-16
(defmethod initialize-instance :before ((obj basic-pane) &key text-style)
(check-type text-style text-style))
(defmethod print-object ((object basic-pane) stream)
(print-unreadable-object (object stream :type t :identity t)
(prin1 (pane-name object) stream)))
(defmethod engraft-medium :after (medium port (pane basic-pane))
(declare (ignore port))
;; implements 29.2.2, last sentence.
(setf (medium-foreground medium) (pane-foreground pane)
(medium-background medium) (pane-background pane)
(medium-text-style medium) (pane-text-style pane)))
(defmethod handle-event ((sheet basic-pane) (event window-map-event))
(setf (sheet-enabled-p sheet) t))
(defmethod handle-event ((sheet basic-pane) (event window-unmap-event))
(setf (sheet-enabled-p sheet) nil))
(defmethod handle-repaint :around ((sheet basic-pane) region)
(letf (((medium-background sheet) (pane-background sheet))
((medium-foreground sheet) (pane-foreground sheet)))
(call-next-method)))
|
