groworld/plant-eyes/scripts/jabberer.ss

;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]

#lang scheme/base
(require scheme/class); openssl (prefix-in xmpp: "xmpp.ss"))
(provide (all-defined-out))

; a class which wraps the xmpp in a thread and allows messages to be picked up
; and sent by the game

(define debug-netloop #f)

(define jabberer%
    (class object%
      (init-field
       (jid "none@nowhere")
       (pass "xxxx"))
      
        (field 
            (incoming '())
            (outgoing '())
            (thr 0)
            (debug-jab #f))
        
        (define/public (get-incoming)
            incoming)
        
        (define/public (clear-incoming)
            (set! incoming '()))
        
        (define/public (msg-waiting?)
            (not (null? incoming)))
        
        (define/public (get-msg)
            (let ((msg (car incoming)))
                (set! incoming (cdr incoming))
                msg))
        
        (define/public (send-msg to msg)
          (set! outgoing (append outgoing (list (list to msg)))))
        
        (define (message-handler sz) 0)
           ; (when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz)))
            ;(set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming)))
        
        (define/public (start)
          (set! thr (thread run)))
        
        (define/public (stop)
            (kill-thread thr))
        
        (define (run) 0
            #;(xmpp:with-xmpp-session jid pass
                (xmpp:set-xmpp-handler 'message message-handler)
                (let loop () 
                    (when debug-netloop (printf ".~n"))
                    (when (not (null? outgoing))                             
		      (when debug-jab (printf "tx ----> ~a ~a~n" (car (car outgoing)) (cadr (car outgoing))))
                      (xmpp:send (xmpp:message (car (car outgoing)) (cadr (car outgoing))))        
                      (set! outgoing (cdr outgoing)))
                    (sleep 0.221)
                    (loop))))
        (super-new)))