;;;; 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 scheme)
(import (except foreign foreign-declare))
(use easyffi data-structures)

(declare
  (fixnum)
  (disable-interrupts))

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

(foreign-parse #<<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);
XML_ParserSruct *XML_ParserCreateNS(const char *enc, char sep);
XML_ParserSruct *XML_ExternalEntityParserCreate(struct XML_ParserStruct *p, char *, char *);
void XML_ParserFree(struct XML_ParserStruct *p);
___safe ___bool XML_Parse(struct XML_ParserStruct *p, const 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_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?)

(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 (expat:make-parser #!key (encoding #f) (namespaces #f) (namespace-separator #\:))
  (make-expat:parser 
   (if namespaces
       (XML_ParserCreateNS encoding namespace-separator)
       (XML_ParserCreate encoding) )
   #f) )

(define (expat:make-external-entity-parser parser context #!key (encoding #f))
  (make-expat:parser
   (XML_ExternalEntityParserCreate (expat:parser-ptr parser) context encoding) 
   #t) )

(define (expat:destroy-parser p)
  (XML_ParserFree (expat:parser-ptr p))
  (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 (expat:parse p str #!key (length (string-length str)) (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 (XML_Parse (expat:parser-ptr p) str length 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 current-start-handler (make-parameter #f))
(define current-end-handler (make-parameter #f))
(define current-char-handler (make-parameter #f))
(define current-pi-handler (make-parameter #f))
(define current-comment-handler (make-parameter #f))
(define current-external-entity-ref-handler (make-parameter #f))

#>
static void extract_attributes(C_word c, C_word self, C_word k, C_word attrptr)
{
  char **attrs = (char **)C_block_item(attrptr, 0);
  C_word attrlist = C_SCHEME_END_OF_LIST;
  C_word *buf, str1, str2, *sp0 = C_temporary_stack;
  int len1, len2;

  /* This code doesn't check for stack-exhaustion, but should work anyway... */

  while(*attrs != NULL) {
    len1 = C_strlen(*attrs);	 
    len2 = C_strlen(attrs[ 1 ]);	 
    buf = C_alloc(C_SIZEOF_PAIR * 2 + C_SIZEOF_STRING(len1) + C_SIZEOF_STRING(len2));
    C_save(attrlist);
    str1 = C_string(&buf, len1, *(attrs++));
    C_save(str1);
    str2 = C_string(&buf, len2, *(attrs++));
    str1 = C_restore;
    attrlist = C_pair(&buf, str1, str2);
    attrlist = C_pair(&buf, attrlist, C_restore);
  }

  assert(sp0 == C_temporary_stack);
  C_kontinue(k, attrlist);
}

static void extract_string(C_word c, C_word self, C_word k, C_word ptr, C_word len)
{
  int bytes = C_unfix(len);
  C_word *buf = C_alloc(C_SIZEOF_STRING(bytes));
  
  C_kontinue(k, C_string(&buf, bytes, (char *)C_block_item(ptr, 0)));
}
<#

(define extract_attributes (##core#primitive "extract_attributes"))
(define extract_string (##core#primitive "extract_string"))

(define-external (C_generic_start_handler (c-pointer data) (c-string tag) (c-pointer attrs)) void
  (let ([h (current-start-handler)])
    (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)])
    (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)])
    (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)])
    (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)])
    (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)])
    (if (if h
	    (safe (lambda () (h context base sysid pubid)))
	    #t)
	XML_STATUS_OK
	XML_STATUS_ERROR) ) )

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

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

(define (expat:set-character-data-handler! p proc)
  (current-char-handler proc)
  (XML_SetCharacterDataHandler (expat:parser-ptr p) #$C_generic_char_handler) )

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

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

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

) ; end of module