commit bad72057667173334b074d56d7e2e7f831ef0582
parent 1521750ac3a0b758f5ebcb0e56cb03a90536e430
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 6 Sep 2015 14:00:15 +0200
add gi-server
Diffstat:
3 files changed, 351 insertions(+), 0 deletions(-)
diff --git a/cl-gi-server.asd b/cl-gi-server.asd
@@ -0,0 +1,31 @@
+;;; -*- lisp; -*-
+
+;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(asdf:defsystem :cl-gi-server
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on (:cl-rw)
+ :serial t
+ :components ((:file "gi-server/gi-server")))
diff --git a/gi-server/gi-server-demo5.glade b/gi-server/gi-server-demo5.glade
@@ -0,0 +1,19 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<interface>
+ <!-- interface-requires gtk+ 3.0 -->
+ <object class="GtkWindow" id="window1">
+ <property name="can_focus">False</property>
+ <signal name="delete-event" handler="onDeleteWindow" swapped="no"/>
+ <child>
+ <object class="GtkButton" id="button1">
+ <property name="label" translatable="yes">button</property>
+ <property name="use_action_appearance">False</property>
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="receives_default">True</property>
+ <property name="use_action_appearance">False</property>
+ <signal name="pressed" handler="onButtonPressed" swapped="no"/>
+ </object>
+ </child>
+ </object>
+</interface>
diff --git a/gi-server/gi-server.lisp b/gi-server/gi-server.lisp
@@ -0,0 +1,301 @@
+;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+;; TODO zombies
+;; TODO invoke return values
+;; TODO handler args
+
+(defpackage :gi-server
+ (:use :cl))
+
+(in-package :gi-server)
+
+(defparameter *gi-server-program* "gi-server")
+
+;; TODO custom error type
+;;(define-condition gi-server-error (error) ())
+
+(defvar *handlers*) ;; id -> thunk
+
+(defvar *istream*)
+(defvar *ostream*)
+
+(defun call-with-gi-server (cmd args thunk)
+ (rw.os:with-program-io (*istream* *ostream* (rw.os:make-program
+ :stream :stream cmd args nil))
+ (let ((*handlers* (make-hash-table)))
+ (funcall thunk))))
+
+(defmacro with-gi-server ((cmd &optional args) &body body)
+ `(call-with-gi-server ,cmd ,args (lambda () ,@body)))
+
+(defun serialize (x)
+ (if (atom x)
+ (etypecase x
+ (null)
+ (integer
+ (format t "~d" x))
+ (symbol
+ (format t "~(~a~)" x))
+ (string
+ (format t "\"")
+ (loop
+ for c across x
+ do (case c
+ (#\" (format t "\\\""))
+ (#\\ (format t "\\\\"))
+ (t (write-char c))))
+ (write-char #\"))
+ (function
+ (format t "~d" (funcall x 'pointer))))
+ (progn
+ (serialize (car x))
+ (write-char #\space)
+ (serialize (cdr x)))))
+
+;;(serialize '(require "GLib" "2.0"))
+
+(defparameter *debug-request* t)
+
+(defun request (&rest x)
+ (when *debug-request*
+ (serialize x)
+ (terpri)
+ (finish-output))
+ (let ((*standard-output* *istream*))
+ (serialize x))
+ (terpri *istream*)
+ (finish-output *istream*)
+ (let* ((s (read-line *ostream*))
+ (r (rw:peek-reader (rw:reader s)))
+ (z (rw:till r '(#\space))))
+ (when *debug-request*
+ (format t "-> ~a~%" s)
+ (finish-output))
+ (cond
+ ((equal z '(#\o #\k))
+ (rw:skip r)
+ (let ((x (rw:till r)))
+ (when x
+ (coerce x 'string))))
+ ((equal z '(#\e #\r #\r #\o #\r))
+ (rw:skip r)
+ (error #+nil 'gi-server-error (coerce (rw:till r) 'string))))))
+
+(defun g_irepository_require (namespace &optional version)
+ (request 'require namespace version)
+ (values))
+
+(defun g_irepository_find_by_name (namespace name)
+ (parse-integer (request 'find namespace name)))
+
+(defun g_function_info_invoke (function arguments)
+ (let ((z (request 'invoke function arguments)))
+ (when z
+ (parse-integer z))))
+
+(defun g_base_info_unref (pointer)
+ (request 'unref pointer)
+ (values))
+
+(defun g_base_info_get_type (pointer)
+ (ecase (parse-integer (request 'type pointer))
+ (1 :function)
+ (7 :object)))
+
+(defun g_function_info_get_flags (pointer)
+ (let ((x (parse-integer (request 'flags pointer))))
+ (append (unless (zerop (logand x #x01)) '(:method))
+ (unless (zerop (logand x #x02)) '(:constructor))
+ (unless (zerop (logand x #x04)) '(:getter))
+ (unless (zerop (logand x #x08)) '(:setter))
+ (unless (zerop (logand x #x10)) '(:vfunc))
+ (unless (zerop (logand x #x20)) '(:throws)))))
+
+(defun g_object_info_find_method (pointer name)
+ (prog1 (parse-integer (request 'method pointer name))))
+
+(defmacro with-ref ((var val) &body body)
+ `(let ((,var ,val))
+ (unwind-protect (locally ,@body)
+ #+nil(g_base_info_unref ,var))))
+
+(defun make-object (pointer &optional class)
+ (let ((class (or class
+ ;; TODO compute class from pointer
+ #+nil(parse-integer (request 'class pointer)))))
+ (lambda (method &rest args)
+ (case method
+ (class class)
+ (pointer pointer)
+ (t (with-ref (m (g_object_info_find_method class method))
+ (assert (not (member :constructor (g_function_info_get_flags m))))
+ (g_function_info_invoke m (cons pointer args))))))))
+
+(defun make-repository (namespace &optional version)
+ (g_irepository_require namespace (or version 'null))
+ (lambda (name &rest args)
+ (with-ref (p (g_irepository_find_by_name namespace name))
+ (ecase (g_base_info_get_type p)
+ (:function
+ (g_function_info_invoke p args))
+ (:object
+ (destructuring-bind (method &rest arguments) args
+ (with-ref (m (g_object_info_find_method p method))
+ (assert (member :constructor (g_function_info_get_flags m)))
+ (make-object (g_function_info_invoke m arguments) p))))))))
+
+(defun connect (object signal handler &optional after)
+ (let* ((s (request 'connect object signal (if after 1 0)))
+ (r (rw:peek-reader (rw:reader s)))
+ (id (parse-integer (coerce (rw:till r) 'string))))
+ (setf (gethash id *handlers*) handler))
+ (values))
+
+(defun callback ()
+ (let ((k (parse-integer (request 'callback))))
+ (or (zerop k)
+ (funcall (gethash k *handlers*))
+ #+nil
+ (let ((v (gethash k *handlers*)))
+ (when v
+ (funcall v))))))
+
+(defun demo1 ()
+ (with-gi-server (*gi-server-program*)
+ (funcall (make-repository "GLib" "2.0")
+ 'assertion_message
+ 'domain "glib-print.c" 30 'main "hello world")))
+
+(defun demo2 ()
+ (with-gi-server (*gi-server-program*)
+ (let ((gtk (make-repository "Gtk")))
+ (funcall gtk 'init 0 'null)
+ (let ((w (funcall gtk "Window" 'new 0)))
+ (connect w 'destroy (lambda (&rest args)
+ (declare (ignore args))
+ (request 'exit)))
+ (funcall w "show"))
+ (loop
+ do (funcall gtk 'main_iteration)
+ while (callback)))))
+
+(defun demo3 ()
+ (with-gi-server (*gi-server-program*)
+ (let ((gtk (make-repository "Gtk")))
+ (funcall gtk 'init 0 'null)
+ (let ((w (funcall gtk "Window" 'new 0)))
+ (funcall w 'set_title "Hello world")
+ (funcall w 'set_default_size 400 300)
+ (connect w 'destroy (lambda (&rest args)
+ (declare (ignore args))
+ (request 'exit)))
+ (funcall w 'show_all))
+ (loop
+ do (funcall gtk 'main_iteration)
+ while (callback)))))
+
+(defun demo4 ()
+ (with-gi-server (*gi-server-program*)
+ (let ((gtk (make-repository "Gtk")))
+ (funcall gtk 'init 0 'null)
+ (let ((w (funcall gtk "Window" 'new 0)))
+ (funcall w 'set_border_width 10)
+ (funcall w 'set_title "Hello world")
+ (connect w 'destroy (lambda (&rest args)
+ (declare (ignore args))
+ (request 'exit)))
+ (let ((b (funcall gtk "Button" 'new_with_label "Hello World")))
+ (connect b 'clicked
+ (let ((i 0))
+ (lambda (&rest args)
+ (funcall w 'set_title
+ (format nil "hi ~s ~s" (incf i) args)))))
+ (funcall w 'add b))
+ (funcall w 'show_all))
+ (loop
+ do (funcall gtk 'main_iteration)
+ while (callback)))))
+
+(defun connect-glade-signals (glade fn)
+ (let (*object*)
+ (declare (special *object*))
+ (labels ((rec (x)
+ (when (consp x)
+ (let* ((head (car x))
+ (tail (cdr x))
+ (plain (atom head))
+ (e (if plain head (car head)))
+ (a (unless plain (cdr head))))
+ (case e
+ (:|object|
+ (let ((*object* a))
+ (declare (special *object*))
+ (mapc #'rec tail)))
+ (:|signal|
+ (funcall fn
+ (getf *object* :|class|)
+ (getf *object* :|id|)
+ (getf a :|name|)
+ (getf a :|handler|)
+ (getf a :|swapped|)))
+ (t (mapc #'rec tail)))))))
+ (rec (rw.xml:parse-xml glade)))))
+
+;;https://python-gtk-3-tutorial.readthedocs.org/en/latest/builder.html
+(defun demo5 ()
+ (with-gi-server (*gi-server-program*)
+ (let ((glade (merge-pathnames "gi-server-demo5.glade"
+ (or *compile-file-pathname*
+ *load-pathname*)))
+ (gtk (make-repository "Gtk")))
+ (funcall gtk 'init 0 'null)
+ (let ((b (funcall gtk "Builder" 'new)))
+ (funcall b 'add_from_file (namestring glade))
+ ;; TODO when retval is object
+ (let ((w (make-object (funcall b 'get_object "window1")
+ ;; TODO automatically
+ (g_irepository_find_by_name "Gtk" "Window")))
+ (b (make-object (funcall b 'get_object "button1")
+ ;; TODO automatically
+ (g_irepository_find_by_name "Gtk" "Button"))))
+ (connect-glade-signals
+ glade
+ (lambda (class id signal handler swapped)
+ ;;(print (list :@@@ class id signal handler swapped))
+ ;;strip_identifier
+ (cond
+ ((string= handler "onDeleteWindow")
+ (connect w signal ;;'destroy ;;delete-event ;; TODO fix callback
+ (lambda (&rest args)
+ (declare (ignore args))
+ (request 'exit))))
+ ((string= handler "onButtonPressed")
+ (connect b signal
+ (let ((i 0))
+ (lambda (&rest args)
+ (funcall w 'set_title
+ (format nil "hi ~s ~s" (incf i) args)))))))))
+ (funcall w 'show_all)))
+ (loop
+ do (funcall gtk 'main_iteration)
+ while (callback)))))
