home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclxml2.0 / tclparser-8.1.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  12.0 KB  |  488 lines
  1. # tclparser-8.1.tcl --
  2. #
  3. #    This file provides a Tcl implementation of a XML parser.
  4. #    This file supports Tcl 8.1.
  5. #
  6. #    See xml-8.[01].tcl for definitions of character sets and
  7. #    regular expressions.
  8. #
  9. # Copyright (c) 1998-2001 Zveno Pty Ltd
  10. # http://www.zveno.com/
  11. # 
  12. # Zveno makes this software and all associated data and documentation
  13. # ('Software') available free of charge for any purpose.
  14. # Copies may be made of this Software but all of this notice must be included
  15. # on any copy.
  16. # 
  17. # The Software was developed for research purposes and Zveno does not warrant
  18. # that it is error free or fit for any purpose.  Zveno disclaims any
  19. # liability for all claims, expenses, losses, damages and costs any user may
  20. # incur as a result of using, copying or modifying the Software.
  21. #
  22. # Copyright (c) 1997 Australian National University (ANU).
  23. # 
  24. # ANU makes this software and all associated data and documentation
  25. # ('Software') available free of charge for any purpose. You may make copies
  26. # of the Software but you must include all of this notice on any copy.
  27. # 
  28. # The Software was developed for research purposes and ANU does not warrant
  29. # that it is error free or fit for any purpose.  ANU disclaims any
  30. # liability for all claims, expenses, losses, damages and costs any user may
  31. # incur as a result of using, copying or modifying the Software.
  32. #
  33. # $Id: tclparser-8.1.tcl,v 1.12 2001/02/26 02:11:11 doss Exp $
  34.  
  35. package require Tcl 8.1
  36.  
  37. package provide xml::tclparser 2.0
  38.  
  39. package require xmldefs 2.0
  40.  
  41. package require sgmlparser 1.0
  42.  
  43. namespace eval xml::tclparser {
  44.  
  45.     namespace export create createexternal externalentity parse configure get delete
  46.  
  47.     # Tokenising expressions
  48.  
  49.     variable tokExpr $::xml::tokExpr
  50.     variable substExpr $::xml::substExpr
  51.  
  52.     # Register this parser class
  53.  
  54.     ::xml::parserclass create tcl \
  55.         -createcommand [namespace code create] \
  56.         -createentityparsercommand [namespace code createentityparser] \
  57.         -parsecommand [namespace code parse] \
  58.         -configurecommand [namespace code configure] \
  59.         -deletecommand [namespace code delete]
  60. }
  61.  
  62. # xml::tclparser::create --
  63. #
  64. #    Creates XML parser object.
  65. #
  66. # Arguments:
  67. #    name    unique identifier for this instance
  68. #
  69. # Results:
  70. #    The state variable is initialised.
  71.  
  72. proc xml::tclparser::create name {
  73.  
  74.     # Initialise state variable
  75.     upvar \#0 [namespace current]::$name parser
  76.     array set parser [list -name $name            \
  77.     -final 1                    \
  78.     -validate 0                    \
  79.     -statevariable [namespace current]::$name    \
  80.     -baseurl {}                    \
  81.     internaldtd {}                    \
  82.     entities [namespace current]::Entities$name    \
  83.     extentities [namespace current]::ExtEntities$name    \
  84.     parameterentities [namespace current]::PEntities$name    \
  85.     externalparameterentities [namespace current]::ExtPEntities$name    \
  86.     elementdecls [namespace current]::ElDecls$name    \
  87.     attlistdecls [namespace current]::AttlistDecls$name    \
  88.     notationdecls [namespace current]::NotDecls$name    \
  89.     depth 0                        \
  90.     ]
  91.  
  92.     # Initialise entities with predefined set
  93.     array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
  94.  
  95.     return $name
  96. }
  97.  
  98. # xml::tclparser::createentityparser --
  99. #
  100. #    Creates XML parser object for an entity.
  101. #
  102. # Arguments:
  103. #    name    name for the new parser
  104. #    parent    name of parent parser
  105. #
  106. # Results:
  107. #    The state variable is initialised.
  108.  
  109. proc xml::tclparser::createentityparser {parent name} {
  110.     upvar #0 [namespace current]::$parent p
  111.  
  112.     # Initialise state variable
  113.     upvar \#0 [namespace current]::$name external
  114.     array set external [array get p]
  115.  
  116.     array set external [list -name $name            \
  117.     -statevariable [namespace current]::$name    \
  118.     internaldtd {}                    \
  119.     line 0                        \
  120.     ]
  121.     incr external(depth)
  122.  
  123.     return $name
  124. }
  125.  
  126. # xml::tclparser::configure --
  127. #
  128. #    Configures a XML parser object.
  129. #
  130. # Arguments:
  131. #    name    unique identifier for this instance
  132. #    args    option name/value pairs
  133. #
  134. # Results:
  135. #    May change values of config options
  136.  
  137. proc xml::tclparser::configure {name args} {
  138.     upvar \#0 [namespace current]::$name parser
  139.  
  140.     # BUG: very crude, no checks for illegal args
  141.     array set parser $args
  142.  
  143.     return {}
  144. }
  145.  
  146. # xml::tclparser::parse --
  147. #
  148. #    Parses document instance data
  149. #
  150. # Arguments:
  151. #    name    parser object
  152. #    xml    data
  153. #    args    configuration options
  154. #
  155. # Results:
  156. #    Callbacks are invoked
  157.  
  158. proc xml::tclparser::parse {name xml args} {
  159.  
  160.     array set options $args
  161.     upvar \#0 [namespace current]::$name parser
  162.     variable tokExpr
  163.     variable substExpr
  164.  
  165.     set parseOptions [list \
  166.         -emptyelement [namespace code ParseEmpty] \
  167.         -parseattributelistcommand [namespace code ParseAttrs] \
  168.         -parseentitydeclcommand [namespace code ParseEntity] \
  169.         -normalize 0]
  170.     eval lappend parseOptions \
  171.         [array get parser -*command] \
  172.         [array get parser -reportempty] \
  173.         [array get parser -name] \
  174.         [array get parser -baseurl] \
  175.         [array get parser -validate] \
  176.         [array get parser -final] \
  177.         [array get parser -defaultexpandinternalentities] \
  178.         [array get parser entities] \
  179.         [array get parser extentities] \
  180.         [array get parser parameterentities] \
  181.         [array get parser externalparameterentities] \
  182.         [array get parser elementdecls] \
  183.         [array get parser attlistdecls] \
  184.         [array get parser notationdecls]
  185.  
  186.     set dtdsubset no
  187.     catch {set dtdsubset $options(-dtdsubset)}
  188.     switch -- $dtdsubset {
  189.     internal {
  190.         # Bypass normal parsing
  191.         lappend parseOptions -statevariable $parser(-statevariable)
  192.         array set intOptions [array get ::sgml::StdOptions]
  193.         array set intOptions $parseOptions
  194.         ::sgml::ParseDTD:Internal [array get intOptions] $xml
  195.         return {}
  196.     }
  197.     external {
  198.         # Bypass normal parsing
  199.         lappend parseOptions -statevariable $parser(-statevariable)
  200.         array set intOptions [array get ::sgml::StdOptions]
  201.         array set intOptions $parseOptions
  202.         ::sgml::ParseDTD:External [array get intOptions] $xml
  203.         return {}
  204.     }
  205.     default {
  206.         # Pass through to normal processing
  207.     }
  208.     }
  209.  
  210.     set tokenised [lrange \
  211.         [::sgml::tokenise $xml \
  212.         $tokExpr \
  213.         $substExpr \
  214.         -internaldtdvariable [namespace current]::${name}(internaldtd)] \
  215.     4 end]
  216.  
  217.     lappend parseOptions -internaldtd [list $parser(internaldtd)]
  218.     eval ::sgml::parseEvent [list $tokenised] $parseOptions
  219.  
  220.     return {}
  221. }
  222.  
  223. # xml::tclparser::ParseEmpty --  Tcl 8.1+ version
  224. #
  225. #    Used by parser to determine whether an element is empty.
  226. #    This is usually dead easy in XML, but as always not quite.
  227. #    Have to watch out for empty element syntax
  228. #
  229. # Arguments:
  230. #    tag    element name
  231. #    attr    attribute list (raw)
  232. #    e    End tag delimiter.
  233. #
  234. # Results:
  235. #    Return value of e
  236.  
  237. proc xml::tclparser::ParseEmpty {tag attr e} {
  238.     switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
  239.     0,0 {
  240.         return {}
  241.     }
  242.     0,* {
  243.         return /
  244.     }
  245.     default {
  246.         return $e
  247.     }
  248.     }
  249. }
  250.  
  251. # xml::tclparser::ParseAttrs -- Tcl 8.1+ version
  252. #
  253. #    Parse element attributes.
  254. #
  255. # There are two forms for name-value pairs:
  256. #
  257. #    name="value"
  258. #    name='value'
  259. #
  260. # Arguments:
  261. #    attrs    attribute string given in a tag
  262. #
  263. # Results:
  264. #    Returns a Tcl list representing the name-value pairs in the 
  265. #    attribute string
  266. #
  267. #    A ">" occurring in the attribute list causes problems when parsing
  268. #    the XML.  This manifests itself by an unterminated attribute value
  269. #    and a ">" appearing the element text.
  270. #    In this case return a three element list;
  271. #    the message "unterminated attribute value", the attribute list it
  272. #    did manage to parse and the remainder of the attribute list.
  273.  
  274. proc xml::tclparser::ParseAttrs attrs {
  275.  
  276.     set result {}
  277.  
  278.     while {[string length [string trim $attrs]]} {
  279.     if {[regexp ($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
  280.         lappend result $attrName [NormalizeAttValue $value]
  281.     } elseif {[regexp $::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
  282.         return -code error [list {unterminated attribute value} $result $attrs]
  283.     } else {
  284.         return -code error "invalid attribute list"
  285.     }
  286.     }
  287.  
  288.     return $result
  289. }
  290.  
  291. # xml::tclparser::NormalizeAttValue --
  292. #
  293. #    Perform attribute value normalisation.  This involves:
  294. #    . character references are appended to the value
  295. #    . entity references are recursively processed and replacement value appended
  296. #    . whitespace characters cause a space to be appended
  297. #    . other characters appended as-is
  298. #
  299. #    Because no state is passed in here, it's a bit difficult
  300. #    to pass entity references back into the parser for further
  301. #    replacement.  I'll just punt on the whole thing for now and do
  302. #    basic normalisation - char refs, pre-defined entities and ws.
  303. #
  304. # Arguments:
  305. #    value    unparsed attribute value
  306. #
  307. # Results:
  308. #    Normalised value returned.
  309.  
  310. proc xml::tclparser::NormalizeAttValue value {
  311.  
  312.     # sgmlparser already has backslashes protected
  313.     # Protect Tcl specials
  314.     regsub -all {([][$])} $value {\\\1} value
  315.  
  316.     # Deal with white space
  317.     regsub -all "\[$::xml::Wsp\]" $value { } value
  318.  
  319.     # Find entity refs
  320.     regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef {\1}]} value
  321.  
  322.     return [subst $value]
  323. }
  324.  
  325. # xml::tclparser::NormalizeAttValue:DeRef --
  326. #
  327. #    Simplistic handler to normalize attribute values
  328. #
  329. # Arguments:
  330. #    ref    entity reference
  331. #
  332. # Results:
  333. #    Returns character
  334.  
  335. proc xml::tclparser::NormalizeAttValue:DeRef ref {
  336.     switch -glob -- $ref {
  337.     #x* {
  338.         scan [string range 2 $ref] %x value
  339.         return $value
  340.     }
  341.     #* {
  342.         scan [string range 1 $ref] %d value
  343.         return $value
  344.     }
  345.     lt -
  346.     gt -
  347.     amp -
  348.     quot -
  349.     apos {
  350.         array set map {lt < gt > amp & quot \" apos '}
  351.         return $map($ref)
  352.     }
  353.     default {
  354.         return -code error "unable to resolve entity reference \"$ref\""
  355.     }
  356.     }
  357. }
  358.  
  359. # xml::tclparser::ParseEntity --
  360. #
  361. #    Parse general entity declaration
  362. #
  363. # Arguments:
  364. #    data    text to parse
  365. #
  366. # Results:
  367. #    Tcl list containing entity declaration
  368.  
  369. proc xml::tclparser::ParseEntity data {
  370.     set data [string trim $data]
  371.     if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
  372.     switch $type {
  373.         PUBLIC {
  374.         return [list external $id2 $id1 $ndata]
  375.         }
  376.         SYSTEM {
  377.         return [list external $id1 {} $ndata]
  378.         }
  379.     }
  380.     } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
  381.     return [list internal $value]
  382.     } else {
  383.     return -code error "badly formed entity declaration"
  384.     }
  385. }
  386.  
  387. # xml::tclparser::delete --
  388. #
  389. #    Destroy parser data
  390. #
  391. # Arguments:
  392. #    name    parser object
  393. #
  394. # Results:
  395. #    Parser data structure destroyed
  396.  
  397. proc xml::tclparser::delete name {
  398.     upvar \#0 [namespace current]::$name parser
  399.     catch {::sgml::ParserDelete $parser(-statevariable)}
  400.     catch {unset parser}
  401.     return {}
  402. }
  403.  
  404. # xml::tclparser::get --
  405. #
  406. #    Retrieve additional information from the parser
  407. #
  408. # Arguments:
  409. #    name    parser object
  410. #    method    info to retrieve
  411. #    args    additional arguments for method
  412. #
  413. # Results:
  414. #    Depends on method
  415.  
  416. proc xml::tclparser::get {name method args} {
  417.     upvar #0 [namespace current]::$name parser
  418.  
  419.     switch -- $method {
  420.  
  421.     elementdecl {
  422.         switch [llength $args] {
  423.  
  424.         0 {
  425.             # Return all element declarations
  426.             upvar #0 $parser(elementdecls) elements
  427.             return [array get elements]
  428.         }
  429.  
  430.         1 {
  431.             # Return specific element declaration
  432.             upvar #0 $parser(elementdecls) elements
  433.             if {[info exists elements([lindex $args 0])]} {
  434.             return [array get elements [lindex $args 0]]
  435.             } else {
  436.             return -code error "element \"[lindex $args 0]\" not declared"
  437.             }
  438.         }
  439.  
  440.         default {
  441.             return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
  442.         }
  443.         }
  444.     }
  445.  
  446.     attlist {
  447.         if {[llength $args] != 1} {
  448.         return -code error "wrong number of arguments: should be \"get attlist element\""
  449.         }
  450.  
  451.         upvar #0 $parser(attlistdecls)
  452.  
  453.         return {}
  454.     }
  455.  
  456.     entitydecl {
  457.     }
  458.  
  459.     parameterentitydecl {
  460.     }
  461.  
  462.     notationdecl {
  463.     }
  464.  
  465.     default {
  466.         return -code error "unknown method \"$method\""
  467.     }
  468.     }
  469.  
  470.     return {}
  471. }
  472.  
  473. # xml::tclparser::ExternalEntity --
  474. #
  475. #    Resolve and parse external entity
  476. #
  477. # Arguments:
  478. #    name    parser object
  479. #    base    base URL
  480. #    sys    system identifier
  481. #    pub    public identifier
  482. #
  483. # Results:
  484. #    External entity is fetched and parsed
  485.  
  486. proc xml::tclparser::ExternalEntity {name base sys pub} {
  487. }
  488.