Changeset 14591

Timestamp:

Jan 23, 2011, 8:25:29 AM (14 years ago)

Author:

Paul Krueger

Message:

Enhanced data conversion

File:

• trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp (modified) (3 diffs)

trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp

@@ -35 +35 @@
   (:export 
    archive-slots
+   bound-slot-modified
    class-name-string
    clear-instance-hash
@@ -246 +247 @@
                  ((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 +703 @@
   (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<whatever>" 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))
+
+)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;