Re: XML encoding from a DSSSL stylesheets?

[Brandon Ibach <bibach@xxxxxxxxxxxxxx>]

Quoting Stephane Bortzmeyer <bortzmeyer@xxxxxxxxxx>:
> but, you're right, I get the complete Processing Instruction and I
> don't know enough about DSSSL to extract the relevant part. 
> 
> So, I'll add one variable for he encoding and use the -V option of
> Jade to allow the user to set it. It duplicates what's already in the
> source file but it works.
> 
   Try this on your XML file. :)

-Brandon :)

<!doctype style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN">
<style-specification id=encoding>

(define debug
  (external-procedure "UNREGISTERED::James Clark//Procedure::debug"))

(declare-flow-object-class element
  "UNREGISTERED::James Clark//Flow Object Class::element")
(declare-flow-object-class formatting-instruction
  "UNREGISTERED::James Clark//Flow Object Class::formatting-instruction")

(declare-characteristic preserve-sdata?
  "UNREGISTERED::James Clark//Characteristic::preserve-sdata?" #f)

(define ws '(#\space #\U-0009 #\line-feed #\carriage-return))

; Parses a PI node's system-data, returning a list containing the PI
; target string, the rest of the data minus any leading whitespace,
; and a series of name-value pairs parsed "XML attribute"-style.
; Does *not* check for legal names (using only valid XML name chars).
; Returns #f if the input node list is empty or not a PI.
(define (parse-pi n)
  (and (not (node-list-empty? n)) (equal? 'pi (node-property 'classnm n))
    (let* ((s (node-property 'system-data n)) (l (string-length s))
           (ss (lambda (a b) (substring s a b)))
           (ao (lambda (r a) (append r (list a)))))
      (let loop ((r '()) (m 0) (p 0) (n 0) (v 0))
        (if (>= p l) r (let ((c (string-ref s p))) (case m
; modes: 0=find target 1=skip ws after target 2=find equals 3=check delim
;        4=find ending delim 5=find ending ws 6=skip ws after pair
          ((0) (if (member c ws) (if (= p 0) (list #f s)
                                     (loop (list (ss 0 p)) 1 (+ p 1) 0 0))
                   (loop r 0 (+ p 1) 0 0)))
          ((1) (if (member c ws) (loop r 1 (+ p 1) 0 0)
                   (loop (ao r (ss p l)) 2 (+ p 1) p 0)))
          ((2) (if (member c ws)
                   (loop (ao r (cons (ss n p) "")) 6 (+ p 1) 0 0)
                   (if (equal? c #\=) (loop r 3 (+ p 1) n (+ p 1))
                       (loop r 2 (+ p 1) n 0))))
          ((3) (if (member c ws)
                   (loop (ao r (cons (ss n (- p 1)) "")) 6 (+ p 1) 0 0)
                   (loop r (if (member c '(#\" #\')) 4 5) (+ p 1) n p)))
          ((4) (if (not (equal? c (string-ref s v))) (loop r 4 (+ p 1) n v)
                   (loop (ao r (cons (ss n (- v 1)) (ss (+ v 1) p)))
                         6 (+ p 1) 0 0)))
          ((5) (if (not (member c ws)) (loop r 5 (+ p 1) n v)
                   (loop (ao r (cons (ss n (- v 1)) (ss v p))) 6 (+ p 1) 0 0)))
          ((6) (loop r (if (member c ws) 6 2) (+ p 1) p 0)))))))))

(define (cddr x) (cdr (cdr x)))

(define (current-root) (node-property 'grove-root (current-node)))

; (string-interp string char strings...) replaces instances of char
; in string with successive strings.  Two successive instances of
; char will instead be replaced by a single instance of char.
; Extra instances of char will be left alone.
(define (string-interp s c #!rest sl)
  (let ((e (string-length s)) (ss (lambda (a b) (substring s a b)))
        (sa string-append) (sr string-ref))
    (let loop ((r "") (b 0) (p 0) (l sl))
      (if (or (>= p e) (null? l)) (sa r (ss b e))
          (if (not (equal? (sr s p) c)) (loop r b (+ p 1) l)
              (if (equal? (sr s (+ p 1)) c)
                  (loop (sa r (ss b (+ p 1))) (+ p 2) (+ p 2) l)
                  (loop (sa r (ss b p) (car l)) (+ p 1) (+ p 1) (cdr l))))))))
             

(root (make formatting-instruction data:
        (let ((p (debug (parse-pi (node-list-first (select-by-class
                     (node-property 'prolog (current-root)) 'pi))))))
          (if (not p) "No XML declaration\U-000D;\U-000A;"
            (string-interp "Document encoding: %\U-000D;\U-000A;" #\%
              (cdr (or (assoc "encoding" (cddr p)) '(#f "[none]"))))))))

</style-specification>