ssax thread-safe? example

Bruce Butterfield <bab-lsrMmtCsshhWk0Htik3J/[email protected]> Mon, 15 Dec 2003 13:29:47 -0800

Newsgroups	gmane.lisp.scheme.ssax-sxml
Message-ID	<[email protected]>

OK, here's a paired down example of my problem. In the attached file 
(mzscheme version 205), xml-server is called from run-server. It calls 
test-parser which just prints stuff out to the output-port and returns 
slightly manipulated seeds. One or more external processes connect to 
port 9090 and write valid XML documents to the input port and read from 
the output port. A typical error message displayed is something like:

2003-12-15 13:22:29 session 2: xml-server exception: error: expects 
argument of type <string or symbol>; given ("[GIMatch] broken for " 
(|END| . col) " while expecting " |END| 10o)

which looks like something is getting stepped on. Note that if I put a 
semaphore around the call to make-parser (similar to the one in counter) 
everything works just ducky, if a little slow.

I know you aren't a PLT user but do you see anything obvious that I'm 
missing or misinterpreting here?

threadtest.ss (text/plain, 1.8 KB)

(require (lib "thread.ss")
         (lib "date.ss")
         (lib "ssax.ss" "ssax")
         (lib "myenv.ss" "ssax")
         (lib "input-parse.ss" "ssax")
         (lib "parse-error.ss" "ssax"))

(define *timeout* 120)

(define (report-parser-error port message . specialising-msgs)
  (error (cons message specialising-msgs)))

(set-parser-error! report-parser-error)

(define (start port)
  (run-server port xml-server *timeout*))

(date-display-format 'iso-8601)

(define (log-message msg)
  (let ((datestr
         (date->string (seconds->date (current-seconds)) #t)))
    (fprintf (current-error-port) "~a ~a~%" datestr msg)))

; use counter to distinguish threads in log
(define counter-sem (make-semaphore 1))

(define counter
  (let ((cnt 1))
    (lambda ()
      (semaphore-wait counter-sem)
      (begin0
        cnt
        (set! cnt (+ cnt 1))
        (semaphore-post counter-sem)))))
     
(define (test-parser inport outport)
  (#cs(SSAX:make-parser
       NEW-LEVEL-SEED
       (lambda (elem-gi attributes namespaces expected-content seed) 
         (fprintf outport "new: ~a<br>" seed)
         (cons elem-gi seed))
       
       FINISH-ELEMENT
       (lambda (elem-gi attributes namespaces parent-seed seed)
         (fprintf outport "finish: ~a<br>" seed)
         parent-seed)

       CHAR-DATA-HANDLER
       (lambda (string1 string2 seed)
         (fprintf outport "char: ~a " seed)
         seed))
        inport '()))
       
(define (xml-server iport oport)
  (let ((session (counter)))
    (with-handlers
        ((exn?
          (lambda (exn)
            (log-message
             (format "session ~a: xml-server exception: ~a" session 
               (exn-message exn)))
            #f)))
      (log-message (format "session ~a BEGIN" session))
      (test-parser iport oport)
      (log-message (format "session ~a END" session)))))

(start 9090)