120 lines
3.3 KiB
Racket
120 lines
3.3 KiB
Racket
#lang racket/base
|
|
|
|
;; Small namespace-insensitive helpers for Racket x-expressions.
|
|
;; UPnP documents use default namespaces and SOAP commonly uses prefixes, so
|
|
;; matching by local element or attribute name keeps parsers independent of
|
|
;; namespace prefixes.
|
|
|
|
(require racket/list
|
|
racket/string)
|
|
|
|
(provide xexpr-element?
|
|
xexpr-local-name
|
|
xexpr-attributes
|
|
xexpr-attribute
|
|
xexpr-children
|
|
xexpr-child-elements
|
|
xexpr-child-element
|
|
xexpr-text
|
|
xexpr-child-text
|
|
xexpr-find-descendant)
|
|
|
|
(define (xexpr-element? value)
|
|
(and (pair? value)
|
|
(symbol? (car value))))
|
|
|
|
(define (xexpr-attribute-list? value)
|
|
(and (list? value)
|
|
(andmap
|
|
(lambda (attribute)
|
|
(and (list? attribute)
|
|
(= (length attribute) 2)
|
|
(symbol? (car attribute))
|
|
(string? (cadr attribute))))
|
|
value)))
|
|
|
|
(define (xexpr-local-name value)
|
|
(let* ([name (if (symbol? value) (symbol->string value) value)]
|
|
[parts (and (string? name) (string-split name ":"))])
|
|
(and parts
|
|
(string-downcase (last parts)))))
|
|
|
|
(define (xexpr-attributes value)
|
|
(if (not (xexpr-element? value))
|
|
'()
|
|
(let ([rest (cdr value)])
|
|
(if (and (pair? rest)
|
|
(xexpr-attribute-list? (car rest)))
|
|
(car rest)
|
|
'()))))
|
|
|
|
(define (xexpr-attribute value name [default #f])
|
|
(let* ([wanted (xexpr-local-name name)]
|
|
[attribute
|
|
(findf
|
|
(lambda (candidate)
|
|
(string=? (xexpr-local-name (car candidate)) wanted))
|
|
(xexpr-attributes value))])
|
|
(if attribute
|
|
(cadr attribute)
|
|
default)))
|
|
|
|
(define (xexpr-children value)
|
|
(if (not (xexpr-element? value))
|
|
'()
|
|
(let ([rest (cdr value)])
|
|
(cond
|
|
[(null? rest) '()]
|
|
[(xexpr-attribute-list? (car rest)) (cdr rest)]
|
|
[else rest]))))
|
|
|
|
(define (xexpr-named-element? value name)
|
|
(and (xexpr-element? value)
|
|
(string=? (xexpr-local-name (car value))
|
|
(string-downcase name))))
|
|
|
|
(define (xexpr-child-elements value name)
|
|
(for/list ([child (in-list (xexpr-children value))]
|
|
#:when (xexpr-named-element? child name))
|
|
child))
|
|
|
|
(define (xexpr-child-element value name [default #f])
|
|
(let ([elements (xexpr-child-elements value name)])
|
|
(if (pair? elements)
|
|
(car elements)
|
|
default)))
|
|
|
|
(define (xexpr-content-text value)
|
|
(cond
|
|
[(string? value) value]
|
|
[(xexpr-element? value)
|
|
(apply string-append
|
|
(map xexpr-content-text (xexpr-children value)))]
|
|
[else ""]))
|
|
|
|
(define (xexpr-text value [default #f])
|
|
(let ([text (string-trim (xexpr-content-text value))])
|
|
(if (string=? text "")
|
|
default
|
|
text)))
|
|
|
|
(define (xexpr-child-text value name [default #f])
|
|
(let ([child (xexpr-child-element value name #f)])
|
|
(if child
|
|
(xexpr-text child default)
|
|
default)))
|
|
|
|
(define (xexpr-find-descendant value name [default #f])
|
|
(cond
|
|
[(xexpr-named-element? value name) value]
|
|
[(xexpr-element? value)
|
|
(let loop ([children (xexpr-children value)])
|
|
(cond
|
|
[(null? children) default]
|
|
[else
|
|
(let ([result (xexpr-find-descendant (car children) name #f)])
|
|
(if result
|
|
result
|
|
(loop (cdr children))))]))]
|
|
[else default]))
|