Index: /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp =================================================================== --- /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp (revision 14593) +++ /trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp (revision 14594) @@ -736,113 +736,118 @@ ;; 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)) + (defun set-format-assoc (path-obj path format) + (setf (assoc-aref format-assoc path-obj path) format)) + + (defun format-for (path-obj path) + (assoc-aref format-assoc path-obj path)) ) +(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)) + (set-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 (format-for 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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; methods to support access to Lisp lists and arrays as if they were NSArrays