Changeset 6723

Timestamp:

Jun 14, 2007, 12:32:38 AM (17 years ago)

Author:

Gary Byers

Message:

Try to work with new preferences scheme.

File:

• branches/ide-1.0/ccl/examples/cocoa-defaults.lisp (modified) (4 diffs)

branches/ide-1.0/ccl/examples/cocoa-defaults.lisp

@@ -57 +57 @@
   value)
 
+;;; Names which contain #\* confuse Cocoa Bindings.
+(defun objc-default-key (name)
+  (ns-constant-string (remove #\* (lisp-to-objc-message (list name)))))
+  
+
 (defun %define-cocoa-default (name type value doc &optional constraint)
   (proclaim `(special ,name))
@@ -65 +70 @@
   (record-source-file name 'variable)
   (setf (documentation name 'variable) doc)
-  (set name (set-cocoa-default name (ns-constant-string (string name)) type value doc constraint))
+  (set name (set-cocoa-default name (objc-default-key name) type value doc constraint))
   name)
   
@@ -75 +80 @@
        (note-variable-info ',name :global ,env))
     (declaim (special ,name))
-    (%define-cocoa-default ',name  ',type ',value ',doc ,@(when constraint `((specifier-type ',constraint))))))
+    (%define-cocoa-default ',name  ',type ,value ',doc ,@(when constraint `((specifier-type ',constraint))))))
 
     
 (defun update-cocoa-defaults ()
-  (update-cocoa-defaults-vector
+  (update-cocoa-defaults-list
    (#/standardUserDefaults ns:ns-user-defaults)
-   (apply #'vector (reverse (cocoa-defaults)))))
+   (cocoa-defaults)))
 
-(defun update-cocoa-defaults-vector (domain defaults-vector)
+(defun update-cocoa-defaults-list (domain defaults)
   (let* ((need-synch nil))
-    (dotimes (i (length defaults-vector))
-      (let* ((d (svref defaults-vector i))
-             (name (cocoa-default-symbol d))
+    (dolist (d defaults)
+      (let* ((name (cocoa-default-symbol d))
              (key (objc-constant-string-nsstringptr (cocoa-default-string d))))
         (if (%null-ptr-p (#/objectForKey:  domain key))
           (progn
-            (#/setObject:forKey: domain (%make-nsstring (format nil "~a" (cocoa-default-value d))) key)
+            (#/setObject:forKey: domain
+                                 (case (cocoa-default-type d)
+                                   (:color (#/archivedDataWithRootObject:
+                                            ns:ns-archiver
+                                            (cocoa-default-value d)))
+                                   (t
+                                    (%make-nsstring (format nil "~a" (cocoa-default-value d)))))
+                                   key)
             (setq need-synch t))
           (case (cocoa-default-type d)
@@ -101 +112 @@
              (let* ((nsstring (#/stringForKey: domain key)))
                (unless (%null-ptr-p nsstring)
-                 (set name (lisp-string-from-nsstring nsstring)))))))))
+                 (set name (lisp-string-from-nsstring nsstring)))))
+            (:color
+             (let* ((data (#/dataForKey: domain key)))
+               (unless (%null-ptr-p data)
+                 (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver data))))))))))
     (when need-synch (#/synchronize domain))))
+
+;;; Type of newval depends on cocoa-default-type.
+(defun update-cocoa-default (d newval)
+  (let* ((name (cocoa-default-symbol d))) 
+    (case (cocoa-default-type d)
+            (:int
+             (set name (#/intValue newval)))
+            (:float
+             (set name (#/floatValue newval)))
+            (:string
+             (unless (%null-ptr-p newval)
+                 (set name (lisp-string-from-nsstring newval))))
+            (:color
+               (unless (%null-ptr-p newval)
+                 (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver newval))))))))