src/signal-slot.lisp
Thu Jul 2 19:34:07 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-commonqt/src/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/src/signal-slot.lisp 2014-10-30 07:09:40.000000000 +0100
@@ -0,0 +1,131 @@
+;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;;
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-smoke.commonqt)
+
+(defclass class-info ()
+ ((key :initarg :key
+ :accessor entry-key)
+ (value :initarg :value
+ :accessor entry-value)))
+
+(defclass slot-or-signal ()
+ ((name :initarg :name
+ :accessor entry-name)
+ (full-name :initarg :full-name
+ :accessor entry-full-name)
+ (arg-types :initarg :arg-types
+ :accessor entry-arg-types)
+ (reply-type :initarg :reply-type
+ :accessor entry-reply-type)))
+
+(defun make-slot-or-signal (signature)
+ (let ((signature (#_data
+ (#_normalizedSignature "QMetaObject" signature))))
+ (cl-ppcre:register-groups-bind
+ (a b c d)
+ ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" signature)
+ (declare (ignore a))
+ (make-instance 'slot-or-signal
+ :name c
+ :full-name (concatenate 'string c "(" d ")")
+ :arg-types d
+ :reply-type (if (or (null b) (equal b "void")) "" b)))))
+
+(defconstant +access-protected+ #x01)
+(defconstant +access-public+ #x02)
+(defconstant +method-signal+ #x04)
+(defconstant +method-slot+ #x08)
+
+(cffi:defcstruct qmeta-object
+ "QMetaObject (a POD struct)"
+ (super-data :pointer)
+ (string-data :pointer)
+ (data :pointer)
+ (extra-data :pointer))
+
+(defun make-metaobject (parent class-name class-infos signals slots)
+ (let ((data (make-array 0 :fill-pointer 0 :adjustable t))
+ (table (make-hash-table))
+ (stream (make-string-output-stream)))
+ (labels ((intern-string (s)
+ (or (gethash s table)
+ (setf (gethash s table)
+ (prog1
+ (file-position stream)
+ (write-string s stream)
+ (write-char (code-char 0) stream)))))
+ (add (x) (vector-push-extend x data))
+ (add-string (s) (add (intern-string s))))
+ (add 1) ;revision
+ (add (intern-string class-name)) ;class name
+ (add (length class-infos)) ;classinfo
+ (add (if (plusp (length class-infos)) 10 0))
+ (add (+ (length signals) (length slots)))
+ (add (+ 10 (* 2 (length class-infos)))) ;methods
+ (add 0) ;properties
+ (add 0)
+ (add 0) ;enums/sets
+ (add 0)
+ (dolist (entry class-infos)
+ (add-string (entry-key entry))
+ (add-string (entry-value entry)))
+ (dolist (entry signals)
+ (add-string (entry-full-name entry))
+ (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
+ (add-string (entry-reply-type entry))
+ (add-string "") ;tag
+ (add (logior +method-signal+ +access-protected+)))
+ (dolist (entry slots)
+ (add-string (entry-full-name entry))
+ (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
+ (add-string (entry-reply-type entry))
+ (add-string "") ;tag
+ (add (logior +method-slot+ +access-public+)))
+ (add 0))
+ (let ((dataptr (cffi:foreign-alloc :int :count (length data))))
+ (dotimes (i (length data))
+ (setf (cffi:mem-aref dataptr :int i) (elt data i)))
+ (let ((meta-struct (cffi:foreign-alloc 'qmeta-object))
+ (parent-meta-object (#_staticMetaObject parent)))
+ (setf (foreign-slot-value meta-struct 'qmeta-object 'super-data)
+ (smoke:pointer parent-meta-object)
+
+ (foreign-slot-value meta-struct 'qmeta-object 'string-data)
+ (foreign-string-alloc (get-output-stream-string stream))
+
+ (foreign-slot-value meta-struct 'qmeta-object 'data)
+ dataptr
+
+ (foreign-slot-value meta-struct 'qmeta-object 'extra-data)
+ (null-pointer))
+ (let ((meta-object (make-instance 'cl-smoke.qt:meta-object
+ :pointer meta-struct)))
+
+ ;; PARENT-META-OBJECT must remain valid during the lifetime
+ ;; of META-OBJECT.
+ (push parent-meta-object (smoke::owned-objects meta-object))
+ meta-object)))))