cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

gi-server.lisp (10873B)

      1 ;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 ;; TODO zombies
     24 ;; TODO invoke return values
     25 ;; TODO handler args
     26 
     27 (defpackage :gi-server
     28   (:use :cl))
     29 
     30 (in-package :gi-server)
     31 
     32 (defparameter *gi-server-program* "gi-server")
     33 
     34 ;; TODO custom error type
     35 ;;(define-condition gi-server-error (error) ())
     36 
     37 (defvar *handlers*) ;; id -> thunk
     38 
     39 (defvar *istream*)
     40 (defvar *ostream*)
     41 
     42 (defun call-with-gi-server (cmd args thunk)
     43   (rw.os:with-program-io (*istream* *ostream* (rw.os:make-program
     44                                                :stream :stream cmd args nil))
     45     (let ((*handlers* (make-hash-table)))
     46       (funcall thunk))))
     47 
     48 (defmacro with-gi-server ((cmd &optional args) &body body)
     49   `(call-with-gi-server ,cmd ,args (lambda () ,@body)))
     50 
     51 (defun serialize (x)
     52   (if (atom x)
     53       (etypecase x
     54         (null)
     55         (integer
     56          (format t "~d" x))
     57         (symbol
     58          (format t "~(~a~)" x))
     59         (string
     60          (format t "\"")
     61          (loop
     62             for c across x
     63             do (case c
     64                  (#\" (format t "\\\""))
     65                  (#\\ (format t "\\\\"))
     66                  (t (write-char c))))
     67          (write-char #\"))
     68         (function
     69          (format t "~d" (funcall x 'pointer))))
     70       (progn
     71         (serialize (car x))
     72         (write-char #\space)
     73         (serialize (cdr x)))))
     74 
     75 ;;(serialize '(require "GLib" "2.0"))
     76 
     77 (defparameter *debug-request* t)
     78 
     79 (defun request (&rest x)
     80   (when *debug-request*
     81     (serialize x)
     82     (terpri)
     83     (finish-output))
     84   (let ((*standard-output* *istream*))
     85     (serialize x))
     86   (terpri *istream*)
     87   (finish-output *istream*)
     88   (let* ((s (read-line *ostream*))
     89          (r (rw:peek-reader (rw:reader s)))
     90          (z (rw:till r '(#\space))))
     91     (when *debug-request*
     92       (format t "-> ~a~%" s)
     93       (finish-output))
     94     (cond
     95       ((equal z '(#\o #\k))
     96        (rw:skip r)
     97        (let ((x (rw:till r)))
     98          (when x
     99            (coerce x 'string))))
    100       ((equal z '(#\e #\r #\r #\o #\r))
    101        (rw:skip r)
    102        (error #+nil 'gi-server-error (coerce (rw:till r) 'string))))))
    103 
    104 (defun g_irepository_require (namespace &optional version)
    105   (request 'require namespace version)
    106   (values))
    107 
    108 (defun g_irepository_find_by_name (namespace name)
    109   (parse-integer (request 'find namespace name)))
    110 
    111 (defun g_function_info_invoke (function arguments)
    112   (let ((z (request 'invoke function arguments)))
    113     (when z
    114       (parse-integer z))))
    115 
    116 (defun g_base_info_unref (pointer)
    117   (request 'unref pointer)
    118   (values))
    119 
    120 (defun g_base_info_get_type (pointer)
    121   (ecase (parse-integer (request 'type pointer))
    122     (1 :function)
    123     (7 :object)))
    124 
    125 (defun g_function_info_get_flags (pointer)
    126   (let ((x (parse-integer (request 'flags pointer))))
    127     (append (unless (zerop (logand x #x01)) '(:method))
    128             (unless (zerop (logand x #x02)) '(:constructor))
    129             (unless (zerop (logand x #x04)) '(:getter))
    130             (unless (zerop (logand x #x08)) '(:setter))
    131             (unless (zerop (logand x #x10)) '(:vfunc))
    132             (unless (zerop (logand x #x20)) '(:throws)))))
    133 
    134 (defun g_object_info_find_method (pointer name)
    135   (prog1 (parse-integer (request 'method pointer name))))
    136 
    137 (defmacro with-ref ((var val) &body body)
    138   `(let ((,var ,val))
    139      (unwind-protect (locally ,@body)
    140        #+nil(g_base_info_unref ,var))))
    141 
    142 (defun make-object (pointer &optional class)
    143   (let ((class (or class
    144                    ;; TODO compute class from pointer
    145                    #+nil(parse-integer (request 'class pointer)))))
    146     (lambda (method &rest args)
    147       (case method
    148         (class class)
    149         (pointer pointer)
    150         (t (with-ref (m (g_object_info_find_method class method))
    151              (assert (not (member :constructor (g_function_info_get_flags m))))
    152              (g_function_info_invoke m (cons pointer args))))))))
    153 
    154 (defun make-repository (namespace &optional version)
    155   (g_irepository_require namespace (or version 'null))
    156   (lambda (name &rest args)
    157     (with-ref (p (g_irepository_find_by_name namespace name))
    158       (ecase (g_base_info_get_type p)
    159         (:function
    160          (g_function_info_invoke p args))
    161         (:object
    162          (destructuring-bind (method &rest arguments) args
    163            (with-ref (m (g_object_info_find_method p method))
    164              (assert (member :constructor (g_function_info_get_flags m)))
    165              (make-object (g_function_info_invoke m arguments) p))))))))
    166 
    167 (defun connect (object signal handler &optional after)
    168   (let* ((s (request 'connect object signal (if after 1 0)))
    169          (r (rw:peek-reader (rw:reader s)))
    170          (id (parse-integer (coerce (rw:till r) 'string))))
    171     (setf (gethash id *handlers*) handler))
    172   (values))
    173 
    174 (defun callback ()
    175   (let ((k (parse-integer (request 'callback))))
    176     (or (zerop k)
    177         (funcall (gethash k *handlers*))
    178         #+nil
    179         (let ((v (gethash k *handlers*)))
    180           (when v
    181             (funcall v))))))
    182 
    183 (defun demo1 ()
    184   (with-gi-server (*gi-server-program*)
    185     (funcall (make-repository "GLib" "2.0")
    186              'assertion_message
    187              'domain "glib-print.c" 30 'main "hello world")))
    188 
    189 (defun demo2 ()
    190   (with-gi-server (*gi-server-program*)
    191     (let ((gtk (make-repository "Gtk")))
    192       (funcall gtk 'init 0 'null)
    193       (let ((w (funcall gtk "Window" 'new 0)))
    194         (connect w 'destroy (lambda (&rest args)
    195                               (declare (ignore args))
    196                               (request 'exit)))
    197         (funcall w "show"))
    198       (loop
    199          do (funcall gtk 'main_iteration)
    200          while (callback)))))
    201 
    202 (defun demo3 ()
    203   (with-gi-server (*gi-server-program*)
    204     (let ((gtk (make-repository "Gtk")))
    205       (funcall gtk 'init 0 'null)
    206       (let ((w (funcall gtk "Window" 'new 0)))
    207         (funcall w 'set_title "Hello world")
    208         (funcall w 'set_default_size 400 300)
    209         (connect w 'destroy (lambda (&rest args)
    210                               (declare (ignore args))
    211                               (request 'exit)))
    212         (funcall w 'show_all))
    213       (loop
    214          do (funcall gtk 'main_iteration)
    215          while (callback)))))
    216 
    217 (defun demo4 ()
    218   (with-gi-server (*gi-server-program*)
    219     (let ((gtk (make-repository "Gtk")))
    220       (funcall gtk 'init 0 'null)
    221       (let ((w (funcall gtk "Window" 'new 0)))
    222         (funcall w 'set_border_width 10)
    223         (funcall w 'set_title "Hello world")
    224         (connect w 'destroy (lambda (&rest args)
    225                               (declare (ignore args))
    226                               (request 'exit)))
    227         (let ((b (funcall gtk "Button" 'new_with_label "Hello World")))
    228           (connect b 'clicked
    229                    (let ((i 0))
    230                      (lambda (&rest args)
    231                        (funcall w 'set_title
    232                                 (format nil "hi ~s ~s" (incf i) args)))))
    233           (funcall w 'add b))
    234         (funcall w 'show_all))
    235       (loop
    236          do (funcall gtk 'main_iteration)
    237          while (callback)))))
    238 
    239 (defun connect-glade-signals (glade fn)
    240   (let (*object*)
    241     (declare (special *object*))
    242     (labels ((rec (x)
    243                (when (consp x)
    244                  (let* ((head (car x))
    245                         (tail (cdr x))
    246                         (plain (atom head))
    247                         (e (if plain head (car head)))
    248                         (a (unless plain (cdr head))))
    249                    (case e
    250                      (:|object|
    251                        (let ((*object* a))
    252                          (declare (special *object*))
    253                          (mapc #'rec tail)))
    254                      (:|signal|
    255                        (funcall fn
    256                                 (getf *object* :|class|)
    257                                 (getf *object* :|id|)
    258                                 (getf a :|name|)
    259                                 (getf a :|handler|)
    260                                 (getf a :|swapped|)))
    261                      (t (mapc #'rec tail)))))))
    262       (rec (rw.xml:parse-xml glade)))))
    263 
    264 ;;https://python-gtk-3-tutorial.readthedocs.org/en/latest/builder.html
    265 (defun demo5 ()
    266   (with-gi-server (*gi-server-program*)
    267     (let ((glade (merge-pathnames "gi-server-demo5.glade"
    268                                   (or *compile-file-pathname*
    269                                       *load-pathname*)))
    270           (gtk (make-repository "Gtk")))
    271       (funcall gtk 'init 0 'null)
    272       (let ((b (funcall gtk "Builder" 'new)))
    273         (funcall b 'add_from_file (namestring glade))
    274         ;; TODO when retval is object
    275         (let ((w (make-object (funcall b 'get_object "window1")
    276                               ;; TODO automatically
    277                               (g_irepository_find_by_name "Gtk" "Window")))
    278               (b (make-object (funcall b 'get_object "button1")
    279                               ;; TODO automatically
    280                               (g_irepository_find_by_name "Gtk" "Button"))))
    281           (connect-glade-signals
    282            glade
    283            (lambda (class id signal handler swapped)
    284              ;;(print (list :@@@ class id signal handler swapped))
    285              ;;strip_identifier
    286              (cond
    287                ((string= handler "onDeleteWindow")
    288                 (connect w signal ;;'destroy ;;delete-event ;; TODO fix callback
    289                          (lambda (&rest args)
    290                            (declare (ignore args))
    291                            (request 'exit))))
    292                ((string= handler "onButtonPressed")
    293                 (connect b signal
    294                          (let ((i 0))
    295                            (lambda (&rest args)
    296                              (funcall w 'set_title
    297                                       (format nil "hi ~s ~s" (incf i) args)))))))))
    298           (funcall w 'show_all)))
    299       (loop
    300          do (funcall gtk 'main_iteration)
    301          while (callback)))))