gtk-server.TODO (19232B)
1 2 3 4 5 6 7 8 9 10 (ctype GtkWidget* c-pointer) 11 12 ;;; 13 ;;; callback handling 14 ;;; 15 16 ;; this is complicated as each callback can have a different number of 17 ;; arguments and it is the last that is most interesting (a gpointer to 18 ;; some data we manage) 19 ;; in order to call lisp functions (and thus support closures) rather 20 ;; than being limited to a primitive data type, the data parameter is 21 ;; used by this module, as an index into a global vector of callback 22 ;; functions. so, a call is made to gtk_connect, with an object, the 23 ;; event name and a callback function the callback is put in the global 24 ;; vector, and its index is given as the data argument to 25 ;; g_signal_connect_data. This module's callback function performs the 26 ;; lookup (it gets the index as its last parameter), and calls it. 27 ;; this could be handled directly by the ffi (passing in a lisp function 28 ;; as the callback would work) but this causes memory leaks. 29 30 ;;; 31 ;;; make the connect functions, taking from 0-4 arguments as well as the object 32 ;;; 33 34 (defmacro make-connect-funcs (param-count) 35 (let* ((c-name (intern (format nil "g_signal_connect_data-~a" param-count))) 36 (cb-name (intern (format nil "gtk-callback-~a" param-count))) 37 (args (loop :for i :from 1 :upto param-count 38 :collect (intern (format nil "ARG-~a" i)))) 39 (arg-types (mapcar (lambda (x) `(,x c-pointer)) args))) 40 `(progn 41 (def-call-out ,c-name (:name "g_signal_connect_data") 42 (:return-type int) 43 (:arguments (widget GtkWidget*) 44 (name c-string) 45 (callback 46 (c-function (:arguments (object c-pointer) 47 ,@arg-types 48 (data int)) 49 (:return-type int))) 50 (data int) 51 (clean-up 52 (c-function (:arguments (data int)) 53 (:return-type nil))) 54 (b int))) 55 (def-call-in ,cb-name (:return-type ffi:int) 56 (:arguments (object c-pointer) 57 ,@arg-types 58 (data ffi:c-string))) 59 (defun ,cb-name (object ,@args data) 60 (funcall (aref *callback-funcs* data) object ,@args)) 61 (setf (aref *connect-funcs* ,param-count) (cons #',c-name #',cb-name))))) 62 63 (defvar *connect-funcs* (make-array 5)) 64 (defvar *callback-funcs* (make-array 0 :adjustable t :fill-pointer 0)) 65 (make-connect-funcs 0) 66 (make-connect-funcs 1) 67 (make-connect-funcs 2) 68 (make-connect-funcs 3) 69 (make-connect-funcs 4) 70 71 ;;; 72 ;;; our cleanup function just has to discard the entry in *callback-funcs* 73 ;;; 74 75 (def-call-in gtk-cleanup (:arguments (data int)) (:return-type nil)) 76 77 (defun gtk-cleanup (data) 78 (format t "~S(~D): discarded ~S~%" 'gtk-cleanup data 79 (aref *callback-funcs* data)) 80 (setf (aref *callback-funcs* data) nil) 81 nil) 82 83 84 85 86 87 88 ;;; 89 ;;; These struct definitions allow us to get the itype from an object 90 ;;; 91 92 (def-c-type GType ulong) 93 (def-c-struct GTypeClass (g_type GType)) 94 (def-c-struct GTypeInstance (g_class (c-ptr GTypeClass))) 95 (def-c-struct GSignalQuery 96 (signal_id int) 97 (signal_name c-string) 98 (itype int) 99 (signal_flags int) 100 (return_type int) 101 (n_params int) 102 (param_types c-pointer)) 103 104 (def-call-out g_signal_handler_disconnect (:return-type nil) 105 (:arguments (obj GtkWidget*) (id int))) 106 (def-call-out g_signal_lookup (:return-type int) 107 (:arguments (name c-string) (itype int))) 108 (def-call-out g_signal_query (:return-type nil) 109 (:arguments (id int) (query c-pointer))) 110 (def-call-out g_type_from_name (:return-type int) (:arguments (name c-string))) 111 112 (defun get_type_from_instance (widget) 113 "Returns the type from an instance instance->g_class->g_type" 114 (with-c-var (_widget 'c-pointer widget) 115 (slot (deref (slot (deref (cast _widget '(c-ptr GTypeInstance))) 116 'g_class)) 117 'g_type))) 118 119 (defun gtk_connect (widget signal func) 120 "The exported function, gtk_connect, taking a gobject, a 121 signal name (e.g `delete_event') and a callback function. 122 The callback function will be passed the gobject, and any other 123 signal specific parameters, but not a data parameter." 124 (let* ((n_params 125 (with-c-var (query 'GSignalQuery) 126 (g_signal_query (g_signal_lookup signal 127 (get_type_from_instance widget)) 128 (c-var-address query)) 129 (slot query 'n_params))) 130 (funcs (aref *connect-funcs* n_params)) 131 (idx (or (position nil *callback-funcs*) 132 (vector-push-extend func *callback-funcs*)))) 133 (funcall (car funcs) 134 widget 135 signal 136 (cdr funcs) 137 idx 138 #'gtk-cleanup 139 0))) 140 141 142 ;;; 143 ;;; the actual imports 144 ;;; 145 146 ;; rather than coding these in by hand, they are read from gtk-server.cfg 147 ;; this file is part of the (excellent) http://www.gtk-server.org project, 148 ;; and defines lots of gtk functions in a simple-enough-to-parse form. 149 ;; 150 ;; the scanning is done in a macro, so it is performed at compile time. 151 ;; there is no need to ship gtk-server.cfg with your project. 152 153 (defmacro read-gtk-server-cfg (filename) 154 (labels ((convert-type (typ) 155 (let ((sym (read-from-string typ))) 156 (case sym 157 (NONE 'nil) 158 (LONG 'long) 159 (BOOL 'boolean) 160 (STRING 'c-string) 161 (FLOAT 'single-float) 162 (DOUBLE 'double-float) 163 (NULL 'c-pointer) 164 (WIDGET 'GtkWidget*) 165 (otherwise sym)))) 166 (proc-line (string start) 167 (let* ((parts (loop :for i = start :then (1+ j) 168 :as j = (position #\, string :start i) 169 :collect (string-trim " " (subseq string i j)) 170 :while j)) 171 ;; parts are: API name, callback signal type, return value, 172 ;; number of arguments, arg1, arg2... 173 (name (intern (pop parts))) 174 (callback-sig-type (pop parts)) 175 (ret-type (pop parts)) 176 (num-arg (parse-integer (pop parts)))) 177 (declare (ignore callback-sig-type)) 178 (unless (= num-arg (length parts)) 179 (warn "~S: argument count ~D does not match argument list ~S" 180 name num-arg parts)) 181 `(def-call-out ,name (:return-type ,(convert-type ret-type)) 182 (:arguments ,@(loop :for arg :in parts 183 :collect `(arg ,(convert-type arg)))))))) 184 `(progn 185 ,@(with-open-file (cfg filename) 186 (format t "~&;; Reading ~A~%" (truename cfg)) 187 (loop :with forms = nil 188 :finally (format t "~&;; Defined ~:D function~:P~%" 189 (length forms)) 190 :finally (return forms) 191 :for line = (read-line cfg nil) 192 :while line 193 :do 194 (setq line (string-trim #.(coerce '(#\space #\tab) 'string) line)) 195 ;; check that it starts with "FUNCTION_NAME = " 196 (when (and (> (length line) #1=#.(length #2="FUNCTION_NAME = ")) 197 (string= line #2# :end1 #1#)) 198 (push (proc-line line #1#) forms))))))) 199 200 (read-gtk-server-cfg "gtk-server.cfg") 201 202 (def-c-struct GtkTreeIter 203 (stamp int) 204 (user_data c-pointer) 205 (user_data2 c-pointer) 206 (user_data3 c-pointer)) 207 208 (def-c-struct GValue 209 (g_type int) 210 (unknown1 double-float) 211 (unknown2 double-float) 212 (unknown3 double-float) 213 (unknown4 double-float)) 214 215 (def-call-out g_type_fundamental (:return-type int) (:arguments (val int))) 216 (def-call-out g_value_init (:return-type nil) 217 (:arguments (val c-pointer) (gtype int))) 218 (def-call-out g_value_set_string (:return-type nil) 219 (:arguments (val c-pointer) (str c-string))) 220 (def-call-out g_object_set_data (:return-type nil) 221 (:arguments (obj c-pointer) (key c-string) (data c-pointer))) 222 (def-call-out g_object_get_data (:return-type c-pointer) 223 (:arguments (obj c-pointer) (key c-string))) 224 225 (def-call-out gtk_tree_view_set_model (:return-type nil) 226 (:arguments (widget GtkWidget*) (model c-pointer))) 227 228 (def-call-out gtk_tree_view_column_set_title (:return-type nil) 229 (:arguments (view GtkWidget*) (title c-string))) 230 (def-call-out gtk_tree_view_column_set_attributes (:return-type nil) 231 (:arguments (column c-pointer) (renderer c-pointer) (name c-string) 232 (value int) (terminator nil))) 233 (def-call-out gtk_tree_view_column_add_attribute (:return-type nil) 234 (:arguments (column c-pointer) (renderer c-pointer) (name c-string) 235 (value int))) 236 237 ;;; 238 ;; memory leak test 239 ;;; 240 241 #+nil 242 (defun ml-test () 243 (gtk_init 0 0) 244 (let ((w (gtk_window_new 0))) 245 (gtk_widget_show_all w) 246 (loop :for id = (gtk_connect w "delete_event" 247 (lambda (&rest args) 248 (declare (ignore args)) 249 (print "destroyed") (ext:quit))) 250 :do (g_signal_handler_disconnect w id) 251 (ext:gc) 252 (print (room)) 253 (sleep 0.1)) 254 (gtk_main))) 255 256 ;;; 257 ;;; === GLADE === 258 ;;; 259 260 (c-lines "#include <glade/glade-xml.h>~%") 261 262 (def-c-type GladeXML* c-pointer) 263 (def-c-type GCallback 264 (c-pointer (c-function (:return-type nil) (:arguments)))) 265 (def-c-type GObject* c-pointer) 266 267 (cfun glade_xml_new GladeXML* (cstr fname) (cstr root) (cstr domain))) 268 269 (def-call-out glade_xml_new_from_buffer (:return-type GladeXML*) 270 (:arguments (buffer c-string) 271 (size int) ; pass (length buffer) 272 (root c-string) 273 (domain c-string))) 274 (def-call-out glade_xml_construct (:return-type boolean) 275 (:arguments (self GladeXML*) 276 (fname c-string) 277 (root c-string) 278 (domain c-string))) 279 (def-call-out glade_xml_signal_connect (:return-type nil) 280 (:arguments (self GladeXML*) 281 (handlername c-string) 282 (func GCallback))) 283 (def-call-out glade_xml_signal_connect_data (:return-type nil) 284 (:arguments (self GladeXML*) 285 (handlername c-string) 286 (func GCallback) 287 (user_data c-pointer))) 288 (def-call-out glade_xml_signal_autoconnect (:return-type nil) 289 (:arguments (self GladeXML*))) 290 (def-call-out glade_xml_get_widget (:return-type GtkWidget*) 291 (:arguments (self GladeXML*) 292 (name c-string))) 293 (def-c-type GList* c-pointer) 294 (def-call-out glade_xml_get_widget_prefix (:return-type GList*) 295 (:arguments (self GladeXML*) 296 (name c-string))) 297 (def-call-out glade_get_widget_name (:return-type c-string) 298 (:arguments (widget GtkWidget*))) 299 (def-call-out glade_get_widget_tree (:return-type GladeXML*) 300 (:arguments (widget GtkWidget*))) 301 (def-c-type GladeXMLConnectFunc 302 (c-function (:return-type nil) 303 (:arguments (handler_name c-string) 304 (object GObject*) 305 (signal_name c-string) 306 (signal_data c-string) 307 (connect_object GObject*) 308 (after boolean) 309 (user_data c-pointer)))) 310 (def-call-out glade_xml_signal_connect_full (:return-type nil) 311 (:arguments (self GladeXML*) 312 (handler_name c-string) 313 (func GladeXMLConnectFunc) 314 (user_data c-pointer))) 315 (def-call-out glade_xml_signal_autoconnect_full (:return-type nil) 316 (:arguments (self GladeXML*) 317 (func GladeXMLConnectFunc) 318 (user_data c-pointer))) 319 (def-c-type GladeXMLCustomWidgetHandler 320 (c-function (:return-type GtkWidget*) 321 (:arguments (xml GladeXML*) 322 (func_name c-string) 323 (name c-string) 324 (string1 c-string) 325 (string2 c-string) 326 (int1 int) 327 (int2 int) 328 (user_data c-pointer)))) 329 (def-call-out glade_set_custom_handler (:return-type nil) 330 (:arguments (handler GladeXMLCustomWidgetHandler) 331 (user_data c-pointer))) 332 333 (include "glade/glade.h" "glade/glade-build.h") 334 335 (def-c-type GladeWidgetInfo* c-pointer) 336 337 (def-c-type GladeNewFunc 338 (c-function (:return-type GtkWidget*) 339 (:arguments (xml GladeXML*) 340 (widget_type GType) 341 (info c-pointer)))) 342 (def-c-type GladeBuildChildrenFunc 343 (c-function (:return-type nil) 344 (:arguments (xml GladeXML*) 345 (parent GtkWidget*) 346 (info c-pointer)))) 347 (def-c-type GladeFindInternalChildFunc 348 (c-function (:return-type GtkWidget*) 349 (:arguments (xml GladeXML*) 350 (parent GtkWidget*) 351 (childname c-string)))) 352 353 (def-c-type GladeChildInfo* c-pointer) 354 355 (def-call-out glade_xml_build_widget (:return-type GtkWidget*) 356 (:arguments (self GladeXML*) 357 (info c-pointer))) 358 (def-call-out glade_xml_handle_internal_child (:return-type nil) 359 (:arguments (self GladeXML*) 360 (parent GtkWidget*) 361 (child_info GladeChildInfo*))) 362 (def-call-out glade_xml_set_common_params (:return-type nil) 363 (:arguments (self GladeXML*) 364 (widget GtkWidget*) 365 (info c-pointer))) 366 (def-call-out glade_register_widget (:return-type nil) 367 (:arguments (type GType) 368 (new_func GladeNewFunc) 369 (build_children GladeBuildChildrenFunc) 370 (find_internal_child GladeFindInternalChildFunc))) 371 (def-call-out glade_standard_build_widget (:return-type GtkWidget*) 372 (:arguments (xml GladeXML*) 373 (widget_type GType) 374 (info c-pointer))) 375 (def-call-out glade_xml_handle_widget_prop (:return-type nil) 376 (:arguments (self GladeXML*) 377 (widget GtkWidget*) 378 (prop_name c-string) 379 (value_name c-string))) 380 (def-call-out glade_standard_build_children (:return-type nil) 381 (:arguments (self GladeXML*) 382 (parent GtkWidget*) 383 (info c-pointer))) 384 (def-call-out glade_xml_set_packing_property (:return-type nil) 385 (:arguments (self GladeXML*) 386 (parent GtkWidget*) 387 (child GtkWidget*) 388 (name c-string) 389 (value c-string))) 390 (def-c-type GladeApplyCustomPropFunc 391 (c-function (:return-type nil) 392 (:arguments (xml GladeXML*) 393 (widget GtkWidget*) 394 (propname c-string) 395 (value c-string)))) 396 (def-call-out glade_register_custom_prop (:return-type nil) 397 (:arguments (type GType) 398 (prop_name c-string) 399 (apply_prop GladeApplyCustomPropFunc))) 400 (def-call-out glade_xml_relative_file (:return-type c-string) 401 (:arguments (self GladeXML*) 402 (filename c-string))) 403 (def-call-out glade_enum_from_string (:return-type int) 404 (:arguments (type GType) 405 (string c-string))) 406 (def-call-out glade_flags_from_string (:return-type uint) 407 (:arguments (type GType) 408 (string c-string))) 409 (def-c-type GParamSpec* c-pointer) 410 (def-call-out glade_xml_set_value_from_string (:return-type boolean) 411 (:arguments (xml GladeXML*) 412 (pspec GParamSpec*) 413 (string c-string) 414 (value (c-ptr GValue) :out :alloca))) 415 (def-c-type GtkWindow* c-pointer) 416 (def-call-out glade_xml_set_toplevel (:return-type nil) 417 (:arguments (xml GladeXML*) 418 (window GtkWindow*))) 419 (def-c-type GtkAccelGroup* c-pointer) 420 (def-call-out glade_xml_ensure_accel (:return-type GtkAccelGroup*) 421 (:arguments (xml GladeXML*))) 422 423 424 ;;; 425 ;;; High-level UI 426 ;;; 427 428 (defun glade-load (file) 429 (let ((xml (or (glade_xml_new (namestring (absolute-pathname file)) nil nil) 430 (error "~S(~S): ~S failed" 'glade-load file 'glade_xml_new)))) 431 (glade_xml_signal_autoconnect_full 432 xml 433 (lambda (handler_name object signal_name signal_data connect_object 434 after user_data) 435 (declare (ignore signal_data connect_object after user_data)) 436 (gtk_connect object signal_name 437 (let ((code (read-from-string handler_name))) 438 (compile 439 (make-symbol (princ-to-string code)) 440 `(lambda (&rest args) 441 (format t "~&calling ~S with arguments ~S~%" 442 ',code args) 443 ,code 444 0))))) ; return an integer 445 nil) 446 xml)) 447 448 (defun run-glade-file (file widget-name) 449 (gtk_init nil nil) 450 (gtk_widget_show_all (glade_xml_get_widget (glade-load file) widget-name)) 451 (gtk_main)) 452 453 ;;; 454 ;;; clisp gui 455 ;;; 456 457 (defstruct gui main repl apropos status about-window about-text) 458 (defvar *gui*) 459 (defun gui-from-file (file) 460 (let ((xml (glade-load file))) 461 (flet ((widget (name) 462 (let ((w (or (glade_xml_get_widget xml name) 463 (error "~S(~S): not found ~S" 'gui-from-file 464 file name)))) 465 (format t "~&~A == ~S~%" name w) 466 w))) 467 (make-gui :main (widget "clisp-gui-main") 468 :repl (widget "textview_repl") 469 :apropos (widget "entry1_apropos") 470 :status (widget "statusbar1") 471 :about-window (widget "dialog1_about") 472 :about-text (widget "textview_about"))))) 473 474 (defun gui-status-show (string &optional (*gui* *gui*)) 475 (gtk_statusbar_push (gui-status *gui*) (length string) string)) 476 477 (defun gui-apropos-do (&optional (*gui* *gui*)) 478 (apropos (gtk_entry_get_text (gui-apropos *gui*)))) 479 480 (defun gui-about-do (&optional (*gui* *gui*)) 481 (let ((about-text 482 (format nil "This is a gtk2 demo.~%~A ~A~%" 483 (lisp-implementation-type) (lisp-implementation-version)))) 484 (gtk_text_buffer_set_text 485 (gtk_text_view_get_buffer (gui-about-text *gui*)) 486 about-text (length about-text))) 487 (gtk_widget_show (gui-about-window *gui*)) 488 (gui-status-show (SYS::TEXT "Displaying ABOUT"))) 489 490 (defun gui-about-done (&optional (*gui* *gui*)) 491 (gtk_widget_hide (gui-about-window *gui*)) 492 (gui-status-show (SYS::TEXT "Closed ABOUT"))) 493 494 (defun gui-clear-do (&optional (*gui* *gui*)) 495 (gui-status-show (SYS::TEXT "Clear CLISP output"))) 496 497 (defun gui-eval-do (&optional (*gui* *gui*)) 498 (gui-status-show (SYS::TEXT "Call EVAL on the current selection"))) 499 500 (defun gui-describe-do (&optional (*gui* *gui*)) 501 (gui-status-show (SYS::TEXT "Call DESCRIBE on the current selection"))) 502 503 (defun gui-quit (&optional (*gui* *gui*)) 504 (gui-status-show (SYS::TEXT "Bye!")) 505 (gtk_main_quit) 506 (throw 'gui-quit 0)) 507 508 (defun gui (file) 509 (gtk_init nil nil) 510 (let ((*gui* (gui-from-file file))) 511 (gui-status-show (SYS::TEXT "Welcome to CLISP!")) 512 (gtk_widget_show (gui-main *gui*)) 513 (gtk_widget_hide (gui-about-window *gui*)) 514 (catch 'gui-quit (gtk_main)) 515 (format t (SYS::TEXT "Exited gui~%"))))