#!MUNGERPATH

; Copyright (c) 2006, 2009 James Bailie <jimmy@mammothcheese.ca>.
; All rights reserved.
;
; Redistribution and use in source form, with or without modification, are
; permitted provided that the following conditions are met:
;
;     * Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;     * The name of James Bailie may not be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

; -------------------------------------------------------------------------

; This script is a minimal, non-validating parser for standalone XML 1.0
; documents.  The program only knows about ISO-8859-1, but it will attempt
; to process a document encoded using UTF-8.  This will only succeed if the
; characters used in tag and attribute names are limited to those of
; ISO-8859-1, which is a subset of UTF-8.  The character data in the
; document is not subject to this limitation.

; It cannot cope with documents which are not well-formed, nor can it
; convert entity references beyond those defined by the XML 1.0 standard as
; predefined (&quot; &amp; &gt; &lt; &apos;).  It will convert both decimal
; and hexadecimal character references, however.  The parser only
; recognizes element tags and CDATA tags.  It ignores processing
; instructions.

; XML structure and content is serialized and stored in a SQLite database.
; The rss.munger example program demonstrates how to query the database
; using the xmlqlite.munger module.

; -------------------------------------------------------------------------

; DATABASE SCHEMA

; The script reads from stdin unless a filename is specified on the command
; line.  The SQLite database is written to a file named "document.db" by
; default, but this may be changed to a user-supplied value with use of the
; -f option.  This is the only option the program understands.

; The "document" table is always created and contains records representing
; the XML elements and character data segments of the document.
; Additionally, if any XML elements have attributes explicitly set, then a
; separate table for each such element will be defined, containing the
; attribute key/value pairs.

; Attribute tables contain records with two columns, "key" and "value", and
; the tables have names of the form attrs[n], where [n] is a unique natural
; number identifier.

; Records in the "document" table have four columns, "index", "path",
; "data", and "parent".  The "index" column contains a unique natural
; number identifier for each record.  The "path" column describes the
; record's hierarchical relationship to the rest of the document.  The
; "data" element contains one of:  the empty string, the name of an
; attribute table if the record describes an XML element with
; explicitly-set attributes, or document text if the record describes a
; segment of character data.  The "parent" field contains the index number
; of the record's parent element in the XML document, or 0, if the element
; is a toplevel element.

; The content of the "path" field resembles a path string representing a
; filesystem entity, except that paths in an XML document ARE NOT UNIQUE.

; Consider the following simple XML document:

; <outer>blather<inner>booger</inner>blather</outer>

; After parsing by this script, this "document" table will have been
; created:

; index           path           data        parent
; -----           ----           ----        ------
; 1               /outer         ''          0
; 2               /outer/        blather     1
; 3               /outer/inner   ''          1
; 4               /outer/inner/  booger      3
; 5               /outer/        blather     1

; Record 1 represents the "outer" element.  The "/" in its path represents
; the root of our database, which is the "document" table itself.  This
; allows the script to process XML documents which do not have root
; elements.  The "outer" token in the path is the name of the element.  The
; virgule ("/") cannot appear in XML element names, so there is no chance
; of confusion with our path delimiter.  The "data" column for the root
; element is the empty string because it does not have any attributes
; explicity set.  Record 1's parent element is set to zero to indicate it
; is a toplevel element.

; Record 2's path field is identical to record 1's except for the addition
; of a trailing virgule.  A record with a path with a trailing virgule
; always contains character data.  The path preceding the trailing virgule
; indicates which XML element contains the character data.  Record 2,
; therefore, represents the first segment of character data in the "outer"
; element.  The "data" field contains, as we would expect, the text
; "blather".

; Record 3 represents the "inner" element.  Record 4 represents the
; character data content of the "inner" element.  Record 5 represents the
; second segment of character data in the "outer" element.

; The xmlsqlite.munger module provides helper functions to query a
; database file containing an XML document serialized by this script.
; Consult the header comment in that file for details on usage.
; See the rss.munger example program for an example of usage.

; ---------------------------------------------------------------------------

; Makes lisp errors fatal to the interpreter.

(fatal)

; Maximum size of the chunks of text we will process.

(setq maxlen 512)

; Lexical analysis.

(let ((token "")
      (type 'empty)
      (term "")
      (chars ())
      (len 0)
      (term_rx (regcomp (char 13))))

   (defun parse (line)

      (if (eq 0 line)
         (when token
            (make_item type token))

         (setq chars (explode (substitute term_rx "" line 0)))

         (while chars
            (cond ((eq type 'empty)
                   (setq token (car chars))
                   (setq type (if (eq (car chars) "<") 'markup 'cdata)))

                  ((eq type 'markup)

                   (if (and (> (setq len (length token)) 8)
                            (eq "<![CDATA[" (substring token 0 9)))

                       (cond ((and (setq term (eq "]]" (substring token (- len 2) 0)))
                                   (eq (car chars) ">"))
                              (make_item type (concat token (car chars)))
                              (setq token "")
                              (setq type 'empty))

                             ; Split-up long explicit cdata sections.

                             ((> len maxlen)
                              (if (eq (car chars) "]")
                                 (setq token (concat token (car chars)))

                                 (make_item type (concat token (car chars) "]]>"))
                                 (setq token "<![CDATA[")))

                             (1 (setq token (concat token (car chars)))))

                       (if (not (eq (car chars) ">"))
                           (setq token (concat token (car chars)))

                           (make_item type (concat token (car chars)))
                           (setq type 'empty)
                           (setq token ""))))

                  ((eq type 'cdata)
                   (if (eq (car chars) "<")
                     (progn
                        (when token
                           (make_item type token))
                        (set 'token (car chars))
                        (set 'type 'markup))

                     (if (<= (length token) maxlen)
                        (setq token (concat token (car chars)))

                        ; Split-up long implicit cdata sections.

                        (make_item type (concat token (car chars)))
                        (setq token "")))))

            (setq chars (cdr chars))))))

; Functions to convert character and entity references.

(let ((nums ())
      (subst "")
      (converted (table))
      (rx "")
      (m ())
      (entities_rx (regcomp "&(lt|gt|apos|quot|amp|(x)?([0-9A-Fa-f]{2}));")))

   (defun do_conversions (line)
      (if (not (setq m (matches entities_rx line)))
         line

         (setq subst
            (cond ((eq (car (cdr m)) "lt") "<")
                  ((eq (car (cdr m)) "gt") ">")
                  ((eq (car (cdr m)) "apos") "'")
                  ((eq (car (cdr m)) "quot") "\"")
                  ((eq (car (cdr m)) "amp") "&")

                  ((eq (car (cddr m)) "x")
                   (char (hex2dec (car (cdddr m)))))

                  (1 (char (digitize (car (cdddr m)))))))

         ; Convert one match at a time to avoid performing multiple levels
         ; of conversions on portions of the line we have not seen yet, and
         ; on portions of lines we have already scanned once.

         (setq nums (match entities_rx line))

         (setq rx (lookup converted (car m)))
         (when (not rx)
            (setq rx (hash converted (car m) (regcomp (car m)))))

         (concat (substitute rx subst (substring line 0 (cadr nums)))
                  (if (eq (length line) (cadr nums))
                     ""
                     (do_conversions (substring line (cadr nums) 0)))))))

; Regular expressions to escape quotes and backslashes so that the final alist
; created by this script will be readable by the munger reader.

(let ((quote_rx (regcomp "'")))

   (defun convert_refs (line convert)

      ; Quotes may be found literally in the string or they may be created
      ; by entity replacement, so we need to escape them after entity
      ; conversion.

      (substitute quote_rx "''" (if convert (do_conversions line) line) 0)))

; Regular expression used to remove delimiting quotes from attribute values.

(setq quotes_rx (regcomp "^[\"'](.*)['\"]$"))

; String containing whitespace characters recognized by XML.

(setq whitespace (concat (char 32) (char 9) (char 10) (char 13)))

; Helper function.  Returns a list of one-element strings, consisting of
; characters having the codes in the specified range, inclusive.  Skips
; DEL (127) for that position is unused in iso8859-1, and skips the
; division and multiplication signs.

(defun make_list_chars (start end)

   (let ((n start)
         (m ()))

      (if (<= n end)
         (tailcall 0
                   (+ n 1)
                   (if (or (eq n 247) (eq n 215) (eq n 127))
                       m
                       (cons (char n) m)))
         (reverse m))))

; String containing the letter glyphs of iso8859-1 only.

(setq letter
   (concat (make_list_chars 65 90)
           (make_list_chars 97 122)
           (make_list_chars 192 255)))

; String representing regular expression to recognize a name token.  Note:
; "-" must appear first in the second character class to avoid having it
; inadvertently specify a range.

(setq name (concat "[" letter "_:][-0-9._:" letter  "]*"))

; Strings representing regular expressions to match character references and
; entity references.

(setq char_ref "&#(x)?([0-9A-Fa-f]+);(.*)")
(setq ent_ref "&[a-z]+;")

; String representing regular expression matching valid attribute value
; characters.
(setq attvalue (concat "(\"([^\"<&]|" char_ref "|" ent_ref ")*\"|"
                       "'([^'<&]|" char_ref "|" ent_ref ")*')"))

; String representing regular expression matching an attribute/value pair.

(setq attribute (concat name "[" whitespace "]*=[" whitespace "]*" attvalue))

; Regular expression to remove whitespace surrouding "=" in attribute pairs.
; This is so (break_up_attrs) will work correctly.

(let ((attr_space_rx (regcomp (concat "(" name ")[" whitespace "]+=[" whitespace "]+(" attvalue ")")))
      (attr_rx (regcomp attribute))
      (m ())
      (len 0)
      (broken ()))

; Function to breakup at attribute list into an alist.

   (defun break_up_attrs (attrs)

      (setq broken ())
      (setq len (length attrs))

      (while (setq m (match attr_rx attrs))
         (setq broken
            (cons
               (substitute attr_space_rx "\1=\2" (substring attrs (car m) (- (cadr m) (car m))))
               broken))

         (if (eq (cadr m) len)
            (setq attrs "")

            (setq attrs (substring attrs (cadr m) 0))
            (setq len (length attrs))))

      (mapcar
         (lambda (x)
            (list (car x)
                  (convert_refs (substitute quotes_rx "\1" (cadr x)) 1)))

         ; If we do not specifically limit the split operation it will also
         ; split the value if it contains one or more equal signs.

         (mapcar (lambda (x) (split "=" x 2)) (reverse broken)))))

; Function to check the XML version and document encoding.

(let ((xml_version_rx (regcomp (concat "[" whitespace "]+version[" whitespace "]*=[" whitespace "]*" attvalue)))
      (xml_encoding_rx (regcomp (concat "[" whitespace "]+encoding[" whitespace "]*=[" whitespace "]*" attvalue)))
      (encoding_rx (regcomp "[Ii][Ss][Oo](-8859-1|-646-[Uu][Ss])|[Uu][Tt][Ff]-8|[Uu][Ss]-[Aa][Ss][Cc][Ii][Ii]")))

   (defun check_version (items)

      (let ((m1 (matches xml_version_rx (car (cddr items))))
            (m2 (matches xml_encoding_rx (car (cddr items)))))

         (when m1
            (unless (eq (substitute quotes_rx "\1" (cadr m1)) "1.0")
               (warn "This processor does not understand XML " m1)
               (exit 1)))

         (when m2
            (setq m2 (substitute quotes_rx "\1" (cadr m2)))
            (unless (match encoding_rx m2)
               (warn "This processor does not understand encoding " m2)
               (exit 1))))))

; Functions to do the database insertions.

(let ((path_string "")
      (idx 0)
      (parent 0)
      (parents (stack))
      (attrs_idx 0)
      (ps_rx (regcomp "/[^/]+$"))
      (sql "")
      (result ()))

   (defun make_cdata (item)
      (setq sql (stringify "INSERT INTO document VALUES ( " (inc idx) ",'" 
         path_string "/', '" item "'," parent " )"))

      (when (stringp (setq result (sqlite_exec db sql)))
         (die result)))

   (defun make_empty (name attrs)
      (setq sql (stringify "INSERT INTO document VALUES ( " (inc idx) ",'"
         path_string "/" name "', "
         (if attrs (stringify "'attrs" (inc attrs_idx) "'") "''") ", "
         parent " )"))

      (when (stringp (setq result (sqlite_exec db sql)))
         (die result))

      (when attrs
         (make_attrs attrs)))

   (defun make_open (name attrs)
      (setq path_string (stringify path_string "/" name))

      (setq sql (stringify "INSERT INTO document VALUES ( " (inc idx) ",'"
         path_string "', "
         (if attrs (stringify "'attrs" (inc attrs_idx) "'") "''") ", "
         parent " )"))

      (when (stringp (setq result (sqlite_exec db sql)))
         (die result))

      (push parents parent)
      (setq parent idx)

      (when attrs
         (make_attrs attrs)))

   (defun make_close ()
      (setq parent (pop parents))
      (setq path_string (substitute ps_rx "" path_string)))

   (defun make_attrs (attrs)
      (setq sql (stringify "CREATE TABLE attrs" attrs_idx " ( key TEXT, value TEXT )"))
      (when (stringp (setq result (sqlite_exec db sql)))
         (die result))

      (while attrs
         (setq sql (stringify "INSERT INTO attrs" attrs_idx
            " VALUES ( '" (caar attrs) "','" (car (cdar attrs)) "' )"))

         (when (stringp (setq result (sqlite_exec db sql)))
            (die result))

         (setq attrs (cdr attrs)))))

; Function to add a parsed item to the database.

(let ((cdata_rx (regcomp "^<!\[CDATA\[(.*)\]\]>$"))
      (empty_rx (regcomp (concat "^<(" name ")(([" whitespace "]+" attribute ")*)" "[" whitespace "]*/>$")))
      (start_rx (regcomp (concat "^<(" name ")(([" whitespace "]+" attribute ")*)" "[" whitespace "]*>$")))
      (end_rx (regcomp (concat "^</(" name ")[" whitespace "]*>$")))
      (xml_rx (regcomp (concat "^<\?([xX][Mm][Ll])(([" whitespace "]+" attribute ")*)" "[" whitespace "]*\?>$")))
      (comment_rx (regcomp "^<!--.*-->$"))
      (proc_rx (regcomp "^<\\?.*\\?>"))
      (m ()))

   (defun make_item (type item)

      (if (eq type 'cdata)
         (make_cdata (convert_refs item 1))

         ; cdata_rx clause must come first.

         (cond ((match cdata_rx item)
                (make_cdata (convert_refs (substitute cdata_rx "\1" item) 0)))

               ((setq m (matches start_rx item))
                (make_open (cadr m) (break_up_attrs (car (cddr m)))))

               ((match end_rx item)
                (make_close))

               ((setq m (matches empty_rx item))
                (make_empty (cadr m) (break_up_attrs (car (cddr m)))))

               ((match xml_rx item)
                (check_version (matches xml_rx item)))

               ((match proc_rx item) 1)
               ((match comment_rx item) 1)
               
               (1 (die "unrecognized tag: " item))))))

; See if the user has provided us a filename for the database,
; otherwise we used "document.db".

(load (join "/" (libdir) "options.munger"))
(getopt)

(unless (setq file (lookup options "f"))
   (setq file "document.db"))

; We read from the first filename specified on the command-line, or from
; stdin.  The call to (getopt) above has left the argument pointer pointing to
; the last option, if any, or the script name, so that we need only call
; (next) once to get the name of the first command-line argument.

(when (next)
   (redirect 0 (current)))

; Open the database.

(let ((line ""))

   (when (stringp (setq db (sqlite_open file)))
      (die db))

   (when (stringp (setq line (sqlite_exec db (concat "CREATE TABLE document ( 'index' INTEGER, "
      "'path' TEXT, 'data' TEXT, parent INTEGER )"))))
      (die line))

   (when (stringp (setq line (sqlite_exec db "BEGIN TRANSACTION")))
      (die line))

   (while (setq line (getline))
      (parse line))
   (parse line)

   (when (stringp (setq line (sqlite_exec db "COMMIT TRANSACTION")))
      (die line))

   (sqlite_close db)
   (quit))
