From: Dmitry Kalyanov Date: Fri, 29 Jan 2010 23:13:07 +0000 (+0300) Subject: Added gtype and tests X-Git-Url: http://repo.macrolet.net/gitweb/?p=cl-gtk2.git;a=commitdiff_plain;h=db7c4d0c9eb2f2bead482bd0341a456a68a655a1 Added gtype and tests --- diff --git a/glib/gobject.ffi.package.lisp b/glib/gobject.ffi.package.lisp index 7cfcc34..a2af983 100644 --- a/glib/gobject.ffi.package.lisp +++ b/glib/gobject.ffi.package.lisp @@ -1,5 +1,5 @@ (defpackage :gobject.ffi - (:use :cl :cffi :glib :trivial-garbage) + (:use :cl :cffi :glib :trivial-garbage :iter) (:export #:g-type #:g-type-designator #:g-type-name diff --git a/glib/gobject.type-designator.lisp b/glib/gobject.type-designator.lisp index 5468403..d31af2e 100644 --- a/glib/gobject.type-designator.lisp +++ b/glib/gobject.type-designator.lisp @@ -2,6 +2,86 @@ (defctype g-type gsize) +(defstruct gtype name %id) + +(defvar *name-to-gtype* (make-hash-table :test 'equal)) +(defvar *id-to-gtype* (make-hash-table)) +(defvar *gtype-lock* (bt:make-lock "gtype lock")) + +(defun invalidate-gtypes () + (bt:with-lock-held (*gtype-lock*) + (clrhash *id-to-gtype*) + (iter (for (name gtype) in-hashtable *name-to-gtype*) + (setf (gtype-%id gtype) nil)))) + +(at-finalize () (invalidate-gtypes)) + +(defcfun (%g-type-from-name "g_type_from_name") g-type + (name :string)) + +(defcfun (%g-type-name "g_type_name") (:string :free-from-foreign nil) + (type g-type)) + +(defun gtype-from-name (name) + (when (null name) (return-from gtype-from-name nil)) + (bt:with-lock-held (*gtype-lock*) + (let ((type (gethash name *name-to-gtype*))) + (when type + (when (null (gtype-%id type)) + (let ((n (%g-type-from-name name))) + (if (zerop n) + (warn "GType ~A is not known to GObject" name) + (progn + (setf (gtype-%id type) n + (gethash n *id-to-gtype*) type))))) + (return-from gtype-from-name type))) + (let ((n (%g-type-from-name name))) + (when (zerop n) + (warn "GType ~A is not known to GObject" name) + (setf n nil)) + (let ((type (make-gtype :name (copy-seq name) :%id n))) + (setf (gethash n *id-to-gtype*) type + (gethash name *name-to-gtype*) type) + (return-from gtype-from-name type))))) + +(defun gtype-from-id (id) + (when (zerop id) (return-from gtype-from-id nil)) + (bt:with-lock-held (*gtype-lock*) + (let ((type (gethash id *id-to-gtype*))) + (when type + (return-from gtype-from-id type))) + (let ((name (%g-type-name id))) + (unless name + (error "GType with ~A is not known to GObject" id)) + (let ((type (gethash name *name-to-gtype*))) + (when type + (setf (gtype-%id type) id + (gethash id *id-to-gtype*) type) + (return-from gtype-from-id type)) + (let ((type (make-gtype :name name :%id id))) + (setf (gethash id *id-to-gtype*) type + (gethash name *name-to-gtype*) type) + (return-from gtype-from-id type)))))) + +(defun gtype-id (gtype) + (when (null gtype) (return-from gtype-id 0)) + (when (gtype-%id gtype) (return-from gtype-id (gtype-%id gtype))) + (bt:with-lock-held (*gtype-lock*) + (let ((n (%g-type-from-name (gtype-name gtype)))) + (when (zerop n) + (warn "GType ~A is not known to GObject" (gtype-name gtype)) + (return-from gtype-id 0)) + (setf (gtype-%id gtype) n + (gethash n *id-to-gtype*) gtype) + n))) + +(defun gtype (thing) + (etypecase thing + (null nil) + (gtype thing) + (string (gtype-from-name thing)) + (integer (gtype-from-id thing)))) + (define-foreign-type g-type-designator () ((mangled-p :initarg :mangled-p :reader g-type-designator-mangled-p diff --git a/glib/gobject.type-tests.lisp b/glib/gobject.type-tests.lisp new file mode 100644 index 0000000..b073963 --- /dev/null +++ b/glib/gobject.type-tests.lisp @@ -0,0 +1,64 @@ +(defpackage #:gtype-tests + (:use #:cl #:iter #:gobject #:gobject.ffi #:5am) + (:export #:run-all-tests) + (:import-from #:gobject.ffi #:gtype #:gtype-name #:gtype-%id #:gtype-id #:invalidate-gtypes)) + +(in-package #:gtype-tests) + +(def-suite gtype) + +(in-suite gtype) + +(defun run-all-tests () + (run! 'gtype)) + +;; Normal things + +(test normal.1 + (finishes (gtype "gint")) + (finishes (gtype "glong")) + (finishes (gtype +g-type-pointer+))) + +(test normal.eq + (is (eq (gtype "gint") (gtype "gint"))) + (is (eq (gtype "GObject") (gtype "GObject"))) + (is (not (eq (gtype "gint") (gtype "GObject")))) + (is (eq (gtype "gchararray") (gtype +g-type-string+)))) + +(test normal.boundary + (is (null (gtype 0))) + (is (null (gtype nil))) + (signals warning (gtype "foobarbaz")) + (signals error (gtype 1))) + +(test normal.trans + (is (string= (gtype-name (gtype "gint")) "gint")) + (is (eql (gtype-id (gtype "gint")) +g-type-int+))) + +;; Clear mappings + +(test clear.simple + (let ((type (gtype "gint"))) + (is (eql (gtype-id type) +g-type-int+)) + (invalidate-gtypes) + (is (null (gtype-%id type))) + (is (eql (gtype-id type) +g-type-int+)) + (invalidate-gtypes) + (is (eq type (gtype "gint"))) + (invalidate-gtypes) + (is (eq type (gtype +g-type-int+))))) + +(test clear.1 + (let ((type (gtype "gint"))) + (invalidate-gtypes) + (is (null (gtype-%id type))) + (gtype +g-type-int+) + (is (not (null (gethash +g-type-int+ gobject.ffi::*id-to-gtype*)))) + (is (not (null (gtype-%id type)))))) + +;; Core saving + +(defvar *gi* (gtype +g-type-int+)) + +(test core.saving + (is (eq *gi* (gtype +g-type-int+)))) diff --git a/glib/gobject.type-tests.sh b/glib/gobject.type-tests.sh new file mode 100755 index 0000000..807d9ae --- /dev/null +++ b/glib/gobject.type-tests.sh @@ -0,0 +1,4 @@ +#!/bin/sh +sbcl --eval "(asdf:oos 'asdf:load-op :cl-gtk2-gtk)" --eval "(asdf:oos 'asdf:load-op :fiveam)" --load gobject.type-tests.lisp --eval '(sb-ext:save-lisp-and-die "/tmp/sbcl-type-tests-core" :executable t)' +/tmp/sbcl-type-tests-core --eval "(gtype-tests:run-all-tests)" --eval "(quit)" +rm /tmp/sbcl-type-tests-core \ No newline at end of file