xx

ports.lisp

(in-package #:climi)

(defclass standard-port (clim:basic-port)
  ((mirrored-sheet->current-pointer-cursor :initform (make-hash-table :test #'eq))
   (selections :initform (make-hash-table) :reader standard-port-selections)))

(defmethod port-lookup-current-pointer-cursor ((port standard-port) sheet)
  (gethash sheet (slot-value port 'mirrored-sheet->current-pointer-cursor)))

(defmethod climb:set-sheet-pointer-cursor :before ((port standard-port) sheet cursor)
  (setf (gethash sheet (slot-value port 'mirrored-sheet->current-pointer-cursor)) cursor))


(defclass stored-object ()
  ((content :initarg :content :reader stored-object-content)
   (type    :initarg :type    :reader stored-object-type)
   (owner   :initarg :owner   :reader stored-object-owner)))

(defun stored-object (port selection)
  (check-type port standard-port)
  (check-type selection keyword)
  (gethash selection (standard-port-selections port)))

(defsetf stored-object (port selection) (value)
  (check-type port standard-port)
  (check-type selection keyword)
  (setf (gethash selection (standard-port-selections port)) value))

(defun remove-stored-object (port selection)
  (check-type port standard-port)
  (check-type selection keyword)
  (remhash selection (standard-port-selections port)))

(defgeneric climb:clear-selection (sheet selection)
  (:method ((sheet basic-sheet) selection)
    (when-let ((port (port sheet))
               (object (stored-object port selection)))
      (when (eql (stored-object-owner object) sheet)
        (climb:clear-selection port selection))))
  (:method ((sheet standard-port) selection)
    (remove-stored-object port selection)))

(defgeneric climb:copy-to-selection (publisher object selection &optional presentation-type)
  (:method ((sheet basic-sheet) object selection
            &optional (presentation-type (clim:presentation-type-of object)))
    (climb:copy-to-selection (port sheet)
                             (make-instance 'stored-object
                                            :content object
                                            :type presentation-type
                                            :owner sheet)
                             selection))
  (:method ((port standard-port) (object stored-object) selection &optional pt)
    (declare (ignore pt))
    (setf (stored-object port selection) object)))

(defgeneric climb:request-selection (sheet selection acceptable-types)
  (:method ((sheet basic-sheet) selection acceptable-types)
    (queue-event sheet (make-instance 'clime:clipboard-send-event
                                      :type acceptable-types
                                      :sheet sheet
                                      :content content)))
  (:method ((port standard-port) selection acceptable-types)
    (stored-object port selection)))