MeMe/meme/libxml2.scm

;; Copyright (C) 2023 Skylar Widulski <cobra@vern.cc>
;;
;; This file is part of MeMe
;;
;; MeMe is free software: you can redistribute it and/or modify it under the
;; terms of the GNU Affero General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option) any
;; later version.
;;
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of  MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public License
;; for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (meme libxml2)
  #:use-module (rnrs)
  #:use-module (system foreign)
  #:use-module (system foreign-library)
  #:export (gumbo-libxml-parse
            xml-doc-get-root-element
            xml-free-doc
            xml-node-list-get-string
            xml-xpath-new-context
            xml-xpath-eval-expression
            xml-xpath-free-object
            xml-child-element-count
            xml-xpath-object
            xml-node
            xml-nodeset
            next
            child
            child1
            props
            name
            doc
            nodeset
            nodeset-nodes
            floatval
            strval
            dump-xml
            get-xpath
            dump-xpath-xml
            get-xpath-string
            get-xpath-nodeset
            get-xpath-node))

(define libxml2 (dynamic-link "libxml2"))
(define gumbo-libxml (dynamic-link "./gumbo-libxml/.libs/libgumbo_xml.so"))

(define xml-xpath-object
  (list int    ; xmlXPathObjectType type
        '*     ; xmlNodeSetPtr nodesetval
        int    ; int boolval
        double ; floatval
        '*     ; xmlChar *stringval
        '*     ; void *user
        int    ; int index
        '*     ; void *user2
        int    ; int index2
        ))
(define xml-nodeset
  (list int
        int
        '*))
(define xml-node
  (list '*  ; void *_private
        int ; xmlElementType type
        '*  ; char *name
        '*  ; _xmlNode *children
        '*  ; _xmlNode *last
        '*  ; _xmlNode *parent
        '*  ; _xmlNode *next
        '*  ; _xmlNode *prev
        '*  ; _xmlDoc *doc
        '*  ; _xmlNs *ns
        '*  ; xmlChar *content
        '*  ; _xmlDict *dict
        '*  ; void *psvi
        '*  ; _xmlAttr *properties
        '*)); _xmlNs *nsDef
(define xml-buffer
  (list '*   ; xmlChar *content
        unsigned-int  ; unsigned int use
        unsigned-int  ; unsigned int size
        int)); xmlBufferAllocationScheme alloc

(define gumbo-libxml-parse
  (pointer->procedure '*
                      (dynamic-func "gumbo_libxml_parse" gumbo-libxml)
                      (list '*)))
(define xml-doc-get-root-element
  (pointer->procedure '*
                      (dynamic-func "xmlDocGetRootElement" libxml2)
                      (list '*)))

(define xml-free-doc
  (pointer->procedure void
                      (dynamic-func "xmlFreeDoc" libxml2)
                      (list '*)))
(define xml-node-list-get-string
  (pointer->procedure '*
                      (dynamic-func "xmlNodeListGetString" libxml2)
                      (list '* '* int)))
(define xml-buffer-create
  (pointer->procedure '*
                      (dynamic-func "xmlBufferCreate" libxml2)
                      (list)))
(define xml-node-dump
  (pointer->procedure void
                      (dynamic-func "xmlNodeDump" libxml2)
                      (list '* '* '* int int)))
(define xml-unlink-node
  (pointer->procedure void
                      (dynamic-func "xmlUnlinkNode" libxml2)
                      (list '*)))

(define xml-xpath-new-context
  (pointer->procedure '*
                      (dynamic-func "xmlXPathNewContext" libxml2)
                      (list '*)))
(define xml-xpath-eval-expression
  (pointer->procedure '*
                      (dynamic-func "xmlXPathEvalExpression" libxml2)
                      (list '* '*)))
(define xml-xpath-free-object
  (pointer->procedure void
                      (dynamic-func "xmlXPathFreeObject" libxml2)
                      (list '*)))
(define xml-xpath-free-context
  (pointer->procedure void
                      (dynamic-func "xmlXPathFreeContext" libxml2)
                      (list '*)))
(define xml-child-element-count
  (pointer->procedure unsigned-long
                      (dynamic-func "xmlChildElementCount" libxml2)
                      (list '* int)))

(define (next ptr times)
  (if (= times 0)
    (list-ref (parse-c-struct ptr xml-node) 6)
    (next (next ptr 0) (- times 1))))
(define (child ptr)
  (cadddr (parse-c-struct ptr xml-node)))
(define (child1 ptr times)
  (if (= times 0)
    (next (child ptr) 0)
    (child1 (next (child ptr) 0) (- times 1))))
(define (props ptr)
  (list-ref (parse-c-struct ptr xml-node) 11))
(define (name ptr)
  (pointer->string (caddr (parse-c-struct ptr xml-node))))
(define (doc ptr)
  (list-ref (parse-c-struct ptr xml-node) 8))

(define (nodeset ptr)
  (cadr (parse-c-struct ptr xml-xpath-object)))
(define (nodeset-nodes ptr)
  (dereference-pointer (caddr (parse-c-struct ptr xml-nodeset))))
(define (floatval ptr)
  (cadddr (parse-c-struct ptr xml-xpath-object)))
(define (strval ptr)
  (list-ref (parse-c-struct ptr xml-xpath-object) 4))

(define (dump-xml node body)
  (define doc (gumbo-libxml-parse
                (string->pointer body)))
  (define buffer (xml-buffer-create))
  (define size (xml-node-dump buffer doc node 0 1))
  (define content (pointer->string (car (parse-c-struct buffer xml-buffer))))
  (xml-free-doc doc)
  content)

(define (get-xpath xpath body)
  (define doc (gumbo-libxml-parse
                (string->pointer body)))
  (define context (xml-xpath-new-context doc))
  (xml-xpath-eval-expression
    (string->pointer xpath)
    context))

(define (dump-xpath-xml xpath body)
  (define buffer (xml-buffer-create))
  (define nodes (get-xpath-node xpath body))
  (define size (xml-node-dump buffer (doc nodes) nodes 0 1))
  (pointer->string (car (parse-c-struct buffer xml-buffer))))

(define (get-xpath-string xpath body attr?)
  (pointer->string
    (xml-node-list-get-string
      (doc (get-xpath-node xpath body))
      (if attr?
        (child (get-xpath-node xpath body))
        (get-xpath-node xpath body))
      1)))

(define (get-xpath-nodeset xpath body)
  (nodeset (get-xpath xpath body)))

(define (get-xpath-node xpath body)
  (nodeset-nodes (get-xpath-nodeset xpath body)))