Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

ns-object-utils.lisp

Visit:

Last change on this file was 16203, checked in by R. Matthew Emerson, 10 years ago
Merge from trunk (see r16202 in particular)
File size: 42.1 KB

Rev	Line
[13631]	1	;; ns-object-utils.lisp
	2	#\|
	3	The MIT license.
	4
	5	Copyright (c) 2010 Paul L. Krueger
	6
	7	Permission is hereby granted, free of charge, to any person obtaining a copy of this software
	8	and associated documentation files (the "Software"), to deal in the Software without restriction,
	9	including without limitation the rights to use, copy, modify, merge, publish, distribute,
	10	sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
	11	furnished to do so, subject to the following conditions:
	12
	13	The above copyright notice and this permission notice shall be included in all copies or substantial
	14	portions of the Software.
	15
	16	THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
	17	LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
	18	IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
	19	WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
	20	SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
	21
	22	\|#
	23
[14585]	24	(eval-when (:compile-toplevel :load-toplevel :execute)
[15808]	25	(require :iu-classes)
[14585]	26	(require :ns-string-utils)
[15808]	27	(require :binding-utils)
[14585]	28	(require :nslog-utils)
	29	(require :date)
	30	(require :alert)
	31	(require :decimal)
[14828]	32	(require :assoc-array)
	33	(require :attributed-strings))
[14585]	34
[13631]	35	(in-package :iu)
	36
[15808]	37	;;;;;;;;;;;;;;;;;;;;;;;
	38	;;; Global variable
	39
	40	(defvar debug-convert nil)
[16203]	41	(defvar minimal-hash-table-encoding nil)
[15808]	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
[13631]	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
[14585]	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)))
[15808]	121	(if (string-equal lisp-name prev-base)
[14585]	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))
[13631]	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
[15808]	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
[13631]	154	ns-obj)
[15808]	155	((or (eql ns-obj (%null-ptr))
	156	(eql ns-obj #$NSNoSelectionMarker)
	157	(eql ns-obj #$NSNullPlaceholderBindingOption)
	158	(eql ns-obj #$NSNotApplicablePlaceholderBindingOption))
[14585]	159	(if (ccl::subclassp lisp-class (find-class 'string))
	160	""
	161	nil))
[13631]	162	((typep ns-obj 'lisp-ptr-wrapper)
	163	;; just strip the wrapper and return the original object
	164	(lpw-lisp-ptr ns-obj))
[14585]	165	((typep ns-obj 'ns-sym)
	166	(sym ns-obj))
	167	((typep ns-obj 'ns-misc)
	168	(obj ns-obj))
[14828]	169	((typep ns-obj 'ns-func)
	170	(func ns-obj))
[14632]	171	((typep ns-obj 'ns:ns-decimal-number)
[14585]	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)
[14632]	181	(if (and (listp ns-format) (eq (first ns-format) :decimal))
[14585]	182	(lisp-from-ns-decimal ns-obj :decimals (second ns-format))
	183	(lisp-from-ns-decimal ns-obj)))))
[15808]	184	((typep ns-obj 'ns:ns-url)
	185	(ns-to-lisp-string (if (#/isFileURL ns-obj)
	186	(#/path ns-obj)
	187	(#/absoluteString ns-obj))))
[13631]	188	((typep ns-obj 'ns:ns-number)
[14632]	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))
[14585]	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))
[14632]	201	((ccl::subclassp lisp-class (find-class 'integer))
[14585]	202	;; convert the number to an integer
[14632]	203	(#/longLongValue ns-obj))
	204	((ccl::subclassp lisp-class (find-class 'ratio))
	205	;; convert the number to an integer
	206	(#/floatValue ns-obj))
[14585]	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))))
[13631]	220	((typep ns-obj 'ns:ns-date)
	221	(ns-to-lisp-date ns-obj))
[14585]	222	((typep ns-obj 'lisp-object-reference)
	223	(objc-to-std-instance ns-obj))
[13673]	224	((typep ns-obj 'ns:ns-dictionary)
[14585]	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))))
[13673]	229	((typep ns-obj 'ns:ns-array)
[15808]	230	(if (or (ccl::subclassp lisp-class (find-class 'list))
	231	(eq lisp-class (find-class 'null))) ;; assume they want a list
[13673]	232	(ns-to-lisp-list ns-obj)
	233	(ns-to-lisp-array ns-obj)))
[14828]	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))))
[13673]	239	((typep ns-obj 'ns:ns-string)
[14585]	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))
[14591]	245	((ccl::subclassp lisp-class (find-class 'number))
	246	(let ((num (read-from-string lisp-str :nil 0)))
	247	(if (numberp num)
	248	num
[15808]	249	lisp-str)))
[14585]	250	(t
	251	lisp-str))))
[13673]	252	((typep ns-obj 'ns:ns-null)
	253	nil)
	254	(t
	255	;; can't convert so just return ns-obj
	256	ns-obj)))
[13631]	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
[15808]	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)
[13631]	275	;; it's already an NSObject so just return it
	276	lisp-obj)
[15808]	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))
[13631]	285	((eq ns-format :date)
[15808]	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)))
[14828]	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))))
[13631]	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)))))
[14585]	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))
[13631]	317	((typep lisp-obj 'double-float)
	318	(#/numberWithDouble: ns:ns-number lisp-obj))
	319	((floatp lisp-obj)
	320	(#/numberWithFloat: ns:ns-number lisp-obj))
[14632]	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))))
[14585]	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))
[13673]	338	((stringp lisp-obj)
[14828]	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)))
[13673]	343	((hash-table-p lisp-obj)
	344	(lisp-to-ns-dict lisp-obj))
[14585]	345	((or (vectorp lisp-obj) (consp lisp-obj))
[13673]	346	(lisp-to-ns-array lisp-obj))
[14585]	347	((or (typep lisp-obj 'standard-object)
	348	(typep lisp-obj 'structure-object))
	349	(std-instance-to-objc lisp-obj))
[14828]	350	((typep lisp-obj 'function)
	351	(lisp-to-ns-func lisp-obj))
[13631]	352	(t
[14585]	353	(lisp-to-ns-misc lisp-obj))))
[13631]	354
	355	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14585]	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
[15808]	415	;; lisp-object-reference: A class that encapsulates references to other instances so that we can have circular
[14585]	416	;; references.
	417
[15808]	418	#\|
[14585]	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))
[15808]	423	\|#
[14585]	424
	425	(defmethod initialize-instance :after ((self lisp-object-reference) &key obj-dict &allow-other-keys)
[15808]	426	(when debug-convert
	427	(ns-log-format "Initializing lisp-object-reference for ~s" self))
[14585]	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))
[15808]	435	(#/release obj-dict)))
	436	(call-next-method)
	437	(objc:remove-lisp-slots self))
[14585]	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)
[15808]	451	(when debug-convert
	452	(ns-log-format "Finding or creating lisp-object-reference for ~s" obj))
[14585]	453	(or (converted-object obj)
	454	(let* ((slots (archive-slots obj))
[14828]	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)))
[14585]	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
[14828]	470	(lisp-to-ns-object slot-val :archive)
[14585]	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)
[15808]	491	(when debug-convert
	492	(ns-log-format "Converting ~s to std-instance~@[ (using existing ~s)~]" ref new-instance))
[14585]	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	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[13673]	567	;; Methods dealing with NSArray objects
	568
[14585]	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))))
[13673]	574
[14585]	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))
[13673]	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
[16203]	616	(defmethod ns-to-lisp-hash-table ((dict ns:ns-dictionary) &key (element-class nil) (test nil))
[16077]	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")))
[16203]	622	(tab-test (or test (if (%null-ptr-p tt) 'eql (ns-to-lisp-object tt))))
[16077]	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)))
[13673]	628	(dolist (key dict-keys ht)
[16077]	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))))))))
[13673]	641
[14585]	642	(defmethod ns-to-lisp-assoc ((dict ns:ns-dictionary) &key (element-class nil))
[13673]	643	(let ((assoc-lst nil)
[14585]	644	(dict-keys (ns-to-lisp-list (#/allKeys dict)
	645	:element-class ns:ns-object)))
[13673]	646	(dolist (key dict-keys assoc-lst)
[16077]	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
[14585]	656	(if (ccl::subclassp element-class ns:ns-object)
[13673]	657	(#/objectForKey: dict key)
[14585]	658	(ns-to-lisp-object (#/objectForKey: dict key)
	659	:lisp-class element-class))
[16077]	660	assoc-lst)))))))
[13673]	661
[16179]	662	(defmethod lisp-to-ns-plist-dict ((ht hash-table))
[16203]	663	;; arrays put in info.plist files have become picky about allowing any fields that
	664	;; are not expected, so we can't add extraneous fields to support hash table attributes
	665	;; because the write to the info.plist file will fail. So this routing does a vanilla
	666	;; encoding of any hash-table that we used in lisp that will end up as part of an info
	667	;; plist file. That includes any sub-fields.
[16179]	668	(let* ((count (hash-table-count ht))
[16203]	669	(new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count))
	670	(minimal-hash-table-encoding t))
[16179]	671	(maphash #'(lambda (key val)
	672	(#/setObject:forKey: new-dict
	673	(lisp-to-ns-object val)
	674	(lisp-to-ns-object key)))
	675	ht)
	676	new-dict))
	677
[13673]	678	(defmethod lisp-to-ns-dict ((alist list))
	679	;; alist must be in the form of an association list
	680	(let* ((count (list-length alist))
	681	(new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count)))
	682	(dolist (pair alist new-dict)
	683	(#/setObject:forKey: new-dict
[14585]	684	(lisp-to-ns-object (cdr pair))
	685	(lisp-to-ns-object (car pair))))))
[13673]	686
	687	(defmethod lisp-to-ns-dict ((ht hash-table))
	688	(let* ((count (hash-table-count ht))
[16077]	689	(new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary (+ count 4))))
[13673]	690	(maphash #'(lambda (key val)
	691	(#/setObject:forKey: new-dict
[14585]	692	(lisp-to-ns-object val)
	693	(lisp-to-ns-object key)))
[13673]	694	ht)
[16203]	695	(unless minimal-hash-table-encoding
	696	(#/setObject:forKey: new-dict
	697	(lisp-to-ns-object (hash-table-size ht))
	698	(lisp-to-ns-object "hash-table-size"))
	699	(#/setObject:forKey: new-dict
	700	(lisp-to-ns-object (hash-table-test ht))
	701	(lisp-to-ns-object "hash-table-test"))
	702	(#/setObject:forKey: new-dict
	703	(lisp-to-ns-object (hash-table-rehash-size ht))
	704	(lisp-to-ns-object "hash-table-rehash-size"))
	705	(#/setObject:forKey: new-dict
	706	(lisp-to-ns-object (hash-table-rehash-threshold ht))
	707	(lisp-to-ns-object "hash-table-rehash-threshold")))
[13673]	708	new-dict))
	709
[14585]	710	(deftype objc-displayable ()
	711	'(or string
	712	(and atom
	713	(not sequence)
	714	(not hash-table)
	715	(not package)
	716	(not pathname)
	717	(not random-state)
	718	(not readtable)
	719	(not array)
	720	(not stream)
	721	(not class)
	722	(not structure-object)
	723	(not standard-object)
	724	(not macptr))))
	725
[13673]	726	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14585]	727	;; Methods dealing with conversion of lisp symbols
	728	;;
	729	;; Initially I implemented this as a concrete subclass of NSString, but it turned out that
	730	;; my #/initWithCoder: and #/encodeWithCoder: functions were never called when one of these
	731	;; was converted. It just encoded them as NSMutableStrings. So there is more than one way to
	732	;; skin a cat ...
	733
[15808]	734	#\|
[14585]	735	(defclass ns-sym (ns:ns-object)
	736	((sym :accessor sym :initarg :sym)
	737	(ns-str :accessor ns-str)
	738	(sym-name :accessor sym-name)
	739	(sym-package :accessor sym-package))
	740	(:metaclass ns:+ns-object))
[15808]	741	\|#
[14585]	742
	743	(defmethod initialize-instance :after ((self ns-sym) &key sym &allow-other-keys)
	744	(setf (sym-name self) (symbol-name sym))
	745	(setf (sym-package self) (symbol-package sym))
	746	(setf (ns-str self) (ccl::%make-nsstring (format nil
	747	"~a:~a"
	748	(package-name (sym-package self))
	749	(sym-name self)))))
	750
	751	(defmethod print-object ((self ns-sym) strm)
	752	(print-unreadable-object (self strm :type t :identity t)
	753	(format strm "~s" (sym self))))
	754
	755	(objc:defmethod (#/dealloc :void)
	756	((self ns-sym))
	757	(#/release (ns-str self))
[15808]	758	(call-next-method)
	759	(objc:remove-lisp-slots self))
[14585]	760
	761	;; This method suffices to make an ns-sym act like an NSString if the runtime is 10.6 or higher
	762	(objc:defmethod (#/forwardingTargetForSelector: :id)
	763	((self ns-sym) (sel #>SEL))
	764	(ns-str self))
	765
	766	;; Otherwise the following two methods are needed
	767
	768	(objc:defmethod (#/methodSignatureForSelector: :id)
	769	((self ns-sym) (sel #>SEL))
	770	(#/methodSignatureForSelector: (ns-str self) sel))
	771
	772	(objc:defmethod (#/forwardInvocation: :void)
	773	((self ns-sym) (inv :id))
	774	(#/invokeWithTarget: inv (ns-str self)))
	775
	776	(objc:defmethod (#/initWithCoder: :id)
	777	((self ns-sym) (decoder :id))
	778	(let* ((sym-name (#/decodeObjectForKey: decoder #@"symName"))
	779	(sym-pkg (#/decodeObjectForKey: decoder #@"symPkg"))
	780	(pkg-str (ns-to-lisp-string sym-pkg)))
	781	(setf (sym-name self) (ns-to-lisp-string sym-name))
	782	(setf (sym-package self) (or (find-package pkg-str)
	783	(make-package pkg-str)))
	784	(setf (sym self) (intern (sym-name self) (sym-package self)))
	785	(setf (ns-str self) (ccl::%make-nsstring (format nil
	786	"~@[~a:~]~a"
	787	(package-name (sym-package self))
	788	(sym-name self))))
	789	self))
	790
	791	(objc:defmethod (#/encodeWithCoder: :void)
	792	((self ns-sym) (coder :id))
	793	(#/encodeObject:forKey: coder
	794	(lisp-to-temp-nsstring (sym-name self))
	795	#@"symName")
	796	(#/encodeObject:forKey: coder
	797	(lisp-to-temp-nsstring (package-name (sym-package self)))
	798	#@"symPkg"))
	799
	800	(defmethod lisp-to-ns-sym ((sym symbol))
[14828]	801	(#/autorelease (make-instance 'ns-sym :sym sym)))
[14585]	802
	803	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14828]	804	;; Methods dealing with conversion of lisp functions
	805	;;
	806	;; We save the function name so that it can be reconstituted when loaded back
	807
[15808]	808	#\|
[14828]	809	(defclass ns-func (ns:ns-object)
	810	((func :accessor func :initarg :func)
	811	(ns-str :accessor ns-str)
	812	(func-name :accessor func-name)
	813	(func-package :accessor func-package))
	814	(:metaclass ns:+ns-object))
[15808]	815	\|#
[14828]	816
	817	(defmethod initialize-instance :after ((self ns-func) &key func &allow-other-keys)
	818	(setf (func-name self) (function-name func))
	819	(setf (func-package self) (symbol-package (func-name self)))
	820	(setf (ns-str self) (ccl::%make-nsstring (print-object self nil))))
	821
	822	(defmethod print-object ((self ns-func) strm)
	823	(format strm "(function ~a::~a)" (package-name (func-package self)) (func-name self)))
	824
	825	(objc:defmethod (#/dealloc :void)
	826	((self ns-func))
	827	(#/release (ns-str self))
[15808]	828	(call-next-method)
	829	(objc:remove-lisp-slots self))
[14828]	830
	831	;; This method suffices to make an ns-func act like an NSString if the runtime is 10.6 or higher
	832	(objc:defmethod (#/forwardingTargetForSelector: :id)
	833	((self ns-func) (sel #>SEL))
	834	(ns-str self))
	835
	836	;; Otherwise the following two methods are needed
	837
	838	(objc:defmethod (#/methodSignatureForSelector: :id)
	839	((self ns-func) (sel #>SEL))
	840	(#/methodSignatureForSelector: (ns-str self) sel))
	841
	842	(objc:defmethod (#/forwardInvocation: :void)
	843	((self ns-func) (inv :id))
	844	(#/invokeWithTarget: inv (ns-str self)))
	845
	846	(objc:defmethod (#/initWithCoder: :id)
	847	((self ns-func) (decoder :id))
	848	(let* ((func-name (#/decodeObjectForKey: decoder #@"funcName"))
	849	(func-pkg (#/decodeObjectForKey: decoder #@"funcPkg"))
	850	(pkg-str (ns-to-lisp-string func-pkg)))
	851	(setf (func-name self) (ns-to-lisp-string func-name))
	852	(setf (func-package self) (or (find-package pkg-str)
	853	(make-package pkg-str)))
	854	(setf (func self) (symbol-function (intern (func-name self) (func-package self))))
	855	(setf (ns-str self) (ccl::%make-nsstring (print-object self nil)))
	856	self))
	857
	858	(objc:defmethod (#/encodeWithCoder: :void)
	859	((self ns-func) (coder :id))
	860	(#/encodeObject:forKey: coder
	861	(lisp-to-temp-nsstring (func-name self))
	862	#@"funcName")
	863	(#/encodeObject:forKey: coder
	864	(lisp-to-temp-nsstring (package-name (func-package self)))
	865	#@"funcPkg"))
	866
	867	(defmethod lisp-to-ns-func ((func function))
	868	(#/autorelease (make-instance 'ns-func :func func)))
	869
	870
	871	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14585]	872	;; Methods dealing with conversion of miscellaneous lisp values that hopefully can
	873	;; be printed to and read from strings
	874
[15808]	875	#\|
[14585]	876	(defclass ns-misc (ns:ns-object)
	877	((obj :accessor obj :initarg :obj)
[15808]	878	(obj-type :accessor obj-type)
[14585]	879	(obj-str :accessor obj-str)
	880	(ns-str :accessor ns-str))
	881	(:metaclass ns:+ns-object))
[15808]	882	\|#
[14585]	883
	884	(defmethod initialize-instance :after ((self ns-misc) &key obj &allow-other-keys)
	885	(setf (obj-str self) (format nil "~s" obj))
[15808]	886	(setf (obj-type self) (type-of obj))
[14585]	887	(setf (ns-str self) (ccl::%make-nsstring (obj-str self))))
	888
	889	(defmethod print-object ((self ns-misc) strm)
	890	(print-unreadable-object (self strm :type t :identity t)
	891	(format strm "~s" (obj-str self))))
	892
	893	(objc:defmethod (#/dealloc :void)
	894	((self ns-misc))
	895	(#/release (ns-str self))
[15808]	896	(call-next-method)
	897	(objc:remove-lisp-slots self))
[14585]	898
	899	;; This method suffices to make an ns-misc act like an NSString if the runtime is 10.6 or higher
	900	(objc:defmethod (#/forwardingTargetForSelector: :id)
	901	((self ns-misc) (sel #>SEL))
	902	(ns-str self))
	903
	904	;; Otherwise the following two methods are needed
	905
	906	(objc:defmethod (#/methodSignatureForSelector: :id)
[14828]	907	((self ns-misc) (sel #>SEL))
[14585]	908	(#/methodSignatureForSelector: (ns-str self) sel))
	909
	910	(objc:defmethod (#/forwardInvocation: :void)
[14828]	911	((self ns-misc) (inv :id))
[14585]	912	(#/invokeWithTarget: inv (ns-str self)))
	913
	914	(objc:defmethod (#/initWithCoder: :id)
	915	((self ns-misc) (decoder :id))
[15808]	916	(let* ((obj-type (coerce-obj (#/decodeObjectForKey: decoder #@"objType") t))
	917	(obj-str (#/decodeObjectForKey: decoder #@"objString"))
	918	(obj (when (member obj-type (list 'ns:ns-rect 'ns:ns-size 'ns:ns-point))
	919	(coerce-obj (coerce-obj (#/decodeObjectForKey: decoder #@"objAsList") 'list) obj-type))))
[14585]	920	(setf (obj-str self) (ns-to-lisp-string obj-str))
[15808]	921	(setf (obj self) (or obj
	922	(if (unreadable-object-string-p (obj-str self))
	923	nil
	924	(read-from-string (obj-str self) nil nil))))
[14585]	925	(setf (ns-str self) (#/retain obj-str))
	926	self))
	927
	928	(objc:defmethod (#/encodeWithCoder: :void)
	929	((self ns-misc) (coder :id))
[15808]	930	(let ((typ (obj-type self)))
	931	(#/encodeObject:forKey: coder
	932	(lisp-to-ns-sym typ)
	933	#@"objType")
	934	(#/encodeObject:forKey: coder
	935	(ns-str self)
	936	#@"objString")
	937	(when (member typ (list 'ns:ns-rect 'ns:ns-size 'ns:ns-point))
	938	(#/encodeObject:forKey: coder
	939	(coerce-obj (coerce-obj (obj self) 'list) 'ns:ns-array)
	940	#@"objAsList"))))
[14585]	941
	942	(defmethod lisp-to-ns-misc (obj)
	943	(make-instance 'ns-misc :obj obj))
	944
[15808]	945	;; methods dealing with NSSize and NSRect
	946
	947	(defmethod equal-size-p ((sz1 ns:ns-size) (sz2 ns:ns-size))
	948	(and (eql (ns:ns-size-width sz1) (ns:ns-size-width sz2))
	949	(eql (ns:ns-size-height sz1) (ns:ns-size-height sz2))))
	950
	951	(defmethod equal-size-p ((sz1 ns:ns-rect) (sz2 ns:ns-rect))
	952	(and (eql (ns:ns-rect-width sz1) (ns:ns-rect-width sz2))
	953	(eql (ns:ns-rect-height sz1) (ns:ns-rect-height sz2))))
	954
	955	;; macro to force actions to happen on the main thread
	956
	957	(defmacro on-main-thread (&rest actions)
	958	`(ccl::call-in-event-process
	959	#'(lambda ()
	960	,@actions)))
	961
[13631]	962	(provide :ns-object-utils)

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: release/1.10/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp

Download in other formats: