aboutsummaryrefslogtreecommitdiff
path: root/examples/xml-struct.scm
diff options
context:
space:
mode:
Diffstat (limited to 'examples/xml-struct.scm')
-rw-r--r--examples/xml-struct.scm63
1 files changed, 63 insertions, 0 deletions
diff --git a/examples/xml-struct.scm b/examples/xml-struct.scm
new file mode 100644
index 0000000..dd2b662
--- /dev/null
+++ b/examples/xml-struct.scm
@@ -0,0 +1,63 @@
+;;;; This file is part of Gamma.
+;;;; Copyright (C) 2010 Sergey Poznyakoff
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify it
+;;;; under the terms of the GNU General Public License as published by the
+;;;; Free Software Foundation; either version 3 of the License, or (at your
+;;;; option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License along
+;;;; with this program. If not, see <http://www.gnu.org/licenses/>.
+;;;;
+(use-modules (gamma expat))
+
+(let ((level 0))
+ (letrec ((elt-start (lambda (name attrs)
+ (display (make-string (* 2 level) #\space))
+ (display name)
+ (for-each
+ (lambda (x)
+ (display " ")
+ (display (car x))
+ (display "=")
+ (display (cdr x)))
+ attrs)
+ (newline)
+ (set! level (1+ level))))
+ (elt-end (lambda (name)
+ (set! level (1- level)))))
+ (catch 'gamma-xml-error
+ (lambda ()
+ (xml-parse (xml-make-parser
+ #:start-element-handler elt-start
+ #:end-element-handler elt-end)))
+ (lambda (key func fmt args ctx)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (cond
+ ((not ctx)
+ (apply format #t fmt args)
+ (newline))
+ (else
+ (format #t
+ "~A:~A: ~A~%"
+ (xml-error-descr ctx #:line)
+ (xml-error-descr ctx #:column)
+ (xml-error-string (xml-error-descr ctx #:error-code)))
+ (if (xml-error-descr ctx #:has-context?)
+ (let ((ctx-text (xml-error-descr ctx #:context))
+ (ctx-pos (xml-error-descr ctx #:error-offset)))
+ (format #t
+ "Context (^ marks the point): ~A^~A~%"
+ (substring ctx-text 0 ctx-pos)
+ (substring ctx-text ctx-pos))))
+ (exit 1)))))))))
+
+
+

Return to:

Send suggestions and report system problems to the System administrator.