aboutsummaryrefslogtreecommitdiff
path: root/skr/xml.skr
diff options
context:
space:
mode:
authorLudovic Court`es2005-06-15 13:00:39 +0000
committerLudovic Court`es2005-06-15 13:00:39 +0000
commitfc42fe56a57eace2dbdb31574c2e161f0eacf839 (patch)
tree18111570156cb0e3df0d81c8d104517a2263fd2c /skr/xml.skr
downloadskribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.gz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.lz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.zip
Initial import of Skribe 1.2d.
Initial import of Skribe 1.2d. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
Diffstat (limited to 'skr/xml.skr')
-rw-r--r--skr/xml.skr111
1 files changed, 111 insertions, 0 deletions
diff --git a/skr/xml.skr b/skr/xml.skr
new file mode 100644
index 0000000..784b6f0
--- /dev/null
+++ b/skr/xml.skr
@@ -0,0 +1,111 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/xml.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Tue Sep 2 09:46:09 2003 */
+;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Generic XML Skribe engine */
+;* ------------------------------------------------------------- */
+;* Implementation: */
+;* common: @path ../src/common/api.src@ */
+;* bigloo: @path ../src/bigloo/api.bgl@ */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/xmle.skb:ref@ */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* xml-engine ... */
+;*---------------------------------------------------------------------*/
+(define xml-engine
+ ;; setup the xml engine
+ (default-engine-set!
+ (make-engine 'xml
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")
+ (#\@ "&#x40;"))))))
+
+;*---------------------------------------------------------------------*/
+;* markup ... */
+;*---------------------------------------------------------------------*/
+(let ((xml-margin 0))
+ (define (make-margin)
+ (make-string xml-margin #\space))
+ (define (xml-attribute? val)
+ (cond
+ ((or (string? val) (number? val) (boolean? val))
+ #t)
+ ((list? val)
+ (every? xml-attribute? val))
+ (else
+ #f)))
+ (define (xml-attribute att val)
+ (let ((s (keyword->string att)))
+ (printf " ~a=\"" (substring s 1 (string-length s)))
+ (let loop ((val val))
+ (cond
+ ((or (string? val) (number? val))
+ (display val))
+ ((boolean? val)
+ (display (if val "true" "false")))
+ ((pair? val)
+ (for-each loop val))
+ (else
+ #f)))
+ (display #\")))
+ (define (xml-option opt val e)
+ (let* ((m (make-margin))
+ (ks (keyword->string opt))
+ (s (substring ks 1 (string-length ks))))
+ (printf "~a<~a>\n" m s)
+ (output val e)
+ (printf "~a</~a>\n" m s)))
+ (define (xml-options n e)
+ ;; display the true options
+ (let ((opts (filter (lambda (o)
+ (and (keyword? (car o))
+ (not (xml-attribute? (cadr o)))))
+ (markup-options n))))
+ (if (pair? opts)
+ (let ((m (make-margin)))
+ (display m)
+ (display "<options>\n")
+ (set! xml-margin (+ xml-margin 1))
+ (for-each (lambda (o)
+ (xml-option (car o) (cadr o) e))
+ opts)
+ (set! xml-margin (- xml-margin 1))
+ (display m)
+ (display "</options>\n")))))
+ (markup-writer #t
+ :options 'all
+ :before (lambda (n e)
+ (printf "~a<~a" (make-margin) (markup-markup n))
+ ;; display the xml attributes
+ (for-each (lambda (o)
+ (if (and (keyword? (car o))
+ (xml-attribute? (cadr o)))
+ (xml-attribute (car o) (cadr o))))
+ (markup-options n))
+ (set! xml-margin (+ xml-margin 1))
+ (display ">\n"))
+ :action (lambda (n e)
+ ;; options
+ (xml-options n e)
+ ;; body
+ (output (markup-body n) e))
+ :after (lambda (n e)
+ (printf "~a</~a>\n" (make-margin) (markup-markup n))
+ (set! xml-margin (- xml-margin 1)))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))