/usr/share/common-lisp/source/mcclim/text-selection.lisp is in cl-mcclim 0.9.6.dfsg.cvs20100315-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIMI; -*-
;;; (c) copyright 2003 by Gilbert Baumann
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Cut and Paste
(in-package :climi)
;;;; Interaction implemented:
;; Shift-Mouse-L down: clear active selection and set the first point
;; Shift-Mouse-L drag: drag the second point
;; Shift-Mouse-L up: set the second point
;; Shift-Mouse-R down: pick the nearest point, if any
;; Shift-Mouse-R drag: drag said point
;; Shift-Mouse-R up: leave said point where it was dragged to.
;; Shift-Mouse-M: paste
;;;; Interaction to implement:
;; Shift-Mouse-L single click: (maybe) select current presentation, if any.
;; Shift-Mouse-L double click: select word
;; Shift-Mouse-L triple click: select "line".
;; TODO:
;; * Editor input (both active and old) is not currently highlighted.
;; * Selecting large regions gets slow.
;; * Structure of line breaks in the original text is not preserved (CLIM/McCLIM design issue)
;;;; Preferences
(defparameter *marking-border* 1)
(defparameter *marked-foreground* +white+
"Foreground ink to use for marked stuff.")
(defparameter *marked-background* +blue4+
"Background ink to use for marked stuff.")
;;;; Text Selection Protocol
(defgeneric release-selection (port &optional time)
(:documentation "Relinquish ownership of the selection."))
(defgeneric request-selection (port requestor time)
(:documentation "Request that the window system retrieve the selection from
its current owner. This should cause a selection-notify-event to be delivered."))
(defgeneric bind-selection (port window &optional time)
(:documentation "Take ownership of the selection."))
(defgeneric send-selection (port request-event string)
(:documentation "Send 'string' to a client in response to a selection-request-event."))
(defgeneric get-selection-from-event (port event)
(:documentation "Given a selection-notify event, return a string containing
the incoming selection."))
;; These events are probably very X11 specific.
;; Backends will likely produce subclasses of selection-notify-event
;; and selection-request-event.
(defclass selection-event (window-event)
((selection :initarg :selection
:reader selection-event-selection)))
(defclass selection-clear-event (selection-event) ())
(defclass selection-notify-event (selection-event) ())
(defclass selection-request-event (selection-event)
((requestor :initarg :requestor :reader selection-event-requestor)))
;;;; Random Notes
;; - McCLIM still has absolutely no idea of lines.
(defclass marking ()
()
(:documentation "A common super class for markings (= stuff marked)."))
(defgeneric marking-region (stream marking)
(:documentation "Region marked/affected."))
(defclass string-marking (marking)
((record :initarg :record
:documentation "The text output record this belongs to.")
(styled-string :initarg :styled-string
:documentation "The styled string sub-record of 'record'.")
(start :initarg :start :reader mark-start
:documentation "Start index within string.")
(end :initarg :end :reader mark-end
:documentation "End index within string. Caution: Could be one off the end to indicate a newline implied."))
(:documentation "Some part of a styled-string marked."))
(defmethod marking-region (stream (marking string-marking))
(with-slots (record styled-string start end) marking
(with-slots (baseline start-y) record
(if (= start end)
+nowhere+
(with-slots (start-x string text-style) styled-string
(make-rectangle* (+ start-x
(stream-string-width stream string
:start 0 :end start
:text-style text-style)
(- *marking-border*))
(+ start-y baseline
(- (text-style-ascent text-style stream))
(- *marking-border*))
(+ start-x
(stream-string-width stream string
:start 0 :end end
:text-style text-style)
*marking-border*)
(+ start-y baseline (text-style-descent text-style stream)
*marking-border*)))))))
;(defgeneric draw-marking (medium marking)
; (:documentation "Draw the marking to medium."))
;
;(defmethod draw-marking (stream (marking string-marking))
; (draw-design (sheet-medium stream) (marking-region marking)
; :ink +flipping-ink+))
;;;;
(defclass cut-and-paste-mixin ()
((markings :initform nil)
(point-1-x :initform nil)
(point-1-y :initform nil)
(point-2-x :initform nil)
(point-2-y :initform nil)
(dragging-p :initform nil)))
(defclass paste-as-keypress-mixin ()
()
(:documentation "Implements the old McCLIM behavior of pasting via a
sequence of key press events. You couldn't possibly want this."))
(defmethod handle-repaint :around ((pane cut-and-paste-mixin) region)
(with-slots (markings) pane
(cond ((null markings)
(call-next-method))
(t
(let ((marked-region
(reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) (slot-value pane 'markings))
:initial-value +nowhere+)))
(with-sheet-medium (medium pane)
(let ((R (region-difference region marked-region)))
(with-drawing-options (medium :clipping-region R)
(call-next-method pane R))))
(with-sheet-medium (medium pane)
(let ((R (region-intersection region marked-region)))
(with-drawing-options (medium :clipping-region R)
(letf (((medium-foreground medium) *marked-foreground*)
((medium-background medium) *marked-background*))
(call-next-method pane R))))))))))
(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
(event pointer-button-press-event))
(if (eql (event-modifier-state event) +shift-key+)
(eos/shift-click pane event)
(call-next-method)))
(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
(event pointer-button-release-event))
(if (eql (event-modifier-state event) +shift-key+)
(eos/shift-release pane event)
(call-next-method)))
(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
(event pointer-motion-event))
(with-slots (point-1-x dragging-p) pane
(if (and (eql (event-modifier-state event) +shift-key+))
(when dragging-p (eos/shift-drag pane event))
(call-next-method))))
(defun pane-clear-markings (pane &optional time)
(repaint-markings pane (slot-value pane 'markings)
(setf (slot-value pane 'markings) nil))
(release-selection (port pane) time))
(defmethod eos/shift-click ((pane extended-output-stream) event)
(with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
(cond ((eql +pointer-left-button+ (pointer-event-button event))
(pane-clear-markings pane (event-timestamp event))
;; start dragging, set point-1 where the mouse is
(setf point-1-x (pointer-event-x event))
(setf point-1-y (pointer-event-y event))
(setf dragging-p t))
((eql +pointer-middle-button+ (pointer-event-button event))
;; paste
(request-selection (port pane) #|:UTF8_STRING|# (sheet-direct-mirror pane) (event-timestamp event)))
((eql +pointer-right-button+ (pointer-event-button event))
(when (and point-1-x point-1-y point-2-x point-2-y)
;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around.
(when (< (+ (expt (- (pointer-event-x event) point-1-x) 2)
(expt (- (pointer-event-y event) point-1-y) 2))
(+ (expt (- (pointer-event-x event) point-2-x) 2)
(expt (- (pointer-event-y event) point-2-y) 2)))
(rotatef point-1-x point-2-x)
(rotatef point-1-y point-2-y))
(eos/shift-drag pane event)
(setf dragging-p t)))
(t (describe event)))))
(defmethod eos/shift-release ((pane extended-output-stream) event)
(with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
(when dragging-p
(setf point-2-x (pointer-event-x event)
point-2-y (pointer-event-y event)
dragging-p nil)
;;
(let ((owner (selection-owner (port pane))))
(when (and owner (not (eq owner pane)))
(distribute-event (port pane)
(make-instance 'selection-clear-event
:sheet owner
:selection :primary))))
(when (bind-selection (port pane) pane (event-timestamp event))
(setf (selection-owner (port pane)) pane)
(setf (selection-timestamp (port pane)) (event-timestamp event))))))
(defun repaint-markings (pane old-markings new-markings)
(let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings)
:initial-value +nowhere+))
(new-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) new-markings)
:initial-value +nowhere+)))
(handle-repaint pane (region-exclusive-or old-region new-region))))
(defmethod eos/shift-drag ((pane extended-output-stream) event)
(with-slots (point-1-x point-1-y) pane
(let ((old-markings (slot-value pane 'markings)))
(setup-marked-extents pane (stream-output-history pane) +everywhere+
point-1-x point-1-y
(pointer-event-x event)
(pointer-event-y event))
(repaint-markings pane old-markings (slot-value pane 'markings)))))
(defun map-over-text (record function)
(cond ((typep record 'standard-text-displayed-output-record)
(with-slots (strings baseline max-height start-y wrapped x1 y1) record
(loop for substring in strings do
(with-slots (start-x string marked-extent text-style) substring
(funcall function start-x (+ start-y baseline) string text-style
substring record)))))
(t
(map-over-output-records-overlapping-region
#'(lambda (x)
(map-over-text x function))
record +everywhere+))))
(defun setup-marked-extents (stream record region bx1 by1 bx2 by2)
(declare (ignore region))
(when (> by1 by2)
(rotatef by1 by2)
(rotatef bx1 bx2))
(let ((*lines* nil)
(*all-lines* nil))
(map-over-text record
(lambda (x y string ts record full-record)
(let ((q (assoc y *lines*)))
(unless q
(push (setf q (cons y nil)) *lines*))
(push (list x y string ts record full-record)
(cdr q)))
(force-output *trace-output*)))
(setf *lines*
(sort (mapcar (lambda (line)
(cons (car line)
(sort (cdr line) #'< :key #'first)))
*lines*)
#'< :key #'car))
(setf *all-lines* *lines*)
;; Nuke every line that is above by1
(setf *lines* (remove-if (lambda (line) (< (+ (car line) 3) by1)) *lines*))
;; Also nuke all that are below by2
(setf *lines* (remove-if (lambda (line) (> (- (car line) 10) by2)) *lines*))
;; Special case:
(when (= 1 (length *lines*))
(psetf bx1 (min bx1 bx2)
bx2 (max bx1 bx2)))
;; Then, in the first line find the index farthest to the right
;; which is still less than bx1.
(let ((start-i 0)
(start-record (fifth (cadar *lines*)))
(end-i 0)
(end-record (fifth (cadar (last *lines*)))))
(loop for chunk in (cdr (first *lines*)) do
(destructuring-bind (x y string ts record full-record) chunk
(declare (ignorable x y string ts record full-record))
(loop for i to (length string) do
(when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
bx1)
(setf start-i i
start-record record)))))
;; Finally in the last line find the index farthest to the left
;; which still is greater than bx2. Or put differently: Search
;; from the left and while we are still in bounds maintain end-i
;; and end-record.
(loop for chunk in (cdr (car (last *lines*))) do
(destructuring-bind (x y string ts record full-record) chunk
(declare (ignorable x y string ts record full-record))
(loop for i to (length string) do
(when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
bx2)
(setf end-i i
end-record record)))))
;; Now grovel over the records, in order ...
(let ((in-p nil)
(marks nil))
(labels ((visit (chunk)
(destructuring-bind (x y string ts record full-record) chunk
(declare (ignorable x y string ts record full-record))
(let ((marked-extent nil))
(cond ((eq record start-record)
(cond ((eq record end-record)
(setf marked-extent
(cons start-i end-i)))
(t
(setf marked-extent
(cons start-i (length string)))
(setf in-p t))))
((eq record end-record)
(setf marked-extent
(cons 0 end-i))
(setf in-p nil))
(t
(setf marked-extent
(if in-p
(cons 0 (length string))
nil))) )
(when marked-extent
(push (destructuring-bind (x y string ts record full-record) chunk
(declare (ignorable x y string ts record full-record))
(make-instance 'string-marking
:record full-record
:styled-string record
:start (car marked-extent)
:end (cdr marked-extent)))
marks)) ))))
(loop for line in *all-lines* do
(loop for chunk in (cdr line) do
(visit chunk)) )
(setf (slot-value stream 'markings) (reverse marks)))))))
;;;; Selections Events
(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
(event selection-clear-event))
(pane-clear-markings pane (event-timestamp event)))
(defmethod dispatch-event :around ((pane cut-and-paste-mixin)
(event selection-request-event))
(send-selection (port pane) event (fetch-selection pane)))
(define-condition selection-notify ()
((event :reader event-of :initarg :event)))
(defmethod handle-event ((pane cut-and-paste-mixin)
(event selection-notify-event))
(signal 'selection-notify :event event))
(defmethod dispatch-event :around ((pane paste-as-keypress-mixin)
(event selection-notify-event))
(let ((matter (get-selection-from-event (port pane) event)))
(loop for c across matter do
(dispatch-event pane
(make-instance 'key-press-event
:timestamp (event-timestamp event)
:sheet pane
:modifier-state 0
:x 0 :y 0 :graft-x 0 :graft-y 0
:key-name nil
:key-character c)))))
;; FIXME: Non-text target conversions.. (?)
(defun fetch-selection (pane)
(let (old-y2 old-x2)
(with-output-to-string (bag)
(map nil
(lambda (m)
(with-slots (record styled-string start end) m
(with-standard-rectangle*
(:x1 x1 :x2 x2 :y1 y1 :y2 y2) record
(cond ((and old-y2 (>= y1 old-y2))
(setf old-y2 nil
old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates.
)
(terpri bag))
(t
(setf old-y2 (max y2 (or old-y2 y2)))))
(when old-x2
(loop repeat (round
(- x1 old-x2)
(text-style-width (slot-value styled-string 'text-style)
pane))
do
(princ " " bag)))
(setf old-x2 x2)
(princ (subseq (styled-string-string styled-string) start end) bag))))
(slot-value pane 'markings)))))
|