source: trunk/ccl/examples/cocoa-defaults.lisp @ 631

Last change on this file since 631 was 631, checked in by gb, 16 years ago

Only synch if we added a new key.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2004 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (use-interface-dir :cocoa)
21  (use-interface-dir :carbon))
22
23(require "OBJC-SUPPORT")
24
25(defstruct cocoa-default
26  symbol                                ; a lisp special variable
27  string                                ; an NSConstantString
28  type                                  ; a keyword
29  value                                 ; the "standard" initial value
30  doc                                   ; a doc string
31  )
32
33(let* ((cocoa-defaults ()))
34  (defun %get-cocoa-default (name)
35    (find name cocoa-defaults :key #'cocoa-default-symbol))
36  (defun %put-cocoa-default (default)
37    (push default cocoa-defaults))
38  (defun cocoa-defaults () cocoa-defaults)
39  (defun %remove-cocoa-default (name)
40    (setq cocoa-defaults
41          (delete name cocoa-defaults :key #'cocoa-default-symbol)))
42  (defun %clear-cocoa-defaults () (setq cocoa-defaults nil)))
43
44(defun set-cocoa-default (name string type value doc)
45  (check-type name symbol)
46  (check-type string objc-constant-string)
47  (check-type type keyword)
48  (check-type doc (or null string))
49  (%remove-cocoa-default name)
50  (%put-cocoa-default (make-cocoa-default :symbol name
51                                          :string string
52                                          :type type
53                                          :value value
54                                          :doc doc))
55  value)
56
57(defun %define-cocoa-default (name type value doc)
58  (proclaim `(special name))
59  (record-source-file name 'variable)
60  (setf (documentation name 'variable) doc)
61  (set name (set-cocoa-default name (ns-constant-string (string name)) type value doc))
62  name)
63 
64 
65
66(defmacro def-cocoa-default (name type value &optional doc)
67  `(progn
68    (declaim (special ,name))
69    (%define-cocoa-default ',name  ',type ',value ',doc)))
70
71   
72(defun update-cocoa-defaults ()
73  (let* ((domain (send (@class "NSUserDefaults") 'standard-user-defaults))
74         (need-synch nil))
75    (dolist (d (cocoa-defaults))
76      (let* ((name (cocoa-default-symbol d))
77             (key (objc-constant-string-nsstringptr (cocoa-default-string d))))
78        (if (%null-ptr-p (send domain :object-for-key key))
79          (progn
80            (send domain
81                  :set-object (%make-nsstring (format nil "~a" (cocoa-default-value d)))
82                  :for-key key)
83            (setq need-synch t))
84          (case (cocoa-default-type d)
85            (:int
86             (set name (send domain :integer-for-key key)))
87            (:float
88             (set name (send domain :float-for-key key)))
89            (:string
90             (let* ((nsstring (send domain :string-for-key key)))
91               (unless (%null-ptr-p nsstring)
92                 (set name (lisp-string-from-nsstring nsstring)))))))))
93    (when need-synch (send domain 'synchronize))))
94
95
96 
97                                   
98   
99
100                       
Note: See TracBrowser for help on using the repository browser.