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 / demos / TclXML / flatten.tcl next >
Encoding:
Text File  |  2001-10-22  |  8.0 KB  |  317 lines
  1. #!/bin/sh
  2. # -*- tcl -*- \
  3. exec tclsh8.3 "$0" "$@"
  4.  
  5. # flatten.tcl --
  6. #
  7. #    Parse a DTD, resolve all external entities, parameter
  8. #    entities and conditional sections and save the result.
  9. #
  10. # Copyright (c) 2000 Zveno Pty Ltd
  11. # http://www.zveno.com/
  12. # 
  13. # Zveno makes this software and all associated data and documentation
  14. # ('Software') available free of charge for any purpose.
  15. # Copies may be made of this Software but all of this notice must be included
  16. # on any copy.
  17. # 
  18. # The Software was developed for research purposes and Zveno does not warrant
  19. # that it is error free or fit for any purpose.  Zveno disclaims any
  20. # liability for all claims, expenses, losses, damages and costs any user may
  21. # incur as a result of using, copying or modifying the Software.
  22. #
  23. # CVS: $Id: flatten.tcl,v 1.2 2000/05/19 23:56:20 steve Exp $
  24.  
  25. # Allow the script to work from the source directory
  26. set auto_path [linsert $auto_path 0 [file dirname [file dirname [file join [pwd] [info script]]]]]
  27.  
  28. # We need TclXML
  29. package require xml 2.0
  30.  
  31. # Process --
  32. #
  33. #    Parse a XML document or DTD and emit result
  34. #
  35. # Arguments:
  36. #    data    XML text
  37. #    type    "xml" or "dtd"
  38. #    out    output channel
  39. #    args    configration options
  40. #
  41. # Results:
  42. #    Data is parsed and flattened DTD written to output channel
  43.  
  44. proc Process {data type out args} {
  45.     global elementDeclCount PEDeclCount AttListDeclCount CommentCount
  46.     global config
  47.     set elementDeclCount [set PEDeclCount [set AttListDeclCount [set CommentCount 0]]]
  48.  
  49.     # Create the parser object.
  50.     # We want to use the Tcl-only parser for this application,
  51.     # because it can resolve entities without doing full
  52.     # validation.
  53.  
  54.     set parser [eval ::xml::parser \
  55.         -elementstartcommand ElementStart \
  56.         -validate 1 \
  57.         $args \
  58.         ]
  59.  
  60.     if {$config(wantElementDecls)} {
  61.     $parser configure -elementdeclcommand [list ElementDeclaration $out]
  62.     }
  63.     if {$config(wantPEDecls)} {
  64.     $parser configure -parameterentitydeclcommand [list PEDecl $out]
  65.     }
  66.     if {$config(wantAttListDecls)} {
  67.     $parser configure -attlistdeclcommand [list AttListDecl $out]
  68.     }
  69.     if {$config(wantComments)} {
  70.     $parser configure -commentcommand [list Comment $out]
  71.     }
  72.  
  73.     switch $type {
  74.     xml {
  75.         # Proceed with normal parsing method
  76.         $parser parse $data
  77.     }
  78.  
  79.     dtd {
  80.         # Use the DTD parsing method instead
  81.         $parser parse $data -dtdsubset external
  82.     }
  83.     }
  84.  
  85.     # Clean up parser object
  86.     #$parser free
  87.     #rename $parser {}
  88.  
  89.     return {}
  90. }
  91.  
  92. # ElementStart --
  93. #
  94. #    Callback for the start of an element.
  95. #
  96. # Arguments:
  97. #    name    tag name
  98. #    attlist    attribute list
  99. #    args    other information
  100. #
  101. # Results:
  102. #    Returns break error code, since we don't
  103. #    care about the document instance, only the DTD
  104.  
  105. proc ElementStart {name attlist args} {
  106.     return -code break
  107. }
  108.  
  109. # ElementDeclaration --
  110. #
  111. #    Callback for an element declaration.
  112. #
  113. # Arguments:
  114. #    out    output channel
  115. #    name    tag name
  116. #    cmodel    content model specification
  117. #
  118. # Results:
  119. #    Writes element declaration to output channel
  120.  
  121. proc ElementDeclaration {out name cmodel} {
  122.     global elementDeclCount
  123.     incr elementDeclCount
  124.  
  125.     regsub -all "\[ \t\n\r\]+" $cmodel { } cmodel
  126.     puts $out "<!ELEMENT $name $cmodel>"
  127.  
  128.     return {}
  129. }
  130.  
  131. # PEDecl --
  132. #
  133. #    Callback for a parameter entity declaration.
  134. #
  135. # Arguments:
  136. #    out    output channel
  137. #    name    PE name
  138. #    repl    replacement text
  139. #
  140. # Results:
  141. #    Writes info to stderr
  142.  
  143. proc PEDecl {out name repl args} {
  144.     global PEDeclCount
  145.     incr PEDeclCount
  146.  
  147.     if {[llength $args]} {
  148.     puts $out "<!ENTITY % $name PUBLIC \"[lindex $args 0]\" \"$repl\">"
  149.     } else {
  150.     puts $out "<!ENTITY % $name \"[string trim $repl]\">"
  151.     }
  152.  
  153.     return {}
  154. }
  155.  
  156. # AttListDecl --
  157. #
  158. #    Callback for an attribute list declaration.
  159. #
  160. # Arguments:
  161. #    out    output channel
  162. #    name    element name
  163. #    attname    attribute name
  164. #    type    attribute definition type
  165. #    dflt    default type
  166. #    dfltval    default value
  167. #
  168. # Results:
  169. #    Writes info to stderr
  170.  
  171. proc AttListDecl {out name attname type dflt dfltval} {
  172.     global AttListDeclCount
  173.     incr AttListDeclCount
  174.  
  175.     puts $out "<!ATTLIST $name $attname $type $dflt $dfltval>"
  176.  
  177.     return {}
  178. }
  179.  
  180. # Comment --
  181. #
  182. #    Callback for a comment.
  183. #
  184. # Arguments:
  185. #    out    output channel
  186. #    data    comment data
  187. #
  188. # Results:
  189. #    Writes info to stderr
  190.  
  191. proc Comment {out data} {
  192.     global CommentCount
  193.     incr CommentCount
  194.  
  195.     puts $out "<!--${data}-->"
  196.  
  197.     return {}
  198. }
  199.  
  200. # Open --
  201. #
  202. #    Manage opening document in GUI environment
  203. #
  204. # Arguments:
  205. #    None
  206. #
  207. # Results:
  208. #    XML or DTD document opened and parsed
  209.  
  210. proc Open {} {
  211.     global currentDir status
  212.  
  213.     set filename [tk_getOpenFile -parent . -title "Open Document" -initialdir $currentDir -defaultextension ".xml" -filetypes {
  214.     {{XML Documents}    {.xml}    }
  215.     {{DTD Files}        {.dtd}    }
  216.     {{All File}        *    }
  217.     }]
  218.     if {![string length $filename]} {
  219.     return {}
  220.     }
  221.  
  222.     set currentDir [file dirname $filename]
  223.     set savename [file join [file rootname $filename].dtd]
  224.     set savename [tk_getSaveFile -parent . -title "Save DTD" -initialdir $currentDir -initialfile $savename -defaultextension ".dtd" -filetypes {
  225.     {{XML Documents}    {.xml}    }
  226.     {{DTD Files}        {.dtd}    }
  227.     {{All File}        *    }
  228.     }]
  229.     if {![string length $savename]} {
  230.     return {}
  231.     }
  232.  
  233.     set status Processing
  234.     set oldcursor [. cget -cursor]
  235.     . configure -cursor watch
  236.     grab .elementDecls
  237.     update
  238.  
  239.     set ch [open $filename]
  240.     set out [open $savename w]
  241.     if {[catch {Process [read $ch] [expr {[file extension $filename] == ".dtd" ? "dtd" : "xml"}] $out -baseurl file://[file join [pwd] $filename]} err]} {
  242.  
  243.     tk_messageBox -message [format [mc {Unable to process document "%s" due to "%s"}] $filename $err] -icon error -default ok -parent . -type ok
  244.     } else {
  245.     tk_messageBox -message [mc "DTD Saved OK"] -icon info -default ok -parent . -type ok
  246.     }
  247.  
  248.     close $ch
  249.     close $out
  250.     set status {}
  251.     grab release .elementDecls
  252.     . configure -cursor $oldcursor
  253.     return {}
  254. }
  255.  
  256. ### Main script
  257.  
  258. # Initialize message catalog, in case it is used
  259. package require msgcat
  260. namespace import msgcat::mc
  261. catch {::msgcat::mcload [file join [file dirname [info script]] msgs]}
  262.  
  263. # Usage: flatten.tcl file1 file2 ...
  264. # "-" reads input from stdin
  265. # No arguments - Tk means read from stdin
  266. # Files read from stdin assumed to be XML documents
  267. # When given files to read, all output goes to stdout
  268. # No arguments + Tk means use GUI
  269.  
  270. switch [llength $argv] {
  271.     0 {
  272.     if {![catch {package require Tk}]} {
  273.         # Create a nice little GUI
  274.         array set config {wantElementDecls 1 wantPEDecls 0 wantAttlistDecls 1 wantComments 0}
  275.         checkbutton .wantElementDecls -variable config(wantElementDecls)
  276.         label .elementDeclLabel -text [mc "Element declarations:"]
  277.         label .elementDecls -textvariable elementDeclCount
  278.         checkbutton .wantPEDecls -variable config(wantPEDecls)
  279.         label .peDeclLabel -text [mc "PE declarations:"]
  280.         label .peDecls -textvariable PEDeclCount
  281.         checkbutton .wantAttListDecls -variable config(wantAttListDecls)
  282.         label .attListDeclLabel -text [mc "Atttribute List declarations:"]
  283.         label .attListDecls -textvariable AttListDeclCount
  284.         checkbutton .wantComments -variable config(wantComments)
  285.         label .commentLabel -text [mc "Comments:"]
  286.         label .comments -textvariable CommentCount
  287.         label .status -textvariable status -foreground red
  288.         grid .wantElementDecls .elementDeclLabel .elementDecls
  289.         grid .wantPEDecls .peDeclLabel .peDecls
  290.         grid .wantAttListDecls .attListDeclLabel .attListDecls
  291.         grid .wantComments .commentLabel .comments
  292.         grid .status - -
  293.         . configure -menu .menu
  294.         menu .menu -tearoff 0
  295.         .menu add cascade -label [mc File] -menu .menu.file
  296.         menu .menu.file
  297.         .menu.file add command -label [mc Open] -command Open
  298.         .menu.file add separator
  299.         .menu.file add command -label [mc Quit] -command exit
  300.         set currentDir [pwd]
  301.     } else {
  302.         Process [read stdin] xml stdout
  303.     }
  304.     }
  305.     default {
  306.     foreach filename $argv {
  307.         if {$filename == "-"} {
  308.         Process [read stdin] xml stdout
  309.         } else {
  310.         set ch [open $filename]
  311.         Process [read $ch] [expr {[file extension $filename] == ".dtd" ? "dtd" : "xml"}] stdout -baseurl file://[file join [pwd] $filename]
  312.         close $ch
  313.         }
  314.     }
  315.     }
  316. }
  317.