;;; _ _ _ ;;; | \ | | ___ | |_ ___ ___ ;;; | \| |/ _ \| __/ _ \/ __| ;;; | |\ | (_) | || __/\__ \ ;;; |_| \_|\___/ \__\___||___/ ;;; Scheme foreign interface doesn't handle char** at all. ;;; Better to pass around a c-pointer (void*) and convert to char** when needed ;;; (define (string-left len s) (if (> len (string-length s)) (string-take s len))) ;;; _____ _ _____ ;;; | ___|__ _ __ ___(_) __ _ _ __ |_ _| _ _ __ ___ ___ ;;; | |_ / _ \| '__/ _ \ |/ _` | '_ \ | || | | | '_ \ / _ \/ __| ;;; | _| (_) | | | __/ | (_| | | | | | || |_| | |_) | __/\__ \ ;;; |_| \___/|_| \___|_|\__, |_| |_| |_| \__, | .__/ \___||___/ ;;; |___/ |___/|_| (define-foreign-type doc (c-pointer "xmlDoc")) (define-foreign-type node (c-pointer "xmlNode")) (define-foreign-type parser-context (c-pointer "xmlParserCtxt")) (define-foreign-type text-writer (c-pointer "xmlTextWriter")) (define-foreign-type text-reader (c-pointer "xmlTextReader")) (define-foreign-type sax-handler (c-pointer "xmlSAXHandler")) ;;; __ __ _ ;;; | \/ (_)___ ___ ;;; | |\/| | / __|/ __| ;;; | | | | \__ \ (__ _ ;;; |_| |_|_|___/\___(_) ;;; Converts a simple list into a a-list ;;; e.g (id name bot alice) -> ((id . name) (bot . alice)) (define (list->pair-alist in #!optional (result '())) (if (eq? in #f) #f (if (>= (length in) 2) ; Create the pair and join the result list (list->pair-alist (cddr in) `((,(car in) . ,(cadr in)) . ,result)) result))) ; Assumes attributes is an association list (define (attributes->string attributes) (if (not (pair? attributes)) "" (foldl (lambda (result x) (string-append result (string-join `(" " ,(car x) "=\"" ,(cdr x) "\"" ) ""))) "" attributes))) ;;; ____ ___ __ __ ;;; | _ \ / _ \| \/ | ;;; | | | | | | | |\/| | ;;; | |_| | |_| | | | | ;;; |____/ \___/|_| |_| (define (dom-demo) (define (print-element-names node) (let loop ((n node)) (when n (when (dom:is-element-node? n) (print "element <" (dom:node-name n) ">" ) (print "@ => " (dom:attributes n))) (when (dom:is-text-node? n) (print "content => " (dom:node-content n))) (print-element-names (dom:node-children n)) (loop (dom:next-node n))))) (define ctx (dom:make-parser-context)) (define doc (dom:read-file-with-context ctx "foo.xml" #f 0)) (define root (dom:root-element doc)) (define valid? (dom:is-valid? ctx)) (print "XML is valid?: " valid?) (print "root: " root) (print-element-names root) (dom:free-doc doc) (dom:cleanup-parser)) (define dom:element-node 1) (define dom:attribute-node 2) (define dom:text-node 3) (define dom:cdata_section_node 4) (define dom:entity-ref-node 5) (define dom:entity-node 6) (define dom:pi-node 7) (define dom:comment-node 8) (define dom:document-node 9) (define dom:document-type-node 10) (define dom:document-frag-node 11) (define dom:notation-node 12) (define dom:html-document-node 13) (define dom:dtd-node 14) (define dom:element-decl 15) (define dom:attribute-decl 16) (define dom:entity-decl 17) (define dom:namespace-decl 18) (define dom:xinclude-start 19) (define dom:xinclude-end 20) (define (dom:is-element-node? node) (= (dom:node-type node) dom:element-node)) (define (dom:is-text-node? node) (= (dom:node-type node) dom:text-node)) (define (dom:is-attribute-node? node) (= (dom:node-type node) dom:attribute-node)) ;;; Parser (define dom:parse-string ;;; buffer, size, URL, encoding, options (foreign-lambda doc "xmlReadMemory" c-string int c-string c-string int)) (define (dom:parse-string-default str) (dom:parse-string-default-helper str (string-length str))) (define (dom:parse-string-default-helper str size) (dom:parse-string str size "noname.xml" #f 0)) (define dom:cleanup-parser (foreign-lambda void "xmlCleanupParser")) (define dom:memory-dump ;;; This is to debug memory for regression tests (foreign-lambda void "xmlMemoryDump")) (define dom:parse-file (foreign-lambda doc "xmlParseFile" c-string)) (define dom:free-doc (foreign-lambda void "xmlFreeDoc" doc)) (define dom:make-parser-context (foreign-lambda parser-context "xmlNewParserCtxt")) (define dom:read-file-with-context (foreign-lambda doc "xmlCtxtReadFile" parser-context c-string c-string int)) (define dom:is-valid? (foreign-safe-lambda* bool ((parser-context ctx)) "if (ctx->valid == 0) \n" " C_return(C_SCHEME_TRUE); \n" " C_return(C_SCHEME_FALSE);")) (define dom:free-parser-context (foreign-lambda void "xmlFreeParserCtxt" parser-context)) (define dom:to-string (foreign-safe-lambda* scheme-object ((doc document) (node currentNode)) "C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;\n" "xmlBufferPtr buffer = xmlBufferCreate();\n" "int size = xmlNodeDump(buffer, document, currentNode, 0, 1);\n" "a = C_alloc(C_SIZEOF_STRING(size));\n" "str = C_string(&a, size, buffer->content);\n" "xmlBufferFree(buffer);\n" "C_return(str);\n")) (define dom:copy-doc (foreign-lambda doc "xmlCopyDoc" doc int)) (define dom:root-element (foreign-lambda node "xmlDocGetRootElement" doc)) (define dom:copy-node (foreign-lambda node "xmlCopyNode" node int)) (define dom:copy-node-list (foreign-lambda node "xmlCopyNodeList" node)) (define dom:next-node (foreign-safe-lambda* node ((node currentNode)) "C_return(currentNode->next);")) (define dom:node-content (foreign-safe-lambda* c-string ((node currentNode)) "C_return(currentNode->content);")) (define dom:node-children (foreign-safe-lambda* node ((node currentNode)) "C_return(currentNode->children);")) (define dom:node-type (foreign-safe-lambda* int ((node currentNode)) "C_return(currentNode->type);")) (define dom:node-name (foreign-safe-lambda* c-string ((node currentNode)) "C_return(currentNode->name);")) (define dom:is-element-name? (foreign-safe-lambda* bool ((c-string name) (node currentNode)) "C_return(!xmlStrcmp(currentNode->name, (const xmlChar *) name));")) (define dom:get-attribute (foreign-safe-lambda* c-string ((c-string key) (node currentNode)) "C_return(xmlGetProp(currentNode, key));")) ;;; TODO ;;;(define dom:li->string ;;; (foreign-self-lambda* scheme-object ((node n)) ;;; "C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;\n" ;;; "\n" ;;; ;;; "if (!(n && n->properties))\n" ;;; " C_return(C_SCHEME_FALSE);\n" ;;; "\n" ;;; Reads the attributes into a simple list. ;;; e.g. properties))\n" " C_return(C_SCHEME_FALSE);\n" "\n" "xmlAttr* attribute = n->properties;\n" "while(attribute && attribute->name && attribute->children) {\n" " xmlChar* value = xmlNodeListGetString(n->doc, attribute->children, 1);\n" ;;; Add the value " len = strlen(value);\n" " a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));\n" " str = C_string(&a, len, value);\n" " lst = C_a_pair(&a, str, lst);\n" ;;; Add the key " len = strlen(attribute->name);\n" " a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));\n" " str = C_string(&a, len, attribute->name);\n" " lst = C_a_pair(&a, str, lst);\n" " xmlFree(value);\n" " attribute = attribute->next; \n" " }" " C_return(lst);\n")) (define (dom:attributes n) (list->pair-alist (dom:attributes-helper n))) ;;; ____ _ __ __ ;;; / ___| / \ \ \/ / ;;; \___ \ / _ \ \ / ;;; ___) / ___ \ / \ ;;; |____/_/ \_\/_/\_\ ;;; Externally defined call-back procedures (define sax:*on-start-element* #f) (define sax:*on-end-element* #f) (define sax:*on-characters* #f) ;;; Converts the attributes (char**) to a Scheme list (define sax:attributes->list (foreign-safe-lambda* scheme-object ((c-pointer ptr) (int nb)) "const int fields = 5;" "char** p = (char**)(ptr);" "C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;" "int i;" "for (i = 0; i < nb; i++) {" " const xmlChar *localname = p[i * fields + 0];" " const xmlChar *prefix = p[i * fields + 1];" " const xmlChar *URI = p[i * fields + 2];" " const xmlChar *value_start = p[i * fields + 3];" " const xmlChar *value_end = p[i * fields + 4];" " int size = value_end - value_start;" " xmlChar* value = (xmlChar *) malloc(sizeof(xmlChar) * size + 1);" " memcpy(value, value_start, size);" " value[size] = \'\\0\';" ;;; Add the value " len = strlen(value);\n" " a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));\n" " str = C_string(&a, len, value);\n" " lst = C_a_pair(&a, str, lst);\n" ;;; Add the key " len = strlen(localname);\n" " a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));\n" " str = C_string(&a, len, localname);\n" " lst = C_a_pair(&a, str, lst);\n" " free(value);" "}" "C_return(lst);")) (define-external (onCharacters (c-pointer context) (c-string characters) (int size)) void (if sax:*on-characters* (sax:*on-characters* (string-left size characters)) (print "[" (string-left size characters) "]"))) (define-external (onStartElement (c-pointer context) (c-string localname) (c-string prefix) (c-string uri) (int nb_namespaces) (c-pointer namespaces) (int nb_attributes) (int nb_defaulted) (c-pointer attributes)) void ;;; Build the attribute association list (let* ((attribute-list (if (<= nb_attributes 0) #f (list->pair-alist (sax:attributes->list attributes nb_attributes))))) (if sax:*on-start-element* (sax:*on-start-element* localname attribute-list) (print "<" localname ">")))) (define-external (onEndElement (c-pointer context) (c-string localname) (c-string prefix) (c-string uri)) void (if sax:*on-end-element* (sax:*on-end-element* localname) (print "<" localname "/>"))) ;;; SAX ;;; Callbacks can only be called from a foreign-safe-lambda so use a safe-lambda* ;;; here even though it's simple call to the C function and a foreign-lambda ;;; would normally suffice. (define sax:parse-file (foreign-safe-lambda* int ((sax-handler handler) (c-pointer userData) (c-string filename)) "xmlSAXUserParseFile(handler, userData, filename);")) (define sax:parse-string (foreign-lambda int "xmlSAXUserParseMemory" sax-handler c-pointer c-string int)) (define (sax:make-handler on-start on-end on-characters) (set! sax:*on-start-element* on-start) (set! sax:*on-end-element* on-end) (set! sax:*on-characters* on-characters) (sax:make-handler-helper)) (define sax:make-handler-helper (foreign-safe-lambda* sax-handler () "xmlSAXHandler* handler = (xmlSAXHandler*) malloc(sizeof(xmlSAXHandler));" "memset(handler, 0, sizeof(xmlSAXHandler));" "handler->initialized = XML_SAX2_MAGIC;" "handler->startElementNs = onStartElement;" "handler->endElementNs = onEndElement;" "handler->characters = onCharacters;" "C_return(handler);")) (define sax:free-handler (foreign-safe-lambda* void ((sax-handler handler)) "free(handler);")) ;;; _____ _ ____ _ ;;; |_ _|____ _| |_ | _ \ ___ __ _ __| | ___ _ __ ;;; | |/ _ \ \/ / __| | |_) / _ \/ _` |/ _` |/ _ \ '__| ;;; | | __/> <| |_ | _ < __/ (_| | (_| | __/ | ;;; |_|\___/_/\_\\__| |_| \_\___|\__,_|\__,_|\___|_| (define text-reader:none 0) (define text-reader:element 1) (define text-reader:attribute 2) (define text-reader:text 3) (define text-reader:cdata 4) (define text-reader:entity-reference 5) (define text-reader:entity 6) (define text-reader:processing-instruction 7) (define text-reader:comment 8) (define text-reader:document 9) (define text-reader:document-type 10) (define text-reader:document-fragmenta 11) (define text-reader:notation 12) (define text-reader:whitespace 13) (define text-reader:significant-whitespace 14) (define text-reader:end-element 15) (define text-reader:end-entity 16) (define text-reader:xml-declaration 17) (define (text-reader:element-to-string r) (when (not (text-reader:element-node? r)) (error "Node is not the start of an XML element")) (define stack (make-stack)) (define start-element (text-reader:name r)) (let loop ((depth 0)) (let ((name (text-reader:name r)) (value (text-reader:value r)) (empty? (text-reader:empty-element? r))) (cond ;;; Node is an element-start ((text-reader:element-node? r) (stack-push! stack (string-join `("<" ,name ,(attributes->string (text-reader:all-attributes r)) ,(if empty? "/>" ">")) "")) (when (not empty?) (set! depth (+ depth 1)))) ;;; Node is text ((text-reader:text-node? r) (stack-push! stack value)) ;;; Node is an element-end ((text-reader:end-element-node? r) (set! depth (- depth 1)) (stack-push! stack (string-join `("") "")))) (if (and (> depth 0) (> (text-reader:read-more r) 0)) (loop depth)))) (string-join (reverse (stack->list stack)) " ")) (define (text-reader:end-element-is? name reader) (and (= (text-reader:node-type reader) text-reader:end-element) (string? (text-reader:name reader)) (string-ci=? (text-reader:name reader) name ))) (define (text-reader:start-element-is? name reader) (and (= (text-reader:node-type reader) text-reader:element) (string? (text-reader:name reader)) (string-ci=? (text-reader:name reader) name))) (define (text-reader:end-element-node? reader) (= (text-reader:node-type reader) text-reader:end-element)) (define (text-reader:text-node? reader) (= (text-reader:node-type reader) text-reader:text)) (define (text-reader:element-node? reader) (= (text-reader:node-type reader) text-reader:element)) (define text-reader:make (foreign-lambda text-reader "xmlNewTextReaderFilename" c-string)) (define text-reader:read-more (foreign-lambda int "xmlTextReaderRead" text-reader)) (define text-reader:free (foreign-lambda void "xmlFreeTextReader" text-reader)) (define text-reader:depth (foreign-lambda int "xmlTextReaderDepth" text-reader)) (define text-reader:node-type (foreign-lambda int "xmlTextReaderNodeType" text-reader)); (define text-reader:empty-element? (foreign-lambda bool "xmlTextReaderIsEmptyElement" text-reader)) (define text-reader:move-to-attribute (foreign-lambda int "xmlTextReaderMoveToAttribute" text-reader c-string)) (define (text-reader:all-attributes r) (define (helper rc result) (if (> rc 0) (let* ((new `(,(text-reader:name r) . ,(text-reader:value r))) (attributes (cons new result))) (helper (text-reader:move-to-next-attribute r) attributes)) (and (not (null? result)) result))) (and (text-reader:element-node? r) (text-reader:move-to-first-attribute r) (helper (text-reader:move-to-first-attribute r) (list)))) (define text-reader:move-to-next-attribute (foreign-lambda int "xmlTextReaderMoveToNextAttribute" text-reader)) (define text-reader:move-to-first-attribute (foreign-lambda int "xmlTextReaderMoveToFirstAttribute" text-reader)) (define text-reader:move-to-element (foreign-lambda int "xmlTextReaderMoveToElement" text-reader)) (define text-reader:next (foreign-lambda int "xmlTextReaderNext" text-reader)) (define text-reader:next-sibling (foreign-lambda int "xmlTextReaderNextSibling" text-reader)) (define text-reader:name (foreign-lambda c-string "xmlTextReaderName" text-reader)) (define text-reader:value (foreign-lambda c-string "xmlTextReaderValue" text-reader))