;;;
;;; sxml.tools - utility to manipulate SXML
;;;
;;;   This file is mechanically translated for Gauche from
;;;   Kirill Lisovsky's sxml-tools.scm CVS revision 3.13
;;;   Public domain.
;;;
;;; $Id: tools.scm.in,v 1.2 2003/11/05 12:38:33 shirok Exp $
;;;

(define-module sxml.tools
  (use srfi-1)
  (use srfi-11)
  (use srfi-13)
  (use text.parse)
  (use sxml.adaptor)
  (use sxml.sxpath)
  (export sxml:attr-list-node
          sxml:attr-as-list
          sxml:aux-list-node
          sxml:aux-as-list
          sxml:find-name-separator
          sxml:error
          sxml:empty-element?
          sxml:shallow-normalized?
          sxml:normalized?
          sxml:shallow-minimized?
          sxml:minimized?
          sxml:name
          sxml:element-name
          sxml:node-name
          sxml:ncname
          sxml:name->ns-id
          sxml:content
          sxml:content-raw
          sxml:attr-list-u
          sxml:aux-list
          sxml:aux-list-u
          sxml:aux-node
          sxml:aux-nodes
          sxml:attr
          sxml:num-attr
          sxml:attr-u
          sxml:ns-list
          sxml:ns-id->nodes
          sxml:ns-id->uri
          sxml:ns-uri->nodes
          sxml:ns-uri->id
          sxml:ns-id
          sxml:ns-uri
          sxml:ns-prefix
          sxml:change-content!
          sxml:change-content
          sxml:change-attrlist
          sxml:change-attrlist!
          sxml:change-name!
          sxml:change-name
          sxml:add-attr
          sxml:add-attr!
          sxml:change-attr
          sxml:change-attr!
          sxml:set-attr
          sxml:set-attr!
          sxml:add-aux
          sxml:add-aux!
          sxml:squeeze!
          sxml:squeeze
          sxml:clean
          select-first-kid
          sxml:node-parent
          sxml:add-parents
          sxml:lookup
          sxml:clean-feed
          sxml:attr->xml
          sxml:sxml->xml
          sxml:attr->html
          sxml:string->html
          sxml:string->xml
          sxml:non-terminated-html-tag?
          sxml:sxml->html
          ))
(select-module sxml.tools)

;; Override these by Gauche-specific versions.

;; We can use srfi-13 fn
(define-macro (sxml:find-name-separator len)
  `(string-index-right name #\:))

;; Error function.
(define (sxml:error . messages)
  (apply error "SXML Error: " messages))

;; nl is used in the arg of sxml:error to insert a newline, but 
;; we don't really need it.
(define nl "")

;;; Generated from Oleg Kiselyov's "sxml-tools.scm"
(define (filter-and-map pred proc lis) (let rpt ((l lis)) (if (null? l) '() (if (pred (car l)) (cons (proc (car l)) (rpt (cdr l))) (rpt (cdr l))))))
(define (check-list pred lst) (cond ((null? lst) #t) ((pred (car lst)) (check-list pred (cdr lst))) (else #f)))
(define (sxml:attr-list-node obj) (if (and (not (null? (cdr obj))) (pair? (cadr obj)) (eq? '|@| (caadr obj))) (cadr obj) #f))
(define (sxml:attr-as-list obj) (cond ((sxml:attr-list-node obj) => list) ((sxml:aux-list-node obj) '((|@|))) (else '())))
(define (sxml:aux-list-node obj) (if (or (null? (cdr obj)) (null? (cddr obj)) (not (pair? (caddr obj))) (not (eq? (caaddr obj) '|@@|))) #f (caddr obj)))
(define (sxml:aux-as-list obj) (cond ((sxml:aux-list-node obj) => list) (else '())))


(define (sxml:empty-element? obj) (not ((select-first-kid (lambda (x) (or ((ntype-names?? '(*PI* *COMMENT* *ENTITY*)) x) ((ntype?? '*) x) (string? x)))) obj)))
(define (sxml:shallow-normalized? obj) (or (null? (cdr obj)) (and (or (and (pair? (cadr obj)) (eq? (caadr obj) '|@|)) (not ((select-first-kid (ntype-names?? '(|@| |@@|))) obj))) (or (null? (cddr obj)) (and (pair? (caddr obj)) (eq? (caaddr obj) '|@@|)) (not ((select-first-kid (ntype?? '|@@|)) obj))))))
(define (sxml:normalized? obj) (and (sxml:shallow-normalized? obj) (check-list (lambda (x) (if (sxml:element? x) (sxml:normalized? x) #t)) (sxml:content obj))))
(define (sxml:shallow-minimized? obj) (and (sxml:shallow-normalized? obj) (not (and (sxml:aux-list-node obj) (null? (sxml:aux-list obj)))) (not (and (sxml:attr-list-node obj) (null? (sxml:attr-list obj)) (not (sxml:aux-list-node obj))))))
(define (sxml:minimized? obj) (and (sxml:shallow-minimized? obj) (check-list (lambda (x) (if (sxml:element? x) (sxml:minimized? x) #t)) (sxml:content obj))))
(define sxml:name car)
(define (sxml:element-name obj) (and ((ntype?? '*) obj) (car obj)))
(define (sxml:node-name obj) (and (pair? obj) (symbol? (car obj)) (car obj)))
(define (sxml:ncname obj) (let* ((name (symbol->string (car obj))) (len (string-length name))) (cond ((sxml:find-name-separator len) => (lambda (pos) (substring name (+ pos 1) len))) (else name))))
(define (sxml:name->ns-id sxml-name) (let* ((name (symbol->string sxml-name))) (cond ((sxml:find-name-separator (string-length name)) => (lambda (pos) (substring name 0 pos))) (else #f))))
(define (sxml:content obj) (((if (nodeset? obj) sxml:filter select-kids) (lambda (x) (or (string? x) ((ntype?? '*) x)))) obj))
(define (sxml:content-raw obj) ((if (and (not (null? (cdr obj))) (pair? (cadr obj)) (eq? (caadr obj) '|@|)) (if (and (not (null? (cddr obj))) (pair? (caddr obj)) (eq? (caaddr obj) '|@@|)) cdddr cddr) cdr) obj))
(define (sxml:attr-list-u obj) (cond (((select-first-kid (ntype?? '|@|)) obj) => cdr) (else '())))
(define (sxml:aux-list obj) (if (or (null? (cdr obj)) (null? (cddr obj)) (not (pair? (caddr obj))) (not (eq? (caaddr obj) '|@@|))) '() (cdaddr obj)))
(define (sxml:aux-list-u obj) (cond (((select-first-kid (ntype?? '|@@|)) obj) => cdr) (else '())))
(define (sxml:aux-node obj aux-name) (cond ((assq aux-name (sxml:aux-list obj))) (else #f)))
(define (sxml:aux-nodes obj aux-name) (filter (lambda (x) (eq? aux-name (car x))) (sxml:aux-list obj)))
(define (sxml:attr obj attr-name) (cond ((assq attr-name (sxml:attr-list obj)) => cadr) (else #f)))
(define (sxml:num-attr obj attr-name) (cond ((assq attr-name (sxml:attr-list obj)) => (lambda (x) (string->number (cadr x)))) (else #f)))
(define (sxml:attr-u obj attr-name) (cond ((assq attr-name (cond ((and (not (null? (cdr obj))) (pair? (cadr obj)) (eq? '|@| (caadr obj))) (cdadr obj)) ((eq? '|@| (car obj)) (cdr obj)) (else (sxml:attr-list-u obj)))) => cadr) (else #f)))
(define (sxml:ns-list obj) (cond ((assv '*NAMESPACES* (sxml:aux-list obj)) => cdr) (else '())))
(define (sxml:ns-id->nodes obj namespace-id) (filter (lambda (x) (eq? (car x) namespace-id)) (sxml:ns-list obj)))
(define (sxml:ns-id->uri obj namespace-id) (cond ((assq namespace-id (sxml:ns-list obj)) => cadr) (else #f)))
(define (sxml:ns-uri->nodes obj URI) (filter (lambda (ns-assoc) (string=? (cadr ns-assoc) URI)) (sxml:ns-list obj)))
(define (sxml:ns-uri->id obj URI) (let rpt ((ns-assocs (sxml:ns-list obj))) (cond ((null? ns-assocs) #f) ((string=? (cadar ns-assocs) URI) (caar ns-assocs)) (else (rpt (cdr ns-assocs))))))
(define sxml:ns-id car)
(define sxml:ns-uri cadr)
(define (sxml:ns-prefix ns-assoc) (if (> (length ns-assoc) 2) (caddr ns-assoc) (car ns-assoc)))
(define (sxml:change-content! obj new-content) (set-cdr! obj `(,@(sxml:attr-as-list obj) ,@(sxml:aux-as-list obj) ,@new-content)))
(define (sxml:change-content obj new-content) `(,(sxml:name obj) ,@(sxml:attr-as-list obj) ,@(sxml:aux-as-list obj) ,@new-content))
(define (sxml:change-attrlist obj new-attrlist) `(,(sxml:name obj) ,@(cond (new-attrlist `((|@| ,@new-attrlist))) ((sxml:aux-list-node obj) '((|@|))) (else `())) ,@(sxml:aux-as-list obj) ,@(sxml:content obj)))
(define (sxml:change-attrlist! obj new-attrlist) (set-cdr! obj `(,@(cond (new-attrlist `((|@| ,@new-attrlist))) ((sxml:aux-list-node obj) '((|@|))) (else `())) ,@(sxml:aux-as-list obj) ,@(sxml:content obj))))
(define (sxml:change-name! obj new-name) (set-car! obj new-name))
(define (sxml:change-name obj new-name) (cons new-name (cdr obj)))
(define (sxml:add-attr obj attr) (let ((attr-list (sxml:attr-list obj))) (if (assq (car attr) attr-list) #f `(,(sxml:name obj) (|@| ,@(cons attr attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj)))))
(define (sxml:add-attr! obj attr) (let ((attr-list (sxml:attr-list obj))) (if (assq (car attr) attr-list) #f (begin (set-cdr! obj `((|@| ,@(cons attr attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj))) obj))))
(define (sxml:change-attr obj attr) (let ((attr-list (sxml:attr-list obj))) (if (null? attr-list) #f (cond ((assv (car attr) attr-list) => (lambda (y) `(,(sxml:name obj) (|@| ,@(map (lambda (at) (if (eq? at y) attr at)) attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj)))) (else #f)))))
(define (sxml:change-attr! obj attr) (let ((x (sxml:attr-list obj))) (if (null? x) #f (cond ((assv (car attr) x) => (lambda (y) (set-cdr! y (cdr attr)) obj)) (else #f)))))
(define (sxml:set-attr obj attr) (let ((attr-list (sxml:attr-list obj))) (cond ((assv (car attr) attr-list) => (lambda (y) `(,(sxml:name obj) (|@| ,@(map (lambda (at) (if (eq? at y) attr at)) attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj)))) (else `(,(sxml:name obj) (|@| ,@(cons attr attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj))))))
(define (sxml:set-attr! obj attr) (let ((attr-list (sxml:attr-list obj))) (cond ((assv (car attr) attr-list) => (lambda (x) (set-cdr! x (cdr attr)))) (else (set-cdr! obj `((|@| ,@(cons attr attr-list)) ,@(sxml:aux-as-list obj) ,@(sxml:content obj)))))))
(define (sxml:add-aux obj aux-node) `(,(sxml:name obj) (|@| ,@(sxml:attr-list obj)) (|@@| ,@(cons aux-node (sxml:aux-list obj))) ,@(sxml:content obj)))
(define (sxml:add-aux! obj aux-node) (set-cdr! obj `((|@| ,@(sxml:attr-list obj)) (|@@| ,@(cons aux-node (sxml:aux-list obj))) ,@(sxml:content obj))) obj)
(define (sxml:squeeze! obj) (set-cdr! obj `(,@(cond ((sxml:attr-list-node obj) => (lambda (atl) (if (and (null? (cdr atl)) (null? (sxml:aux-list obj))) '() (list atl)))) (else '())) ,@(cond ((sxml:aux-list-node obj) => (lambda (axl) (if (null? (cdr axl)) '() (list axl)))) (else '())) ,@(map (lambda (x) (cond (((ntype?? '*) x) (sxml:squeeze! x) x) (else x))) (sxml:content obj)))))
(define (sxml:squeeze obj) `(,(sxml:name obj) ,@(cond ((sxml:attr-list-node obj) => (lambda (atl) (if (and (null? (cdr atl)) (null? (sxml:aux-list obj))) '() (list atl)))) (else '())) ,@(cond ((sxml:aux-list-node obj) => (lambda (axl) (if (null? (cdr axl)) '() (list axl)))) (else '())) ,@(map (lambda (x) (cond (((ntype?? '*) x) (sxml:squeeze x)) (else x))) (sxml:content obj))))
(define (sxml:clean obj) `(,(sxml:name obj) ,@(cond ((sxml:attr-list-node obj) => (lambda (atl) (if (null? (cdr atl)) '() (list atl)))) (else '())) ,@(map (lambda (x) (cond (((ntype?? '*) x) (sxml:clean x)) (else x))) (sxml:content obj))))
(define (select-first-kid test-pred?) (lambda (obj) (let rpt ((lst (if (symbol? (car obj)) (cdr obj) obj))) (cond ((null? lst) #f) ((and (pair? (car lst)) (test-pred? (car lst))) (car lst)) (else (rpt (cdr lst)))))))
(define (sxml:node-parent rootnode) (lambda (obj) (cond ((sxml:aux-node obj '*PARENT*) => (lambda (x) (if (eq? '*TOP-PTR* (cadr x)) rootnode ((cadr x))))) ((and (pair? obj) (eq? (car obj) '*TOP*)) '()) (else (sxml:error nl "PARENT pointer is absent in: " obj nl)))))
(define (sxml:add-parents obj . top-ptr) (let rpt ((elt obj) (p '*TOP*) (at-aux (if (eq? (sxml:name obj) '*TOP*) (list (cons '|@@| (sxml:aux-list-u obj))) (list (cons '|@| (sxml:attr-list obj)) (cons '|@@| (cons `(*PARENT* ,(lambda () (car top-ptr))) (sxml:aux-list obj))))))) (let* ((h (list (sxml:name elt))) (b (append at-aux (map (lambda (x) (cond (((ntype?? '*) x) (rpt x h (list (cons '|@| (sxml:attr-list x)) (cons '|@@| (cons `(*PARENT* ,(lambda () h)) (sxml:aux-list x)))))) (else x))) (sxml:content elt))))) (set-cdr! h b) h)))
(define (sxml:lookup id index) (cond ((assoc id index) => cdr) (else #f)))
(define (sxml:clean-feed . fragments) (reverse (let loop ((fragments fragments) (result '())) (cond ((null? fragments) result) ((not (car fragments)) (loop (cdr fragments) result)) ((null? (car fragments)) (loop (cdr fragments) result)) ((pair? (car fragments)) (loop (cdr fragments) (loop (car fragments) result))) (else (loop (cdr fragments) (cons (car fragments) result)))))))
(define (sxml:attr->xml attr) (list " " (sxml:ncname attr) "='" (cadr attr) "'"))
(define sxml:string->xml (make-char-quotator '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;") (#\' . "&apos;"))))
(define (sxml:sxml->xml tree) (cond ((nodeset? tree) (map (lambda (a-tree) (sxml:sxml->xml a-tree)) tree)) ((pair? tree) (let* ((name (sxml:name tree)) (nm (symbol->string name)) (content (sxml:content-raw tree))) `("<" ,nm ,@(map sxml:attr->xml (sxml:attr-list tree)) ,@(if (null? content) '("/>") `(">" ,@(sxml:sxml->xml content) "</" ,nm ">"))))) ((string? tree) (sxml:string->xml tree)) (else (sxml:error "sxml->html - unexpected type of node: " tree))))
(define (sxml:attr->html attr) (if (equal? "" (cadr attr)) (list " " (sxml:ncname attr)) (list " " (sxml:ncname attr) "='" (cadr attr) "'")))
(define sxml:string->html (make-char-quotator '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
(define (sxml:non-terminated-html-tag? tag) (memq tag '(area base basefont br col frame hr img input isindex link meta param)))
(define (sxml:sxml->html tree) (cond ((nodeset? tree) (map (lambda (a-tree) (sxml:sxml->html a-tree)) tree)) ((pair? tree) (let* ((name (sxml:name tree)) (nm (symbol->string name)) (content (sxml:content-raw tree))) `("<" ,nm ,@(map sxml:attr->html (sxml:attr-list tree)) ,@(if (null? content) (if (sxml:non-terminated-html-tag? name) '(">") '("/>")) `(">" ,@(sxml:sxml->html content) "</" ,nm ">"))))) ((string? tree) (sxml:string->html tree)) (else (sxml:error "sxml->html - unexpected type of node: " tree))))

(provide "sxml/tools")

          
;; Local variables:
;; mode: scheme
;; end:
