From 83ee9de18a0ecaa237eb73e1b75d0b21e3e8d321 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 4 Feb 2019 21:39:06 +0100 Subject: [PATCH] sxml: xml->sxml: Record and use namespace abbreviations. * module/sxml/simple.scm (xml->sxml): Add namespace declarations to the attribute list of the first XML element. [name->sxml]: Accept namespaces argument to look up abbreviation. Return name with abbreviation prefix. [parser]: Let FINISH-ELEMENT procedure return namespaces in addition to SXML tree. --- module/sxml/simple.scm | 50 +++++++++++++++++++++++++++++++++--------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/module/sxml/simple.scm b/module/sxml/simple.scm index 703ad9137..52dd9af12 100644 --- a/module/sxml/simple.scm +++ b/module/sxml/simple.scm @@ -1,7 +1,8 @@ ;;;; (sxml simple) -- a simple interface to the SSAX parser ;;;; -;;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2013, 2019 Free Software Foundation, Inc. ;;;; Modified 2004 by Andy Wingo . +;;;; Modified 2019 by Ricardo Wurmus . ;;;; Originally written by Oleg Kiselyov as SXML-to-HTML.scm. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -30,6 +31,7 @@ #:use-module (sxml ssax) #:use-module (sxml transform) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (xml->sxml sxml->xml sxml->string)) @@ -123,10 +125,15 @@ port." (acons '*DEFAULT* default-entity-handler entities) entities)) - (define (name->sxml name) + (define (name->sxml name namespaces) (match name ((prefix . local-part) - (symbol-append prefix (string->symbol ":") local-part)) + (let ((abbrev (and=> (find (match-lambda + ((abbrev uri . rest) + (and (eq? uri prefix) abbrev))) + namespaces) + first))) + (symbol-append abbrev (string->symbol ":") local-part))) (_ name))) (define (doctype-continuation seed) @@ -152,14 +159,16 @@ port." (ssax:reverse-collect-str seed))) (attrs (attlist-fold (lambda (attr accum) - (cons (list (name->sxml (car attr)) (cdr attr)) + (cons (list (name->sxml (car attr) namespaces) + (cdr attr)) accum)) '() attributes))) - (acons (name->sxml elem-gi) - (if (null? attrs) - seed - (cons (cons '@ attrs) seed)) - parent-seed))) + (values (acons (name->sxml elem-gi namespaces) + (if (null? attrs) + seed + (cons (cons '@ attrs) seed)) + parent-seed) + namespaces))) CHAR-DATA-HANDLER ; fhere (lambda (string1 string2 seed) @@ -212,7 +221,28 @@ port." (let* ((port (if (string? string-or-port) (open-input-string string-or-port) string-or-port)) - (elements (reverse (parser port '())))) + (elements (call-with-values + (lambda () (parser port '())) + (lambda (elements namespaces) + ;; Generate namespace declarations mapping + ;; abbreviations to URLs. + (let ((ns-declarations + (filter-map (match-lambda + (('*DEFAULT* . _) #f) + ((abbrev uri . _) + (list (symbol-append 'xmlns: abbrev) + (symbol->string uri)))) + namespaces))) + ;; Inject namespace declarations into the first + ;; proper element. + (match (reverse elements) + (((and pi-elem ('*PI* . _)) + (tag ('@ . attrs) . children)) + `(,pi-elem (,tag (@ ,@ns-declarations ,attrs) + ,@children))) + (((tag ('@ . attrs) . children)) + `(,tag (@ ,@ns-declarations ,attrs) + ,@children)))))))) `(*TOP* ,@elements))) (define check-name -- 2.20.1