source: trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp @ 16178

Last change on this file since 16178 was 16178, checked in by plkrueger, 7 years ago

Bug Fixes for Lisp app development

File size: 41.5 KB
Line 
1;; ns-object-utils.lisp
2#|
3The MIT license.
4
5Copyright (c) 2010 Paul L. Krueger
6
7Permission is hereby granted, free of charge, to any person obtaining a copy of this software
8and associated documentation files (the "Software"), to deal in the Software without restriction,
9including without limitation the rights to use, copy, modify, merge, publish, distribute,
10sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
11furnished to do so, subject to the following conditions:
12
13The above copyright notice and this permission notice shall be included in all copies or substantial
14portions of the Software.
15
16THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
17LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
19WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22|#
23
24(eval-when (:compile-toplevel :load-toplevel :execute)
25  (require :iu-classes)
26  (require :ns-string-utils)
27  (require :binding-utils)
28  (require :nslog-utils)
29  (require :date)
30  (require :alert)
31  (require :decimal)
32  (require :assoc-array)
33  (require :attributed-strings))
34
35(in-package :iu)
36
37;;;;;;;;;;;;;;;;;;;;;;;
38;;; Global variable
39
40(defvar *debug-convert* nil)
41
42
43;;;;;;;;;;;;;;;;;;;;;;;
44;;; Special types
45
46(deftype lisp-slot-object ()
47  '(satisfies ccl::has-lisp-slot-vector))
48
49;;;;;;;;;;;;;;;;;;;;;;;;;
50;;; Utility functions
51
52(defmethod class-conforms-to-protocol ((cl objc:objc-class-object) prot)
53  (let ((pr (#_NSProtocolFromString (coerce-obj prot 'ns:ns-string))))
54    (unless (eql pr (%null-ptr))
55      (#/conformsToProtocol: cl pr))))
56
57(defmethod class-conforms-to-protocol (cl prot)
58  (declare (ignore cl prot))
59  nil)
60
61(defun print-ns-object (ns-obj)
62  ;; default print methods for objects truncate strings at 1024 characters for some reason
63  ;; this function doesn't
64  (if (ccl::objc-object-p ns-obj)
65    (format t "~a" (ns-to-lisp-string (#/description ns-obj)))
66    (format t "~s" ns-obj)))
67
68(defun obj-if-not-null (ns-obj)
69  (if (eql ns-obj (%null-ptr))
70    nil
71    ns-obj))
72
73(defun unreadable-object-string-p (str)
74  ;; returns t if str contains a "#<" substring
75  (search "#<" str))
76
77(defun string-to-interned-symbol (str)
78  ;; str can be in form a, a:b, or a::b
79  (let* ((c1-pos (or (position #\: str) 0))
80         (c2-pos (or (position #\: str :from-end t) -1))
81         (pkg-str (string-upcase (subseq str 0 c1-pos)))
82         (name-str (string-upcase (subseq str (1+ c2-pos)))))
83    (if (string= pkg-str "")
84      (unless (string= name-str "")
85        (intern name-str))
86      (when (find-package pkg-str)
87        (intern name-str pkg-str)))))
88
89(defun recursive-map (func obj)
90  ;; apply func to obj and then to the results
91  ;; returned from that application recursively
92  ;; func can return either a list of objects or a single object
93  (let ((res (funcall func obj)))
94    (setf res (if (listp res) (copy-list res) (list res)))
95    (nconc res (mapcan #'(lambda (sub-obj)
96                           (recursive-map func sub-obj))
97                       res))))
98
99(defun class-name-string (class)
100  ;; we want a fully-qualified string (including package designation) for the class
101  ;; so symbol-name won't cut it.
102  (format nil "~s" (class-name class)))
103
104(defun ns-to-lisp-classname (classname-str &optional (previous-str ""))
105  ;; unlike ccl::objc-to-lisp-classname which does a syntactic translation
106  ;; and therefore fails to provide a package-qualified classname, this
107  ;; function finds the actual class and returns its name.
108  (unless (non-empty-string classname-str)
109    (return-from ns-to-lisp-classname ""))
110  (let ((cls (#_NSClassFromString (iu::lisp-to-temp-nsstring classname-str))))
111    (if (eql cls (%null-ptr))
112      ;; There isn't a known class with this name.
113      ;; If the lexical conversion of classname-str is identical to the part
114      ;; of the non-package portion of the previous string then just use the
115      ;; previous string.
116      (let* ((lisp-name (ccl::objc-to-lisp-classname classname-str))
117             (col-pos (position #\: previous-str :test #'char= :from-end t))
118             (prev-base (if col-pos
119                          (subseq previous-str (1+ col-pos))
120                          previous-str)))
121        (if (string-equal lisp-name prev-base)
122          previous-str
123          lisp-name))
124      (class-name-string cls))))
125
126(defun find-ns-classes (&key (if-pkg nil) (if-not-pkg nil))
127  ;; finds all subclasses of ns:ns-object which are explicitly in the non-null if-pkg
128  ;; or finds all that are explicitly not in the non-null if-not-pkg
129  ;; either keyword argument may contain a single package or package-name or a list
130  ;; of packages or package names
131  (let ((if-pkgs (mapcar #'find-package 
132                         (and if-pkg (if (consp if-pkg) if-pkg (list if-pkg)))))
133        (if-not-pkgs (mapcar #'find-package 
134                             (and if-not-pkg (if (consp if-not-pkg) if-not-pkg (list if-not-pkg)))))
135        (ns-classes (mapcar #'class-name (recursive-map #'class-direct-subclasses ns:ns-object))))
136    (when if-pkgs
137      (setf ns-classes (delete-if-not #'(lambda (class-name)
138                                          (member (find-package (symbol-package class-name)) if-pkgs))
139                                      ns-classes)))
140    (when if-not-pkgs
141      (setf ns-classes (delete-if #'(lambda (class-name)
142                                      (member (find-package (symbol-package class-name)) if-not-pkgs))
143                                  ns-classes)))
144    ns-classes))
145
146(defun ns-to-lisp-object (ns-obj &key (lisp-class nil) (ns-format nil))
147  ;; convert an arbitrary NSObject object to an appropriate lisp object.
148  ;; Often done so that it can replace the old-lisp-obj when edited
149  ;; An empty string @"" returns nil if old-lisp-obj is not a string
150  (when *debug-convert*
151    (ns-log-format "Converting ~s to lisp~@[ lisp-class = ~s~]~@[ ns-format = ~s~]" ns-obj lisp-class ns-format))
152  (cond ((ccl::subclassp (class-of ns-obj) lisp-class)
153         ;; ns-obj is a subclass of the target lisp class so just return the new value
154         ns-obj)
155        ((or (eql ns-obj (%null-ptr))
156             (eql ns-obj #$NSNoSelectionMarker)
157             (eql ns-obj #$NSNullPlaceholderBindingOption)
158             (eql ns-obj #$NSNotApplicablePlaceholderBindingOption))
159         (if (ccl::subclassp lisp-class (find-class 'string))
160           ""
161           nil))
162        ((typep ns-obj 'lisp-ptr-wrapper)
163         ;; just strip the wrapper and return the original object
164         (lpw-lisp-ptr ns-obj))
165        ((typep ns-obj 'ns-sym)
166         (sym ns-obj))
167        ((typep ns-obj 'ns-misc)
168         (obj ns-obj))
169        ((typep ns-obj 'ns-func)
170         (func ns-obj))
171        ((typep ns-obj 'ns:ns-decimal-number)
172         (cond ((ccl::subclassp lisp-class (find-class 'double-float))
173                ;; convert the decimal to a double
174                (#/doubleValue ns-obj))
175               ((ccl::subclassp lisp-class (find-class 'float))
176                ;; convert the decimal to a float
177                (#/floatValue ns-obj))
178               (t
179                ;; otherwise convert it to an appropriate lisp integer with assumed
180                ;; decimals (see ip;Utilities;decimal.lisp)
181                (if (and (listp ns-format) (eq (first ns-format) :decimal))
182                  (lisp-from-ns-decimal ns-obj :decimals (second ns-format))
183                  (lisp-from-ns-decimal ns-obj)))))
184        ((typep ns-obj 'ns:ns-url)
185         (ns-to-lisp-string (if (#/isFileURL ns-obj)
186                              (#/path ns-obj)
187                              (#/absoluteString ns-obj))))
188        ((typep ns-obj 'ns:ns-number)
189         (cond ((and (listp ns-format) (eq (first ns-format) :decimal))
190                (round (* (expt 10 (second ns-format)) (#/floatValue ns-obj))))
191               ((eq lisp-class (find-class 'symbol))
192                ;; how can a number be of class 'symbol? Simple, it is nil if number
193                ;; is 0 or t otherwise
194                (not (= (#/intValue ns-obj) 0)))
195               ((ccl::subclassp lisp-class (find-class 'double-float))
196                ;; convert the number to a double
197                (#/doubleValue ns-obj))
198               ((ccl::subclassp lisp-class (find-class 'float))
199                ;; convert the number to a float
200                (#/floatValue ns-obj))
201               ((ccl::subclassp lisp-class (find-class 'integer))
202                ;; convert the number to an integer
203                (#/longLongValue ns-obj))
204               ((ccl::subclassp lisp-class (find-class 'ratio))
205                ;; convert the number to an integer
206                (#/floatValue ns-obj))
207               ((eql ns-obj (#/numberWithBool: ns:ns-number #$YES))
208                ;; the number is the constant for #$YES, convert to t
209                ;; This does NOT convert all numbers with the value 1 to t
210                t)
211               ((eql ns-obj (#/numberWithBool: ns:ns-number #$NO))
212                ;; the number is the constant for #$NO, convert to nil
213                ;; This does NOT convert all numbers with the value 0 to nil
214                nil)
215               (t
216                ;; no specific target, so just read from the string representation
217                (read-from-string (ns-to-lisp-string
218                                   (#/descriptionWithLocale: ns-obj (%null-ptr)))
219                                  nil nil))))
220        ((typep ns-obj 'ns:ns-date)
221         (ns-to-lisp-date ns-obj))
222        ((typep ns-obj 'lisp-object-reference)
223         (objc-to-std-instance ns-obj))
224        ((typep ns-obj 'ns:ns-dictionary)
225         (cond ((ccl::subclassp lisp-class (find-class 'list))
226                (ns-to-lisp-assoc ns-obj))
227               (t
228                (ns-to-lisp-hash-table ns-obj))))
229        ((typep ns-obj 'ns:ns-array)
230         (if (or (ccl::subclassp lisp-class (find-class 'list))
231                 (eq lisp-class (find-class 'null))) ;; assume they want a list
232           (ns-to-lisp-list ns-obj)
233           (ns-to-lisp-array ns-obj)))
234        ((typep ns-obj 'ns:ns-attributed-string)
235         (cond ((ccl::subclassp lisp-class (find-class 'string))
236                (ns-attrib-to-lisp-string ns-obj))
237               (t
238                (make-instance 'attributed-string :ns-str ns-obj))))
239        ((typep ns-obj 'ns:ns-string)
240         (let ((lisp-str (ns-to-lisp-string ns-obj)))
241           (cond ((ccl::subclassp lisp-class (find-class 'string))
242                  lisp-str)
243                 ((ccl::subclassp lisp-class (find-class 'symbol))
244                  (string-to-interned-symbol lisp-str))
245                 ((ccl::subclassp lisp-class (find-class 'number))
246                  (let ((num (read-from-string lisp-str :nil 0)))
247                    (if (numberp num)
248                      num
249                      lisp-str)))
250                 (t
251                  lisp-str))))
252        ((typep ns-obj 'ns:ns-null)
253         nil)
254        (t
255         ;; can't convert so just return ns-obj
256         ns-obj)))
257
258(defun lisp-to-ns-object (lisp-obj &optional (ns-format nil))
259  ;; convert an arbitrary lisp object to an appropriate NSObject so
260  ;; that it can be displayed someplace
261  (when *debug-convert*
262    (ns-log-format "Converting ~s to ns~@[ ns-format = ~s~]" lisp-obj ns-format))
263  (cond ((and (eq ns-format :archive)
264              (typep lisp-obj 'ns:ns-object))
265         (if (class-conforms-to-protocol (class-of lisp-obj) "NSCoding")
266           ;; Any object that conforms to NSCoding can just be returned.
267           ;; A lisp class that inherits from an Objective-C class which is NSCoding compliant
268           ;; must itself implement appropriate encoding and decoding methods if it wants to
269           ;; add additional information to the archived object (and it should call-next-method
270           ;; as the first thing it does).
271           lisp-obj
272           ;; otherwise convert to a lisp-object-reference
273           (std-instance-to-objc lisp-obj)))
274        ((ccl::objc-object-p lisp-obj)
275         ;; it's already an NSObject so just return it
276         lisp-obj)
277        ((member (type-of lisp-obj) (list 'ns:ns-rect 'ns:ns-size 'ns:ns-point))
278         ;; These types are let through even if they aren't exactly objc "objects"
279         (if (eq ns-format :archive)
280           ;; But if we're archiving them we need to encapsulate them
281           (lisp-to-ns-misc lisp-obj)
282           lisp-obj))
283        ((eq ns-format :wrapper)
284         (wrapper-for lisp-obj))
285        ((eq ns-format :date)
286         (if (stringp lisp-obj)
287           (string-to-ns-date lisp-obj)
288           ;; assume lisp-obj is an integer representing a lisp date
289           (lisp-to-ns-date lisp-obj)))
290        ((typep lisp-obj 'attributed-string)
291         (cond ((eq ns-format :text)
292                ;; The binding object doesn't accept NSAttributedStrings so
293                ;; pass it an NSString
294                (#/string (att-ns-str lisp-obj)))
295               ((eq ns-format :archive)
296                ;; We're archiving this to disk, so save it as we would
297                ;; any other Lisp instance so that eq-ness is preserved when it is restored.
298                (std-instance-to-objc lisp-obj))
299               (t
300                ;; Either null ns-format or :rich-text
301                ;; Return the NSMutableAttributedString
302                (att-ns-str lisp-obj))))
303        ((and (consp ns-format) (eq (first ns-format) :decimal))
304         (cond ((typep lisp-obj 'fixnum)
305                (lisp-to-ns-decimal lisp-obj :decimals (second ns-format)))
306               ((typep lisp-obj 'number)
307                (lisp-to-ns-decimal (round (* (expt 10 (second ns-format)) lisp-obj))
308                                    :decimals (second ns-format)))
309               (t
310                (lisp-to-ns-decimal 0 :decimals (second ns-format)))))
311        ((typep lisp-obj '(signed-byte 16))
312         (#/numberWithShort: ns:ns-number lisp-obj))
313        ((typep lisp-obj '(signed-byte 32))
314         (#/numberWithLong: ns:ns-number lisp-obj))
315        ((typep lisp-obj '(signed-byte 64))
316         (#/numberWithLongLong: ns:ns-number lisp-obj))
317        ((typep lisp-obj 'double-float)
318         (#/numberWithDouble: ns:ns-number lisp-obj))
319        ((floatp lisp-obj)
320         (#/numberWithFloat: ns:ns-number lisp-obj))
321        ((ratiop lisp-obj)
322         (#/numberWithFloat: ns:ns-number (float lisp-obj)))
323        ((floatp lisp-obj)
324         ;; some other type of floating number
325         (#/numberWithFloat: ns:ns-number (float lisp-obj)))
326        ((integerp lisp-obj)
327         ;; some other type of integer number
328         (#/numberWithLongLong: ns:ns-number (coerce lisp-obj '(signed-byte 64))))
329        ((complexp lisp-obj)
330         ;; no Objective-C counterpart so just return the realpart of the complex
331         (#/numberWithFloat: ns:ns-number (float (realpart lisp-obj))))
332        ((null lisp-obj)
333         (#/numberWithBool: ns:ns-number #$NO))
334        ((eq lisp-obj t)
335         (#/numberWithBool: ns:ns-number #$YES))
336        ((symbolp lisp-obj)
337         (lisp-to-ns-sym lisp-obj))
338        ((stringp lisp-obj)
339         (let ((ns-str (lisp-to-temp-nsstring lisp-obj)))
340           (if (eq ns-format :rich-text)
341             (#/autorelease (#/initWithString: (#/alloc ns:ns-attributed-string) ns-str))
342             ns-str)))
343        ((hash-table-p lisp-obj)
344         (lisp-to-ns-dict lisp-obj))
345        ((or (vectorp lisp-obj) (consp lisp-obj))
346         (lisp-to-ns-array lisp-obj))
347        ((or (typep lisp-obj 'standard-object)
348             (typep lisp-obj 'structure-object))
349         (std-instance-to-objc lisp-obj))
350        ((typep lisp-obj 'function)
351         (lisp-to-ns-func lisp-obj))
352        (t
353         (lisp-to-ns-misc lisp-obj))))
354
355;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
356;; Methods dealing with standard-object instances
357
358(defvar *converting* nil)
359(defvar *unconverting* nil)
360
361;; The *ns-object-hash* keeps track of instances that have been converted to objc objects and
362;; only converts an instance one time.
363(defvar *ns-object-hash* nil)
364
365;; Similarly, *lisp-object-assoc* keeps track of objc objects that have been turned into lisp objects
366;; and always returns the same lisp obj for the multiple invocations of objc-to-std-instance
367;; that pass in the same objc object and are looking for the same lisp target class.
368(defvar *lisp-object-assoc* nil)
369
370(defun vals ()
371  (declare (special *converting* *ns-object-hash*))
372  (values *converting* *ns-object-hash*))
373
374(defmacro while-converting (&rest body)
375  `(let ((*converting* t)
376         (*ns-object-hash* (make-hash-table)))
377     (prog1 (progn ,@body)
378       (maphash #'(lambda (key val)
379                    (declare (ignore key))
380                    (#/release val))
381                *ns-object-hash*))))
382
383(defmacro while-unconverting (&rest body)
384  `(let ((*unconverting* t)
385         (*lisp-object-assoc* (make-instance 'assoc-array :rank 2 :tests (list #'eql #'eq))))
386     (prog1 (progn ,@body)
387       ;; release all the objects we retained in note-unconverted-object
388       (map-assoc-array #'(lambda (obj x)
389                            (declare (ignore x))
390                            (#/release obj))
391                        *lisp-object-assoc*))))
392
393(defun note-converted-object (lisp-obj ns-obj)
394  (declare (special *converting* *ns-object-hash*))
395  (when *converting*
396    (#/retain ns-obj)
397    (setf (gethash lisp-obj *ns-object-hash*) ns-obj)))
398
399(defun note-unconverted-object (ns-obj lisp-target-class lisp-obj)
400  (declare (special *unconverting* *lisp-object-assoc*))
401  (when *unconverting*
402    (#/retain ns-obj)
403    (setf (assoc-aref *lisp-object-assoc* ns-obj lisp-target-class) lisp-obj)))
404
405(defun converted-object (lisp-obj)
406  (declare (special *converting* *ns-object-hash*))
407  (and *converting*
408       (gethash lisp-obj *ns-object-hash* nil)))
409
410(defun unconverted-object (lisp-obj lisp-target-class)
411  (declare (special *unconverting* *lisp-object-assoc*))
412  (and *unconverting*
413       (assoc-aref *lisp-object-assoc* lisp-obj lisp-target-class)))
414
415;; lisp-object-reference: A class that encapsulates references to other instances so that we can have circular
416;; references.
417
418#|
419(defclass lisp-object-reference (ns:ns-object)
420  ((obj-dict :accessor obj-dict :initarg :obj-dict))
421  (:default-initargs :obj-dict nil)
422  (:metaclass ns:+ns-object))
423|#
424
425(defmethod initialize-instance :after ((self lisp-object-reference) &key obj-dict &allow-other-keys)
426  (when *debug-convert*
427    (ns-log-format "Initializing lisp-object-reference for ~s" self))
428  (when (and obj-dict (ccl::objc-object-p obj-dict))
429    (#/retain obj-dict)))
430
431(objc:defmethod (#/dealloc :void)
432                ((self lisp-object-reference))
433  (with-slots (obj-dict) self
434    (when (and obj-dict (ccl::objc-object-p obj-dict))
435    (#/release obj-dict)))
436  (call-next-method)
437  (objc:remove-lisp-slots self))
438
439(objc:defmethod (#/initWithCoder: :id)
440                ((self lisp-object-reference) (decoder :id))
441  (setf (obj-dict self) (#/retain (#/decodeObjectForKey: decoder #@"obj-dict")))
442  self)
443
444(objc:defmethod (#/encodeWithCoder: :void)
445                ((self lisp-object-reference) (coder :id))
446  (#/encodeObject:forKey: coder
447                          (obj-dict self)
448                          #@"obj-dict"))
449
450(defun instance-to-ref (obj)
451  (when *debug-convert*
452    (ns-log-format "Finding or creating lisp-object-reference for ~s" obj))
453  (or (converted-object obj)
454      (let* ((slots (archive-slots obj))
455             (obj-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary (1+ (* 2 (list-length slots)))))
456             (obj-ref (make-instance 'lisp-object-reference :obj-dict obj-dict)))
457        (note-converted-object obj obj-ref)
458        (#/setObject:forKey: obj-dict
459                             (lisp-to-ns-object (class-name (class-of obj)))
460                             #@"__instance-class__")
461        (dolist (slot slots)
462          (let ((slot-str (string slot))
463                (slot-val (slot-value obj slot)))
464            (#/setObject:forKey: obj-dict
465                                 (lisp-to-ns-object (class-name (class-of slot-val)))
466                                 (lisp-to-temp-nsstring (concatenate 'string 
467                                                                     slot-str
468                                                                     "__class__")))
469            (#/setObject:forKey: obj-dict
470                                 (lisp-to-ns-object slot-val :archive)
471                                 (lisp-to-temp-nsstring slot-str))))
472        (#/autorelease obj-ref))))
473
474(defmethod std-instance-to-objc ((obj standard-object))
475  ;; Default method for converting an object instance to an Objective-C dictionary object.
476  ;; This is used to create objects that can be converted and restored by normal Objective-C
477  ;; methods such as encodeWithCoder: and initWithCoder:.
478  ;; Classes can override or specialize this in any way they want as long as some Objective-C
479  ;; instance is returned.
480  (instance-to-ref obj))
481
482(defmethod std-instance-to-objc ((obj structure-object))
483  ;; Default method for converting an structure instance to an Objective-C dictionary object.
484  ;; This is used to create objects that can be converted and restored by normal Objective-C
485  ;; methods such as encodeWithCoder: and initWithCoder:.
486  ;; Classes can override or specialize this in any way they want as long as some Objective-C
487  ;; instance is returned.
488  (instance-to-ref obj))
489
490(defmethod objc-to-std-instance ((ref lisp-object-reference) &optional new-instance)
491  (when *debug-convert*
492    (ns-log-format "Converting ~s to std-instance~@[ (using existing ~s)~]" ref new-instance))
493  (or (unconverted-object ref nil)
494      (let* ((obj-dict (obj-dict ref))
495             (class (find-class (ns-to-lisp-object
496                                 (#/objectForKey: obj-dict #@"__instance-class__"))
497                                nil))
498             (inst (and class
499                        (if (ccl::subclassp (class-of new-instance) class)
500                          ;; if new-instance is specified and is of a compatible type,
501                          ;; then just set the values in its slots from the NSDictionary
502                          ;; object. Otherwise create a new instance.
503                          new-instance
504                          (make-instance class)))))
505        (unless class
506          (ns-log (format nil
507                          "Bad dictionary found in objc-to-std-instance: ~s" obj-dict))
508          (alert :text 
509           "In objc-to-std-instance, no instance-class found in NSDictionary, returned object will be nil. See console log for more information"))
510        (when inst
511          (note-unconverted-object ref nil inst)
512          (dolist (slot (archive-slots inst) inst)
513            (let* ((slot-str (string slot))
514                   (slot-class-key-str (lisp-to-temp-nsstring (concatenate 'string
515                                                                           slot-str
516                                                                           "__class__")))
517                   (slot-class-str (ns-to-lisp-object (#/objectForKey: obj-dict 
518                                                                       slot-class-key-str)))
519                   (slot-class (find-class slot-class-str nil))
520                   (objc-slot-val (#/objectForKey: obj-dict (lisp-to-temp-nsstring slot-str)))
521                   (slot-val (ns-to-lisp-object 
522                              objc-slot-val
523                              :lisp-class slot-class)))
524              (when (ccl::objc-object-p slot-val)
525                (#/retain slot-val))
526              (cond ((eq slot-val :none)
527                     (ns-log (format nil
528                                     "Saved value for ~s slot cannot be converted to Lisp. Value: ~s"
529                                     slot
530                                     objc-slot-val)))
531                    ((not (eql objc-slot-val (%null-ptr)))
532                     ;; We found an archived value for the slot
533                     (setf (slot-value inst slot) slot-val))
534                    (t
535                     ;; There is now a slot in the object that wasn't archived in the saved version of
536                     ;; this instance. We just let the default initial value take care of it and do
537                     ;; nothing here.
538                     nil))))))))
539
540(defun instance-hash-table-p (ns-dict)
541  ;; ns-dict must be an NSDictionary object
542  ;; check to see if it is an encoded standard-instance
543  (not (eql (%null-ptr) (#/objectForKey: ns-dict #@"__instance-class__"))))
544
545(defun arch-slots (obj)
546  ;; by default return a list of all non-foreign slots
547  ;; object classes that do not want to archive all such slots may
548  ;; override this function for their class
549  (mapcar #'ccl::slot-definition-name
550          (remove-if #'(lambda (eslot)
551                         (subtypep (type-of eslot) 'ccl::foreign-effective-slot-definition))
552                     (class-slots (class-of obj)))))
553
554(defmethod archive-slots ((obj standard-object))
555  ;; by default return a list of all non-foreign slots
556  ;; object classes that do not want to archive all such slots may
557  ;; override this function for their class
558  (arch-slots obj))
559
560(defmethod archive-slots ((obj structure-object))
561  ;; by default return a list of all non-foreign slots
562  ;; object classes that do not want to archive all such slots may
563  ;; override this function for their class
564  (arch-slots obj))
565
566;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
567;; Methods dealing with NSArray objects
568
569(defmacro do-objc-array ((arr-elt arr &optional (return t)) &rest body)
570  (let ((arr-indx (gensym)))
571    `(dotimes (,arr-indx (#/count ,arr) ,return)
572       (let ((,arr-elt (#/objectAtIndex: ,arr ,arr-indx)))
573         ,@body))))
574
575(defmethod ns-to-lisp-array ((ns-arr ns:ns-array) &key (element-class nil))
576  (let ((new-arr (make-array (list 0) :adjustable t :fill-pointer t)))
577    (do-objc-array (elt ns-arr new-arr)
578       (vector-push-extend (if (ccl::subclassp element-class ns:ns-object)
579                             elt
580                             (ns-to-lisp-object elt
581                                                :lisp-class element-class))
582                           new-arr))))
583
584(defmethod ns-to-lisp-list ((ns-arr ns:ns-array) &key (element-class nil))
585  (let ((new-list nil))
586    (do-objc-array (elt ns-arr (nreverse new-list))
587       (setf new-list 
588              (cons (if (ccl::subclassp element-class ns:ns-object)
589                      elt
590                      (ns-to-lisp-object elt
591                                         :lisp-class element-class))
592                    new-list)))))
593
594(defmethod lisp-to-ns-array ((lst list))
595  (let ((new-arr (#/arrayWithCapacity: ns:ns-mutable-array (list-length lst)))
596        (count -1))
597    (dolist (item lst new-arr)
598      (#/insertObject:atIndex: new-arr
599                               (lisp-to-ns-object item)
600                               (incf count)))))
601
602(defmethod lisp-to-ns-array ((arr array))
603  (let* ((max-count (if (array-has-fill-pointer-p arr)
604                     (fill-pointer arr)
605                     (length arr)))
606         (new-arr (#/arrayWithCapacity: ns:ns-mutable-array max-count)))
607    (do* ((count 0 (1+ count)))
608         ((>= count max-count) new-arr)
609      (#/insertObject:atIndex: new-arr
610                               (lisp-to-ns-object (aref arr count))
611                               count))))
612
613;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
614;; Methods dealing with NSDictionary objects
615
616(defmethod ns-to-lisp-hash-table ((dict ns:ns-dictionary) &key (element-class nil))
617  (let* ((dict-keys (ns-to-lisp-list (#/allKeys dict)
618                                                     :element-class ns:ns-object))
619         (ts (#/objectForKey: dict (lisp-to-ns-object "hash-table-size")))
620         (tab-size (if (%null-ptr-p ts) 60 (ns-to-lisp-object ts)))
621         (tt (#/objectForKey: dict (lisp-to-ns-object "hash-table-test")))
622         (tab-test (if (%null-ptr-p tt) 'eql (ns-to-lisp-object tt)))
623         (trs (#/objectForKey: dict (lisp-to-ns-object "hash-table-rehash-size")))
624         (tab-rehash-size (if (%null-ptr-p trs) 1.5 (ns-to-lisp-object trs)))
625         (trt (#/objectForKey: dict (lisp-to-ns-object "hash-table-rehash-threshold")))
626         (tab-rehash-threshold  (if (%null-ptr-p trt) 0.85 (ns-to-lisp-object trt)))
627         (ht (make-hash-table :test tab-test :size tab-size :rehash-size tab-rehash-size :rehash-threshold tab-rehash-threshold)))
628    (dolist (key dict-keys ht)
629      (let ((lisp-key (ns-to-lisp-object key)))
630        (unless (and (stringp lisp-key) (member lisp-key
631                                                (list "hash-table-size" 
632                                                      "hash-table-test"
633                                                      "hash-table-rehash-size"
634                                                      "hash-table-rehash-threshold")
635                                                :test #'string=))
636          (setf (gethash lisp-key ht)
637                (if (ccl::subclassp element-class ns:ns-object)
638                  (#/objectForKey: dict key)
639                  (ns-to-lisp-object (#/objectForKey: dict key)
640                                     :lisp-class element-class))))))))
641
642(defmethod ns-to-lisp-assoc ((dict ns:ns-dictionary) &key (element-class nil))
643  (let ((assoc-lst nil)
644        (dict-keys (ns-to-lisp-list (#/allKeys dict)
645                                    :element-class ns:ns-object)))
646    (dolist (key dict-keys assoc-lst)
647      (let ((lisp-key (ns-to-lisp-object key)))
648        (unless (and (stringp lisp-key) (member lisp-key
649                                                (list "hash-table-size" 
650                                                      "hash-table-test"
651                                                      "hash-table-rehash-size"
652                                                      "hash-table-rehash-threshold")
653                                                :test #'string=))
654          (setf assoc-lst
655            (acons lisp-key
656                   (if (ccl::subclassp element-class ns:ns-object)
657                     (#/objectForKey: dict key)
658                     (ns-to-lisp-object (#/objectForKey: dict key)
659                                        :lisp-class element-class))
660                   assoc-lst)))))))
661
662(defmethod lisp-to-ns-plist-dict ((ht hash-table))
663  (let* ((count (hash-table-count ht))
664         (new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count)))
665    (maphash #'(lambda (key val)
666                 (#/setObject:forKey: new-dict 
667                                      (lisp-to-ns-object val)
668                                      (lisp-to-ns-object key)))
669             ht)
670    new-dict))
671
672(defmethod lisp-to-ns-dict ((alist list))
673  ;; alist must be in the form of an association list
674  (let* ((count (list-length alist))
675         (new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count)))
676    (dolist (pair alist new-dict)
677      (#/setObject:forKey: new-dict 
678                           (lisp-to-ns-object (cdr pair))
679                           (lisp-to-ns-object (car pair))))))
680
681(defmethod lisp-to-ns-dict ((ht hash-table))
682  (let* ((count (hash-table-count ht))
683         (new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary (+ count 4))))
684    (maphash #'(lambda (key val)
685                 (#/setObject:forKey: new-dict 
686                                      (lisp-to-ns-object val)
687                                      (lisp-to-ns-object key)))
688             ht)
689    (#/setObject:forKey: new-dict 
690                         (lisp-to-ns-object (hash-table-size ht))
691                         (lisp-to-ns-object "hash-table-size"))
692    (#/setObject:forKey: new-dict 
693                         (lisp-to-ns-object (hash-table-test ht))
694                         (lisp-to-ns-object "hash-table-test"))
695    (#/setObject:forKey: new-dict 
696                         (lisp-to-ns-object (hash-table-rehash-size ht))
697                         (lisp-to-ns-object "hash-table-rehash-size"))
698    (#/setObject:forKey: new-dict 
699                         (lisp-to-ns-object (hash-table-rehash-threshold ht))
700                         (lisp-to-ns-object "hash-table-rehash-threshold"))
701    new-dict))
702
703(deftype objc-displayable () 
704  '(or string
705       (and atom 
706            (not sequence)
707            (not hash-table)
708            (not package) 
709            (not pathname)
710            (not random-state)
711            (not readtable)
712            (not array)
713            (not stream)
714            (not class)
715            (not structure-object)
716            (not standard-object)
717            (not macptr))))
718
719;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
720;; Methods dealing with conversion of lisp symbols
721;;
722;; Initially I implemented this as a concrete subclass of NSString, but it turned out that
723;; my #/initWithCoder: and #/encodeWithCoder: functions were never called when one of these
724;; was converted. It just encoded them as NSMutableStrings. So there is more than one way to
725;; skin a cat ...
726
727#|
728(defclass ns-sym (ns:ns-object)
729  ((sym :accessor sym :initarg :sym)
730   (ns-str :accessor ns-str)
731   (sym-name :accessor sym-name)
732   (sym-package :accessor sym-package))
733  (:metaclass ns:+ns-object))
734|#
735
736(defmethod initialize-instance :after ((self ns-sym) &key sym &allow-other-keys)
737  (setf (sym-name self) (symbol-name sym))
738  (setf (sym-package self) (symbol-package sym))
739  (setf (ns-str self) (ccl::%make-nsstring (format nil
740                                                   "~a:~a"
741                                                   (package-name (sym-package self))
742                                                   (sym-name self)))))
743
744(defmethod print-object ((self ns-sym) strm)
745  (print-unreadable-object (self strm :type t :identity t)
746    (format strm "~s" (sym self))))
747
748(objc:defmethod (#/dealloc :void)
749                ((self ns-sym))
750  (#/release (ns-str self))
751  (call-next-method)
752  (objc:remove-lisp-slots self))
753
754;; This method suffices to make an ns-sym act like an NSString if the runtime is 10.6 or higher
755(objc:defmethod (#/forwardingTargetForSelector: :id)
756                ((self ns-sym) (sel #>SEL))
757  (ns-str self))
758
759;; Otherwise the following two methods are needed
760
761(objc:defmethod (#/methodSignatureForSelector: :id)
762                ((self ns-sym) (sel #>SEL))
763  (#/methodSignatureForSelector: (ns-str self) sel))
764
765(objc:defmethod (#/forwardInvocation: :void)
766                ((self ns-sym) (inv :id))
767  (#/invokeWithTarget: inv (ns-str self)))
768
769(objc:defmethod (#/initWithCoder: :id)
770                ((self ns-sym) (decoder :id))
771  (let* ((sym-name (#/decodeObjectForKey: decoder #@"symName"))
772         (sym-pkg (#/decodeObjectForKey: decoder #@"symPkg"))
773         (pkg-str (ns-to-lisp-string sym-pkg)))
774    (setf (sym-name self) (ns-to-lisp-string sym-name))
775    (setf (sym-package self) (or (find-package pkg-str)
776                                 (make-package pkg-str)))
777    (setf (sym self) (intern (sym-name self) (sym-package self)))
778    (setf (ns-str self) (ccl::%make-nsstring (format nil
779                                                     "~@[~a:~]~a"
780                                                     (package-name (sym-package self))
781                                                     (sym-name self))))
782    self))
783
784(objc:defmethod (#/encodeWithCoder: :void)
785                ((self ns-sym) (coder :id))
786  (#/encodeObject:forKey: coder
787                          (lisp-to-temp-nsstring (sym-name self))
788                          #@"symName")
789  (#/encodeObject:forKey: coder 
790                          (lisp-to-temp-nsstring (package-name (sym-package self)))
791                          #@"symPkg"))
792
793(defmethod lisp-to-ns-sym ((sym symbol))
794  (#/autorelease (make-instance 'ns-sym :sym sym)))
795
796;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
797;; Methods dealing with conversion of lisp functions
798;;
799;; We save the function name so that it can be reconstituted when loaded back
800
801#|
802(defclass ns-func (ns:ns-object)
803  ((func :accessor func :initarg :func)
804   (ns-str :accessor ns-str)
805   (func-name :accessor func-name)
806   (func-package :accessor func-package))
807  (:metaclass ns:+ns-object))
808|#
809
810(defmethod initialize-instance :after ((self ns-func) &key func &allow-other-keys)
811  (setf (func-name self) (function-name func))
812  (setf (func-package self) (symbol-package (func-name self)))
813  (setf (ns-str self) (ccl::%make-nsstring (print-object self nil))))
814
815(defmethod print-object ((self ns-func) strm)
816  (format strm "(function ~a::~a)" (package-name (func-package self)) (func-name self)))
817
818(objc:defmethod (#/dealloc :void)
819                ((self ns-func))
820  (#/release (ns-str self))
821  (call-next-method)
822  (objc:remove-lisp-slots self))
823
824;; This method suffices to make an ns-func act like an NSString if the runtime is 10.6 or higher
825(objc:defmethod (#/forwardingTargetForSelector: :id)
826                ((self ns-func) (sel #>SEL))
827  (ns-str self))
828
829;; Otherwise the following two methods are needed
830
831(objc:defmethod (#/methodSignatureForSelector: :id)
832                ((self ns-func) (sel #>SEL))
833  (#/methodSignatureForSelector: (ns-str self) sel))
834
835(objc:defmethod (#/forwardInvocation: :void)
836                ((self ns-func) (inv :id))
837  (#/invokeWithTarget: inv (ns-str self)))
838
839(objc:defmethod (#/initWithCoder: :id)
840                ((self ns-func) (decoder :id))
841  (let* ((func-name (#/decodeObjectForKey: decoder #@"funcName"))
842         (func-pkg (#/decodeObjectForKey: decoder #@"funcPkg"))
843         (pkg-str (ns-to-lisp-string func-pkg)))
844    (setf (func-name self) (ns-to-lisp-string func-name))
845    (setf (func-package self) (or (find-package pkg-str)
846                                  (make-package pkg-str)))
847    (setf (func self) (symbol-function (intern (func-name self) (func-package self))))
848    (setf (ns-str self) (ccl::%make-nsstring (print-object self nil)))
849    self))
850
851(objc:defmethod (#/encodeWithCoder: :void)
852                ((self ns-func) (coder :id))
853  (#/encodeObject:forKey: coder
854                          (lisp-to-temp-nsstring (func-name self))
855                          #@"funcName")
856  (#/encodeObject:forKey: coder 
857                          (lisp-to-temp-nsstring (package-name (func-package self)))
858                          #@"funcPkg"))
859
860(defmethod lisp-to-ns-func ((func function))
861  (#/autorelease (make-instance 'ns-func :func func)))
862
863
864;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
865;; Methods dealing with conversion of miscellaneous lisp values that hopefully can
866;; be printed to and read from strings
867
868#|
869(defclass ns-misc (ns:ns-object)
870  ((obj :accessor obj :initarg :obj)
871   (obj-type :accessor obj-type)
872   (obj-str :accessor obj-str)
873   (ns-str :accessor ns-str))
874  (:metaclass ns:+ns-object))
875|#
876
877(defmethod initialize-instance :after ((self ns-misc) &key obj &allow-other-keys)
878  (setf (obj-str self) (format nil "~s" obj))
879  (setf (obj-type self) (type-of obj))
880  (setf (ns-str self) (ccl::%make-nsstring (obj-str self))))
881
882(defmethod print-object ((self ns-misc) strm)
883  (print-unreadable-object (self strm :type t :identity t)
884    (format strm "~s" (obj-str self))))
885
886(objc:defmethod (#/dealloc :void)
887                ((self ns-misc))
888  (#/release (ns-str self))
889  (call-next-method)
890  (objc:remove-lisp-slots self))
891
892;; This method suffices to make an ns-misc act like an NSString if the runtime is 10.6 or higher
893(objc:defmethod (#/forwardingTargetForSelector: :id)
894                ((self ns-misc) (sel #>SEL))
895  (ns-str self))
896
897;; Otherwise the following two methods are needed
898
899(objc:defmethod (#/methodSignatureForSelector: :id)
900                ((self ns-misc) (sel #>SEL))
901  (#/methodSignatureForSelector: (ns-str self) sel))
902
903(objc:defmethod (#/forwardInvocation: :void)
904                ((self ns-misc) (inv :id))
905  (#/invokeWithTarget: inv (ns-str self)))
906
907(objc:defmethod (#/initWithCoder: :id)
908                ((self ns-misc) (decoder :id))
909  (let* ((obj-type (coerce-obj (#/decodeObjectForKey: decoder #@"objType") t))
910         (obj-str (#/decodeObjectForKey: decoder #@"objString"))
911         (obj (when (member obj-type (list 'ns:ns-rect 'ns:ns-size 'ns:ns-point))
912                (coerce-obj (coerce-obj (#/decodeObjectForKey: decoder #@"objAsList") 'list) obj-type))))
913    (setf (obj-str self) (ns-to-lisp-string obj-str))
914    (setf (obj self) (or obj
915                         (if (unreadable-object-string-p (obj-str self))
916                           nil
917                           (read-from-string (obj-str self) nil nil))))
918    (setf (ns-str self) (#/retain obj-str))
919    self))
920
921(objc:defmethod (#/encodeWithCoder: :void)
922                ((self ns-misc) (coder :id))
923  (let ((typ (obj-type self)))
924    (#/encodeObject:forKey: coder
925                            (lisp-to-ns-sym typ)
926                            #@"objType")
927    (#/encodeObject:forKey: coder
928                            (ns-str self)
929                            #@"objString")
930    (when (member typ (list 'ns:ns-rect 'ns:ns-size 'ns:ns-point))
931      (#/encodeObject:forKey: coder
932                              (coerce-obj (coerce-obj (obj self) 'list) 'ns:ns-array)
933                              #@"objAsList"))))
934
935(defmethod lisp-to-ns-misc (obj)
936  (make-instance 'ns-misc :obj obj))
937
938;; methods dealing with NSSize and NSRect
939
940(defmethod equal-size-p ((sz1 ns:ns-size) (sz2 ns:ns-size))
941  (and (eql (ns:ns-size-width sz1) (ns:ns-size-width sz2))
942       (eql (ns:ns-size-height sz1) (ns:ns-size-height sz2))))
943
944(defmethod equal-size-p ((sz1 ns:ns-rect) (sz2 ns:ns-rect))
945  (and (eql (ns:ns-rect-width sz1) (ns:ns-rect-width sz2))
946       (eql (ns:ns-rect-height sz1) (ns:ns-rect-height sz2))))
947
948;; macro to force actions to happen on the main thread
949
950(defmacro on-main-thread (&rest actions)
951  `(ccl::call-in-event-process
952     #'(lambda ()
953         ,@actions)))
954
955(provide :ns-object-utils)
Note: See TracBrowser for help on using the repository browser.