;;;; expat.scm
;
; Copyright (c) 2000-2005, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany
; 


(module expat
	(expat:make-parser expat:destroy-parser expat:parse expat:parser?
	  expat:make-external-entity-parser
	  expat:set-start-handler! expat:set-end-handler! expat:set-character-data-handler!
	  expat:set-external-entity-ref-handler!
	  expat:set-processing-instruction-handler! expat:set-comment-handler!

	;; These shouldn't be necessary to export for the user, but they are
	;; necessary callbacks from the expat lib into Scheme;
	;; otherwise if we don't export them we get an error like this:
	;; Error: bad argument count - received 3 but expected 2: #<procedure>
	;; test.scm:449: expat#expat:parse			<--
	;; Felix's old comment was:
 	;; This is a workaround for a stupid bug in the optimizer (1.91)
 	 C_generic_start_handler C_generic_end_handler
         C_generic_char_handler C_generic_pi_handler C_generic_comment_handler
         C_generic_external_entity_ref_handler )

(import (chicken base) scheme (chicken blob) (chicken condition)
	(chicken memory) (chicken string) srfi-4)
(import (except (chicken foreign) foreign-declare))
(import bind)

(declare
  (fixnum)
  (disable-interrupts))

(define get-user-data
  (foreign-lambda* c-pointer (((c-pointer (struct XMLParserStruct)) p))
    "C_return(XML_GetUserData(p));"))

(define make-gc-root           ;; Create non-finalizable GC root pointing to OBJ
  (foreign-lambda* c-pointer ((scheme-object obj))
    "void *root = CHICKEN_new_gc_root();"
    "if (root == NULL) C_return(NULL);"
    "CHICKEN_gc_root_set(root, obj);"
    "C_return(root);"))
(define gc-root-ref
  (foreign-lambda scheme-object CHICKEN_gc_root_ref c-pointer))
(define free-gc-root
  (foreign-lambda void CHICKEN_delete_gc_root c-pointer))

#>
#include <expat.h>
#include <assert.h>
<#

(bind #<<EOF
const int XML_PARAM_ENTITY_PARSING_NEVER;
const int XML_PARAM_ENTITY_PARSING_ALWAYS;
const int XML_PARAM_ENTITY_PARSING_UNLESS_STANDALONE;

const int XML_STATUS_OK;
const int XML_STATUS_ERROR;

struct XML_ParserStruct *XML_ParserCreate(const char *enc);
struct XML_ParserStruct *XML_ParserCreateNS(const char *enc, char sep);
struct XML_ParserStruct *XML_ExternalEntityParserCreate(struct XML_ParserStruct *p, char *, char *);
void XML_ParserFree(struct XML_ParserStruct *p);
___safe ___bool XML_Parse(struct XML_ParserStruct *p, const unsigned char *s, int len, ___bool isfinal);
int XML_GetErrorCode(struct XML_ParserStruct *p);
char *XML_ErrorString(int code);
void XML_SetParamEntityParsing(struct XML_ParserStruct *p, int);
int XML_GetCurrentLineNumber(struct XML_ParserStruct *p);
int XML_GetCurrentColumnNumber(struct XML_ParserStruct *p);
void XML_SetUserData(struct XML_ParserStruct *parser, void *userData);
void XML_SetStartElementHandler(struct XML_ParserStruct *p, void (*)(void *, const char *, const char **));
void XML_SetEndElementHandler(struct XML_ParserStruct *p, void (*)(void *, const char *));
void XML_SetCharacterDataHandler(struct XML_ParserStruct *p, void (*)(void *, const char *, int));
void XML_SetProcessingInstructionHandler(struct XML_ParserStruct *p, void (*)(void *, const char *, const char *));
void XML_SetCommentHandler(struct XML_ParserStruct *p, void (*)(void *, const char *));
void XML_SetExternalEntityRefHandler(struct XML_ParserStruct *p, void (*)(void *, const char *, const char *, const char *, const char *));

EOF
)

(define-record expat:parser ptr external? handlers)
(define-record handlers
  start-handler end-handler character-data-handler pi-handler
  comment-handler external-entity-ref-handler)

(define (make-empty-handlers)
(make-handlers #f #f #f #f #f #f))

(define (copy-handlers old)
  (make-handlers
   (handlers-start-handler old)
   (handlers-end-handler old)
   (handlers-character-data-handler old)
   (handlers-pi-handler old)
   (handlers-comment-handler old)
   (handlers-external-entity-ref-handler old)))

(define (expat:error p where 
		     #!optional
		     (msg (conc (XML_GetCurrentLineNumber (expat:parser-ptr p)) "." 
				(XML_GetCurrentColumnNumber (expat:parser-ptr p)) ": "
				(XML_ErrorString (XML_GetErrorCode (expat:parser-ptr p)))) )
		     (args '()) )
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message msg 'location where 'arguments args)
    (make-property-condition 'expat 'parser p) ) ) )

(define (update-userdata! parser)
  (let ((root (make-gc-root parser)))
    (when (not root)
      (expat:error parser 'failed-to-allocate-memory))
    (XML_SetUserData (expat:parser-ptr parser) root)))

(define (expat:make-parser #!key (encoding #f) (namespaces #f) (namespace-separator #\:))
  (let ((p
	 (make-expat:parser 
	  (if namespaces
	      (XML_ParserCreateNS encoding namespace-separator)
	      (XML_ParserCreate encoding) )
	  #f
	  (make-empty-handlers))))
    (update-userdata! p)
    p))

(define (expat:make-external-entity-parser parser context #!key (encoding #f))
  (let ((p
	 (make-expat:parser
	  (XML_ExternalEntityParserCreate (expat:parser-ptr parser) context encoding) 
	  #t
	  (copy-handlers (expat:parser-handlers parser)))))
    (update-userdata! p)
    p))

(define (expat:destroy-parser p)
  (let ((user-data (get-user-data (expat:parser-ptr p))))
    (XML_ParserFree (expat:parser-ptr p))
    (free-gc-root user-data))
  (expat:parser-ptr-set! p #f) )

(cond-expand [safe-callbacks

(define (safe thunk)
  (handle-exceptions ex (current-expat-exception ex) 
    (thunk) ) )

(define current-expat-exception (make-parameter #f))

] [else

(define (safe thunk) (thunk))

])

(define (as-u8vector obj)
  (cond
   ((u8vector? obj) obj)
   ((blob? obj) (blob->u8vector obj))
   ((string? obj) (blob->u8vector (string->blob obj)))))

(define (expat:parse p input #!key (final #t) (external-entities #f))
  (XML_SetParamEntityParsing
   (expat:parser-ptr p)
   (case external-entities
     [(never #f) XML_PARAM_ENTITY_PARSING_NEVER]
     [(unless-standalone) XML_PARAM_ENTITY_PARSING_UNLESS_STANDALONE]
     [(always #t) XML_PARAM_ENTITY_PARSING_ALWAYS] 
     [else (error "invalid argument for `external-entities:' keyword argument" external-entities)] ) )
  (or (let ((bytes (as-u8vector input)))
	(XML_Parse (expat:parser-ptr p) bytes (u8vector-length bytes) final))
      (and (not (expat:parser-external? p))
	   (begin
	     (cond-expand [safe-callbacks
			   (let ([ex (current-expat-exception)])
			     (when ex (signal ex)) ) ]
			  [else] )
	     (expat:error p 'expat:parse) ) ) ) )

(define string-at-pos
  (foreign-safe-lambda*
      c-string (((c-pointer (c-pointer char)) a) (int pos))
    "if (!a[pos]) C_return(NULL);"
    "C_return(a[pos]);"))

(define (extract-attributes a)
  (let loop ((l '()) (i 0))
    (let ((k (string-at-pos a i)))
      (if k
	  (loop (cons (cons k (string-at-pos a (add1 i))) l) (+ i 2))
	  l))))

(define (extract-string text len)
  (let ((str (make-string len)))
    (move-memory! text str len)
    str))

(define current-start-handler (compose handlers-start-handler expat:parser-handlers gc-root-ref))
(define current-end-handler (compose handlers-end-handler expat:parser-handlers gc-root-ref))
(define current-char-handler (compose handlers-character-data-handler expat:parser-handlers gc-root-ref))
(define current-pi-handler (compose handlers-pi-handler expat:parser-handlers gc-root-ref))
(define current-comment-handler (compose handlers-comment-handler expat:parser-handlers gc-root-ref))
(define current-external-entity-ref-handler
  (compose
   handlers-external-entity-ref-handler expat:parser-handlers gc-root-ref
   get-user-data))

(define-external (C_generic_start_handler (c-pointer data) (c-string tag) (c-pointer attrs)) void
  (let ([h (current-start-handler data)])
    (when h (safe (lambda () (h tag (extract-attributes attrs))) ) ) ) )

(define-external (C_generic_end_handler (c-pointer data) (c-string tag)) void
  (let ([h (current-end-handler data)])
    (when h (safe (lambda () (h tag)) ) ) ))

(define-external (C_generic_char_handler (c-pointer data) (c-pointer text) (int len)) void
  (let ([h (current-char-handler data)])
    (when h (safe (lambda () (h (extract-string text len))) ) ) ))

(define-external (C_generic_pi_handler (c-pointer data) (c-string target) (c-string text)) void
  (let ([h (current-pi-handler data)])
    (when h (safe (lambda () (h target text)) ) )))

(define-external (C_generic_comment_handler (c-pointer data) (c-string text)) void
  (let ([h (current-comment-handler data)])
    (when h (safe (lambda () (h text)) ) )))

(define-external (C_generic_external_entity_ref_handler
		  (c-pointer parser) (c-string context) (c-string base) (c-string sysid)
		  (c-string pubid) ) 
  int
  (let ([h (current-external-entity-ref-handler parser)])
    (if (if h
	    (safe (lambda () (h (gc-root-ref (get-user-data parser)) context base sysid pubid)))
	    #t)
	XML_STATUS_OK
	XML_STATUS_ERROR) ) )

(define (expat:set-start-handler! p proc)
  (handlers-start-handler-set! (expat:parser-handlers p) proc)
  (XML_SetStartElementHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_start_handler #f)))

(define (expat:set-end-handler! p proc)
  (handlers-end-handler-set! (expat:parser-handlers p) proc)
  (XML_SetEndElementHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_end_handler #f)))

(define (expat:set-character-data-handler! p proc)
  (handlers-character-data-handler-set! (expat:parser-handlers p) proc)
  (XML_SetCharacterDataHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_char_handler #f)))

(define (expat:set-processing-instruction-handler! p proc)
  (handlers-pi-handler-set! (expat:parser-handlers p) proc)
  (XML_SetProcessingInstructionHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_pi_handler #f)))

(define (expat:set-comment-handler! p proc)
  (handlers-comment-handler-set! (expat:parser-handlers p) proc)
  (XML_SetCommentHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_comment_handler #f)))

(define (expat:set-external-entity-ref-handler! p proc)
  (handlers-external-entity-ref-handler-set! (expat:parser-handlers p) proc)
  (XML_SetExternalEntityRefHandler
   (expat:parser-ptr p)
   (if proc #$C_generic_external_entity_ref_handler #f)))

) ; end of module