Index: /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp =================================================================== --- /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp (revision 14590) +++ /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp (revision 14591) @@ -35,4 +35,5 @@ (:export archive-slots + bound-slot-modified class-name-string clear-instance-hash @@ -246,4 +247,9 @@ ((ccl::subclassp lisp-class (find-class 'symbol)) (string-to-interned-symbol lisp-str)) + ((ccl::subclassp lisp-class (find-class 'number)) + (let ((num (read-from-string lisp-str :nil 0))) + (if (numberp num) + num + 0))) (t lisp-str)))) @@ -697,87 +703,145 @@ (ccl::%get-selector (ccl::load-objc-selector (concatenate 'string "set" (string-capitalize str :end 1))))) -(objc:defmethod (#/valueForKey: :id) - ((self lisp-ptr-wrapper) (path :id)) - ;; Treat path as a lisp path as long as it works. - ;; If it is not valid and the next target is an Objective-C object - ;; then treat the path as a normal Objective-C Key and return the results - ;; of calling #/valueForKey: on the target using path as the key. - (let* ((lisp-str (ns-to-lisp-string path)) - (lisp-path (objc-to-lisp-keypathname lisp-str)) - (ptr-obj (lpw-lisp-ptr self)) - ;; to set next-obj we try 3 ways: - ;; 1. If the path is a valid lisp function name use it to access the slot - ;; 2. If the object is an Objective-C object try calling its #/valueForKey method - ;; 3. Look for any KVO slots defined for the object with path specified as the KVO - ;; accessor and use the lisp function value-for-kvo-key to access that slot - (next-obj (cond ((and (typep lisp-path 'function-name) - (fboundp lisp-path)) - (funcall lisp-path ptr-obj)) - ((and (typep ptr-obj 'objc:objc-object) - (#/respondsToSelector: ptr-obj (reader-selector lisp-str))) - (#/valueForKey: ptr-obj path)) - (t - (ccl::value-for-kvo-key ptr-obj lisp-str))))) - ;; First track that the path is being observed by somebody - (note-kvc-observed self (lpw-lisp-ptr self) lisp-path) - (note-kvc-observed self (lpw-lisp-ptr self) lisp-str) - ;; (ns-log (format nil "(~s ~s) returned ~s" lisp-path (lpw-lisp-ptr self) next-obj)) - (cond ((eql next-obj (%null-ptr)) - next-obj) - ((null next-obj) - (%null-ptr)) - ((and (typep next-obj 'ns:ns-object) - (not (typep next-obj 'ccl::kvo-object))) - ;; any kvo-objects will be encapsulated in a lisp-ptr-wrapper - ;; so that subsequent accesses through this method will try to - ;; use ccl::value-for-kvo-key - next-obj) - ((typep next-obj 'objc-displayable) - (lisp-to-ns-object next-obj)) - (t - (wrapper-for (lpw-controller self) next-obj :parent (lpw-lisp-ptr self)))))) - -(objc:defmethod (#/setValue:forKey: :void) - ((self lisp-ptr-wrapper) (new-value :id) (path :id)) - (let* ((lisp-str (ns-to-lisp-string path)) - (lisp-path (objc-to-lisp-keypathname lisp-str)) - (ptr-obj (lpw-lisp-ptr self)) - (prev-obj (cond ((and (typep lisp-path 'function-name) - (fboundp lisp-path)) - (funcall lisp-path ptr-obj)) - ((and (typep ptr-obj 'objc:objc-object) - (#/respondsToSelector: self (reader-selector lisp-str))) - (#/valueForKey: ptr-obj path)) - (t - (ccl::value-for-kvo-key ptr-obj lisp-str)))) - (prev-class (class-of prev-obj)) - (new-lisp-obj (ns-to-lisp-object new-value :lisp-class prev-class)) - (setf-func (fboundp (list 'setf lisp-path))) - ;;`(setf (,lisp-path ,(lpw-lisp-ptr self)) ,new-lisp-obj)) - (ctrl (lpw-controller self))) - ;; (ns-log (format nil "Prev Class: ~s" prev-class)) - (cond (setf-func - (funcall setf-func new-lisp-obj ptr-obj)) - ((and (typep ptr-obj 'objc:objc-object) - (typep new-lisp-obj 'objc:objc-object) - (#/respondsToSelector: self (writer-selector lisp-str))) - (#/setValue:forKey: ptr-obj new-lisp-obj path)) - (t - (multiple-value-bind (value found-slot) - (setf (ccl::value-for-kvo-key ptr-obj lisp-str) new-lisp-obj) - (declare (ignore value)) - (unless found-slot - ;; If the setf failed, log the original condition - (error "No way to setValue: ~s forKey: ~s for lisp-ptr ~s" - new-lisp-obj - lisp-str - ptr-obj))))) - (when ctrl - (lc::modified-bound-value ctrl - (lpw-lisp-ptr self) - lisp-path - prev-obj - new-lisp-obj)) - new-lisp-obj)) +(defmethod bound-slot-modified ((self standard-object) slot-name) + (declare (ignore slot-name)) + ;; do nothing by default + ) + +(defmethod real-observer (nskvo) + ;; nskvo will be an instance of NSKeyValueObservance which isn't public as far as I can tell. + ;; All we want is a pointer to the original observer extracted from that object, but without + ;; a public API that is a little tricky. But we are trickier. We use the #/description of that + ;; object which provides a substring of the form "Observer: 0x" which points to + ;; possibly another non-public object of type NSSelectionBinder. We extract the address and + ;; create a pointer to the NSSelectionbinder. We now use its description to extract its + ;; "object" slot address, which hopefully points to the original view object that we bound + ;; to our lisp object. We use that to create a macptr and return it. + (let* ((desc (ns-to-lisp-string (#/description nskvo))) + (obs-start (search "Observer: " desc)) + (hex-start (and obs-start (position #\x desc :start (+ obs-start 9)))) + (hex-end (and hex-start (position #\, desc :start hex-start))) + (hex-val (and hex-end (read-from-string (concatenate 'string "#" (subseq desc hex-start hex-end)) nil 0))) + (nssb-ptr (and hex-val (ccl::%int-to-ptr hex-val))) + (nssb-desc (and nssb-ptr (ns-to-lisp-string (#/description nssb-ptr)))) + (obj-start (search "object:" nssb-desc)) + (obj-class-end (and obj-start (position #\: nssb-desc :start (+ obj-start 8)))) + (obj-hex-start (and obj-class-end (position #\x nssb-desc :start obj-class-end))) + (obj-hex-end (and obj-hex-start (position #\> nssb-desc :start obj-hex-start))) + (obj-hex-val (and obj-hex-end (read-from-string (concatenate 'string "#" (subseq nssb-desc obj-hex-start obj-hex-end)) nil 0)))) + (when obj-hex-val + (ccl::%int-to-ptr obj-hex-val)))) + +(let ((format-assoc (make-instance 'assoc-array :rank 2 :tests (list #'eql #'equal)))) + ;; used to hold needed Objective-C format information for slots that are observed by + ;; Objective-C objects that have associated formatter objects from which we can take hints. + + (objc:defmethod (#/addObserver:forKeyPath:options:context: :void) + ((self lisp-ptr-wrapper) (obs :id) (key-path :id) (options #>NSUInteger) (context :address)) + (let ((observer (real-observer obs))) + (ns-log (format nil "~s observed by ~s" (lpw-lisp-ptr self) observer)) + (when (subtypep (type-of observer) 'ns:ns-control) + (let* ((cell (#/cell observer)) + (formatter (#/formatter cell)) + (ns-format nil)) + (cond ((or (typep cell 'ns:ns-date-picker-cell) + (typep formatter 'ns:ns-date-formatter)) + (setf ns-format :date)) + ((typep formatter 'ns:ns-number-formatter) + (cond ((#/generatesDecimalNumbers formatter) + (let ((dec-digits (#/maximumFractionDigits formatter))) + (setf ns-format (list :decimal dec-digits)))) + (t + (setf ns-format :number))))) + (when ns-format + (ns-log (format nil "Observer data format: ~s" ns-format)) + (setf (assoc-aref format-assoc self (ns-to-lisp-string key-path)) ns-format))))) + (call-next-method obs key-path options context)) + + (objc:defmethod (#/valueForKey: :id) + ((self lisp-ptr-wrapper) (path :id)) + ;; Treat path as a lisp path as long as it works. + ;; If it is not valid and the next target is an Objective-C object + ;; then treat the path as a normal Objective-C Key and return the results + ;; of calling #/valueForKey: on the target using path as the key. + (let* ((lisp-str (ns-to-lisp-string path)) + (lisp-path (objc-to-lisp-keypathname lisp-str)) + (ptr-obj (lpw-lisp-ptr self)) + ;; to set next-obj we try 3 ways: + ;; 1. If the path is a valid lisp function name use it to access the slot + ;; 2. If the object is an Objective-C object try calling its #/valueForKey method + ;; 3. Look for any KVO slots defined for the object with path specified as the KVO + ;; accessor and use the lisp function value-for-kvo-key to access that slot + (next-obj (cond ((and (typep lisp-path 'function-name) + (fboundp lisp-path)) + (funcall lisp-path ptr-obj)) + ((and (typep ptr-obj 'objc:objc-object) + (#/respondsToSelector: ptr-obj (reader-selector lisp-str))) + (#/valueForKey: ptr-obj path)) + (t + (ccl::value-for-kvo-key ptr-obj lisp-str))))) + ;; First track that the path is being observed by somebody + (note-kvc-observed self (lpw-lisp-ptr self) lisp-path) + (note-kvc-observed self (lpw-lisp-ptr self) lisp-str) + ;; (ns-log (format nil "(~s ~s) returned ~s" lisp-path (lpw-lisp-ptr self) next-obj)) + (cond ((eql next-obj (%null-ptr)) + next-obj) + ((null next-obj) + (%null-ptr)) + ((and (typep next-obj 'ns:ns-object) + (not (typep next-obj 'ccl::kvo-object))) + ;; any kvo-objects will be encapsulated in a lisp-ptr-wrapper + ;; so that subsequent accesses through this method will try to + ;; use ccl::value-for-kvo-key + next-obj) + ((typep next-obj 'objc-displayable) + (lisp-to-ns-object next-obj (assoc-aref format-assoc self lisp-str))) + (t + (wrapper-for (lpw-controller self) next-obj :parent (lpw-lisp-ptr self)))))) + + (objc:defmethod (#/setValue:forKey: :void) + ((self lisp-ptr-wrapper) (new-value :id) (path :id)) + (let* ((lisp-str (ns-to-lisp-string path)) + (lisp-path (objc-to-lisp-keypathname lisp-str)) + (ptr-obj (lpw-lisp-ptr self)) + (prev-obj (cond ((and (typep lisp-path 'function-name) + (fboundp lisp-path)) + (funcall lisp-path ptr-obj)) + ((and (typep ptr-obj 'objc:objc-object) + (#/respondsToSelector: self (reader-selector lisp-str))) + (#/valueForKey: ptr-obj path)) + (t + (ccl::value-for-kvo-key ptr-obj lisp-str)))) + (prev-class (class-of prev-obj)) + (new-lisp-obj (ns-to-lisp-object new-value :lisp-class prev-class)) + (setf-func (fboundp (list 'setf lisp-path))) + ;;`(setf (,lisp-path ,(lpw-lisp-ptr self)) ,new-lisp-obj)) + (ctrl (lpw-controller self))) + ;; (ns-log (format nil "Prev Class: ~s" prev-class)) + (cond (setf-func + (funcall setf-func new-lisp-obj ptr-obj)) + ((and (typep ptr-obj 'objc:objc-object) + (typep new-lisp-obj 'objc:objc-object) + (#/respondsToSelector: self (writer-selector lisp-str))) + (#/setValue:forKey: ptr-obj new-lisp-obj path)) + (t + (multiple-value-bind (value found-slot) + (setf (ccl::value-for-kvo-key ptr-obj lisp-str) new-lisp-obj) + (declare (ignore value)) + (if found-slot + (bound-slot-modified ptr-obj (ccl::slot-definition-name found-slot)) + ;; If the setf failed, log the original condition + (error "No way to setValue: ~s forKey: ~s for lisp-ptr ~s" + new-lisp-obj + lisp-str + ptr-obj))))) + (when ctrl + (lc::modified-bound-value ctrl + (lpw-lisp-ptr self) + lisp-path + prev-obj + new-lisp-obj)) + new-lisp-obj)) + +) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;