1;; guile-gnome 2;; Copyright (C) 2003,2004,2015 Andy Wingo <wingo at pobox dot com> 3;; Copyright (C) 2001 Martin Baulig <martin@gnome.org> 4 5;; This program is free software; you can redistribute it and/or 6;; modify it under the terms of the GNU General Public License as 7;; published by the Free Software Foundation; either version 2 of 8;; the License, or (at your option) any later version. 9;; 10;; This program is distributed in the hope that it will be useful, 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13;; GNU General Public License for more details. 14;; 15;; You should have received a copy of the GNU General Public License 16;; along with this program; if not, contact: 17;; 18;; Free Software Foundation Voice: +1-617-542-5942 19;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 20;; Boston, MA 02111-1307, USA gnu@gnu.org 21 22;;; Commentary: 23;; 24;; GObject is what is commonly understood as @emph{the} object system 25;; for GLib. This is not strictly true. GObject is @emph{one} 26;; implementation of an object system, built on the other modules: 27;; GType, GValue, GParameter, GClosure, and GSignal. 28;; 29;; Similarly, this Guile module provides integration with the GObject 30;; object system, built on the Guile modules that support GType, GValue, 31;; GParameter, GClosure, and GSignal. 32;; 33;; The main class exported by this module is @code{<gobject>}. 34;; @code{<gobject>} classes can be subclassed by the user, which will 35;; register new subtypes with the GType runtime type system. 36;; @code{<gobject>} classes are are also created as needed when wrapping 37;; GObjects that come from C, for example from a function's return 38;; value. 39;; 40;; Besides supporting derivation, and signals like other 41;; @code{<gtype-instance>} implementations, @code{<gobject>} has the 42;; concept of @dfn{properties}, which are @code{<gvalue>}'s associated 43;; with the object. The values are constrained by @code{<gparam>}'s, 44;; which are associated with the object's class. This module exports the 45;; necessary routines to query, get, and set @code{<gobject>} 46;; properties. 47;; 48;; In addition, this module defines the @code{<ginterface>} base class, 49;; whose subclasses may be present as mixins of @code{<gobject>} 50;; classes. For example: 51;; 52;; @lisp 53;; (use-modules (gnome gtk) (oop goops)) 54;; (class-direct-supers <gtk-widget>) @result{} 55;; (#<<gobject-class> <atk-implementor-iface> 3033bad0> 56;; #<<gobject-class> <gtk-object> 3034bc90>) 57;; @end lisp 58;; 59;; In this example, we see that @code{<gtk-widget>} has two 60;; superclasses, @code{<gtk-object>} and @code{<atk-implementor-iface>}. 61;; The second is an interface implemented by the @code{<gtk-widget>} 62;; class. See @code{gtype-interfaces} for more details. 63;; 64;;; Code: 65 66(define-module (gnome gobject gobject) 67 #:use-module ((srfi srfi-1) #:select (filter-map)) 68 #:use-module (oop goops) 69 #:use-module (gnome gobject utils) 70 #:use-module (gnome gobject config) 71 #:use-module (gnome gobject gtype) 72 #:use-module (gnome gobject gvalue) 73 #:use-module (gnome gobject gparameter) 74 #:use-module (gnome gobject gsignal) 75 76 #:export (;; Classes 77 <gobject> <ginterface> <gparam-object> 78 ;; Low-level subclassing 79 gtype-register-static 80 ;; Methods to override 81 gobject:get-property gobject:set-property 82 ;; Properties 83 gobject-class-get-properties gobject-class-find-property 84 gobject-class-get-property-names 85 gobject-get-property gobject-set-property)) 86 87(eval-when (expand load eval) 88 (dynamic-call "scm_init_gnome_gobject" 89 (dynamic-link *guile-gnome-gobject-lib-path*))) 90 91 92;;; 93;;; {Class Initialization} 94;;; 95 96(define-class <gobject-class> (<gtype-class>)) 97 98(define-method (compute-slots (class <gobject-class>)) 99 (define (has-slot? name slots) 100 (and (pair? slots) 101 (or (eq? name (slot-definition-name (car slots))) 102 (has-slot? name (cdr slots))))) 103 (define (compute-extra-slots props slots) 104 (filter-map (lambda (prop) 105 (and (not (has-slot? prop slots)) 106 (if (defined? '<slot>) 107 (make <slot> #:name prop #:allocation #:gproperty) 108 `(,prop #:allocation #:gproperty)))) 109 props)) 110 (let* ((slots (next-method)) 111 (extra (compute-extra-slots 112 (gobject-class-get-property-names class) slots))) 113 (with-accessors (direct-slots) 114 (set! (direct-slots class) (append (direct-slots class) extra))) 115 (append slots extra))) 116 117(define-method (compute-get-n-set (class <gobject-class>) slotdef) 118 (let ((name (slot-definition-name slotdef))) 119 (case (slot-definition-allocation slotdef) 120 ((#:gproperty) (list (lambda (o) (gobject-get-property o name)) 121 (lambda (o v) (gobject-set-property o name v)))) 122 (else (next-method))))) 123 124(define-method (initialize (class <gobject-class>) initargs) 125 (define (install-properties!) 126 ;; To expose slots as gobject properties, <gobject> will process a 127 ;; #:gparam slot option to create a new gobject property. 128 (for-each 129 (lambda (slot) 130 (let ((pspec (get-keyword #:gparam (slot-definition-options slot) #f))) 131 (if pspec 132 (gobject-class-install-property 133 class 134 (apply make 135 (car pspec) #:name (slot-definition-name slot) 136 (cdr pspec)))))) 137 (class-direct-slots class))) 138 139 (define (install-signals!) 140 ;; We parse a #:gsignal initialization argument to install signals. 141 (let loop ((args initargs)) 142 (if (not (null? args)) 143 (begin 144 (if (eq? (car args) #:gsignal) 145 (let ((signal (cadr args))) 146 (if (not (and (list? signal) (>= (length signal) 2))) 147 (gruntime-error "Invalid signal specification: ~A" signal)) 148 (let* ((name (car signal)) 149 (return-type (cadr signal)) 150 (param-types (cddr signal)) 151 (generic (gtype-class-create-signal class name return-type param-types))) 152 ;; Some magic to define the generic 153 (module-define! (current-module) 154 (generic-function-name generic) generic)))) 155 (loop (cddr args)))))) 156 157 (define (first pred list) 158 (cond ((null? list) #f) 159 ((pred (car list)) (car list)) 160 (else (first pred (cdr list))))) 161 (define (gobject-class? c) 162 (memq <gobject> (class-precedence-list c))) 163 164 ;; real work starts here 165 166 (next-method 167 class 168 (cons* 169 #:gtype-name 170 (or (get-keyword #:gtype-name initargs #f) 171 (gtype-register-static 172 (class-name->gtype-name (get-keyword #:name initargs #f)) 173 (first gobject-class? 174 (apply append 175 (map class-precedence-list 176 (get-keyword #:dsupers initargs '())))))) 177 initargs)) 178 (install-properties!) 179 (install-signals!)) 180 181(define-class-with-docs <gobject> (<gtype-instance>) 182 "The base class for GLib's default object system. 183 184@code{<gobject>}'s metaclass understands a new slot option, 185@code{#:gparam}, which will export a slot as a @code{<gobject>} 186property. The default implementation will set and access the value from 187the slot, but you can customize this by writing your own methods for 188@code{gobject:set-property} and @code{gobject:get-property}. 189 190In addition, the metaclass also understands @code{#:gsignal} arguments, 191which define signals on the class, and define the generics for the 192default signal handler. See @code{gtype-class-define-signal} for more 193information. 194 195For example: 196@lisp 197 ;; deriving from <gobject> 198 (define-class <test> (<gobject>) 199 ;; a normal object slot 200 my-data 201 202 ;; an object slot exported as a gobject property 203 (pub-data #:gparam (list <gparam-long> #:name 'test)) 204 205 ;; likewise, using non-default parameter settings 206 (foo-data #:gparam (list <gparam-long> #:name 'foo 207 #:minimum -3 #:maximum 1000 208 #:default-value 42)) 209 210 ;; a signal with no arguments and no return value 211 #:gsignal '(frobate #f) 212 213 ;; a signal with arguments and a return value 214 #:gsignal (list 'frobate <gboolean> <gint> <glong>)) 215 216 ;; deriving from <test> -- also inherits properties and signals 217 (define-class <hungry> (<test>)) 218@end lisp 219 220@code{<gobject>} classes also expose a slot for each GObject property 221defined on the class, if such a slot is not already defined. 222" 223 ;; add a slot for signal generics instead of module-define! ? 224 #:metaclass <gobject-class> 225 #:gtype-name "GObject") 226 227(define-class-with-docs <ginterface> (<gtype-instance>) 228 "The base class for GLib's interface types. Not derivable in Scheme." 229 #:metaclass <gobject-class> 230 #:gtype-name "GInterface") 231 232(define (class-is-a? x is-a) 233 (memq is-a (class-precedence-list x))) 234 235(define-class-with-docs <gparam-object> (<gparam>) 236 "Parameter for @code{<gobject>} values." 237 (object-type 238 #:init-keyword #:object-type #:allocation #:checked 239 #:pred (lambda (x) (is-a? x <gobject-class>))) 240 #:value-type <gobject> 241 #:gtype-name "GParamObject") 242 243 244;;; 245;;; {GObject Properties} 246;;; 247 248(define (gobject-class-find-property class name) 249 "Returns a property named @var{name} (a symbol), belonging to 250@var{class} or one of its parent classes, or @code{#f} if not found." 251 (let ((propname name)) 252 (with-accessors (name) 253 (let lp ((props (gobject-class-get-properties class))) 254 (cond ((null? props) #f) 255 ((eq? (name (car props)) propname) (car props)) 256 (else (lp (cdr props)))))))) 257 258(define-generic-with-docs gobject:set-property 259 "Called to set a gobject property. Only properties directly belonging 260to the object's class will come through this function; superclasses 261handle their own properties. 262 263Takes three arguments: the object, the property name, and the value. 264 265Call @code{(next-method)} in your methods to invoke the default handler.") 266 267(define-method (gobject:set-property (object <gobject>) (name <symbol>) value) 268 "The default implementation of @code{gobject:set-property}, which sets 269slots on the object." 270 (if (class-slot-definition (class-of object) name) 271 (slot-set! object name value) 272 (gruntime-error "Properties added after object definition must be accessed via custom property methods: ~A" name))) 273 274(define-generic-with-docs gobject:get-property 275 "Called to get a gobject property. Only properties directly belonging 276to the object's class will come through this function; superclasses 277handle their own properties. 278 279Takes two arguments: the object and the property name. 280 281Call @code{(next-method)} in your methods to invoke the default handler") 282 283(define-method (gobject:get-property (object <gobject>) (name <symbol>)) 284 "The default implementation of @code{gobject:get-property}, which 285calls @code{(slot-ref obj name)}." 286 (if (class-slot-definition (class-of object) name) 287 (slot-ref object name) 288 (gruntime-error "Properties added after object definition must be accessed via custom property methods: ~A" name))) 289 290(eval-when (load eval) 291 (%gnome-gobject-object-post-init)) 292