flatten.tcl

Go to the documentation of this file.

/* !/bin/sh*/
/*  -*- tcl -*- \*/
exec tclsh8.3 "$0" "$@"

/*  flatten.tcl --*/
/* */
/*  Parse a DTD, resolve all external entities, parameter*/
/*  entities and conditional sections and save the result.*/
/* */
/*  Copyright (c) 2000 Zveno Pty Ltd*/
/*  http://www.zveno.com/*/
/*  */
/*  Zveno makes this software and all associated data and documentation*/
/*  ('Software') available free of charge for any purpose.*/
/*  Copies may be made of this Software but all of this notice must be included*/
/*  on any copy.*/
/*  */
/*  The Software was developed for research purposes and Zveno does not warrant*/
/*  that it is error free or fit for any purpose.  Zveno disclaims any*/
/*  liability for all claims, expenses, losses, damages and costs any user may*/
/*  incur as a result of using, copying or modifying the Software.*/
/* */
/*  CVS: $Id: flatten.tcl,v 1.2 2000/05/19 23:56:20 steve Exp $*/

/*  Allow the script to work from the source directory*/
 auto = _path [linsert $auto_path 0 [file dirname [file dirname [file join [pwd] [info script]]]]]

/*  We need TclXML*/
package require xml 2.0

/*  Process --*/
/* */
/*  Parse a XML document or DTD and emit result*/
/* */
/*  Arguments:*/
/*  data    XML text*/
/*  type    "xml" or "dtd"*/
/*  out output channel*/
/*  args    configration options*/
/* */
/*  Results:*/
/*  Data is parsed and flattened DTD written to output channel*/

ret  Process (type data , type type , type out , type args) {
    global elementDeclCount PEDeclCount AttListDeclCount CommentCount
    global config
    set elementDeclCount [set PEDeclCount [set AttListDeclCount [set CommentCount 0]]]

    # Create the parser object.
    # We want to use the Tcl-only parser for this application,
    # because it can resolve entities without doing full
    # validation.

    set parser [eval ::xml::parser \
        -elementstartcommand ElementStart \
        -validate 1 \
        $args \
        ]

    if {$config(wantElementDecls)} {
    $parser configure -elementdeclcommand [list ElementDeclaration $out]
    }
    if {$config(wantPEDecls)} {
    $parser configure -parameterentitydeclcommand [list PEDecl $out]
    }
    if {$config(wantAttListDecls)} {
    $parser configure -attlistdeclcommand [list AttListDecl $out]
    }
    if {$config(wantComments)} {
    $parser configure -commentcommand [list Comment $out]
    }

    switch $type {
    xml {
        # Proceed with normal parsing method
        $parser parse $data
    }

    dtd {
        # Use the DTD parsing method instead
        $parser parse $data -dtdsubset external
    }
    }

    # Clean up parser object
    #$parser free
    #rename $parser {}

    return {}
}

/*  ElementStart --*/
/* */
/*  Callback for the start of an element.*/
/* */
/*  Arguments:*/
/*  name    tag name*/
/*  attlist attribute list*/
/*  args    other information*/
/* */
/*  Results:*/
/*  Returns break error code, since we don't*/
/*  care about the document instance, only the DTD*/

ret  ElementStart (type name , type attlist , type args) {
    return -code break
}

/*  ElementDeclaration --*/
/* */
/*  Callback for an element declaration.*/
/* */
/*  Arguments:*/
/*  out output channel*/
/*  name    tag name*/
/*  cmodel  content model specification*/
/* */
/*  Results:*/
/*  Writes element declaration to output channel*/

ret  ElementDeclaration (type out , type name , type cmodel) {
    global elementDeclCount
    incr elementDeclCount

    regsub -all "\[ \t\n\r\]+" $cmodel { } cmodel
    puts $out "<!ELEMENT $name $cmodel>"

    return {}
}

/*  PEDecl --*/
/* */
/*  Callback for a parameter entity declaration.*/
/* */
/*  Arguments:*/
/*  out output channel*/
/*  name    PE name*/
/*  repl    replacement text*/
/* */
/*  Results:*/
/*  Writes info to stderr*/

ret  PEDecl (type out , type name , type repl , type args) {
    global PEDeclCount
    incr PEDeclCount

    if {[llength $args]} {
    puts $out "<!ENTITY % $name PUBLIC \"[lindex $args 0]\" \"$repl\">"
    } else {
    puts $out "<!ENTITY % $name \"[string trim $repl]\">"
    }

    return {}
}

/*  AttListDecl --*/
/* */
/*  Callback for an attribute list declaration.*/
/* */
/*  Arguments:*/
/*  out output channel*/
/*  name    element name*/
/*  attname attribute name*/
/*  type    attribute definition type*/
/*  dflt    default type*/
/*  dfltval default value*/
/* */
/*  Results:*/
/*  Writes info to stderr*/

ret  AttListDecl (type out , type name , type attname , type type , type dflt , type dfltval) {
    global AttListDeclCount
    incr AttListDeclCount

    puts $out "<!ATTLIST $name $attname $type $dflt $dfltval>"

    return {}
}

/*  Comment --*/
/* */
/*  Callback for a comment.*/
/* */
/*  Arguments:*/
/*  out output channel*/
/*  data    comment data*/
/* */
/*  Results:*/
/*  Writes info to stderr*/

ret  Comment (type out , type data) {
    global CommentCount
    incr CommentCount

    puts $out "<!--${data}-->"

    return {}
}

/*  Open --*/
/* */
/*  Manage opening document in GUI environment*/
/* */
/*  Arguments:*/
/*  None*/
/* */
/*  Results:*/
/*  XML or DTD document opened and parsed*/

ret  Open () {
    global currentDir status

    set filename [tk_getOpenFile -parent . -title "Open Document" -initialdir $currentDir -defaultextension ".xml" -filetypes {
    {{XML Documents}    {.xml}  }
    {{DTD Files}        {.dtd}  }
    {{All File}     *   }
    }]
    if {![string length $filename]} {
    return {}
    }

    set currentDir [file dirname $filename]
    set savename [file join [file rootname $filename].dtd]
    set savename [tk_getSaveFile -parent . -title "Save DTD" -initialdir $currentDir -initialfile $savename -defaultextension ".dtd" -filetypes {
    {{XML Documents}    {.xml}  }
    {{DTD Files}        {.dtd}  }
    {{All File}     *   }
    }]
    if {![string length $savename]} {
    return {}
    }

    set status Processing
    set oldcursor [. cget -cursor]
    . configure -cursor watch
    grab .elementDecls
    update

    set ch [open $filename]
    set out [open $savename w]
    if {[catch {Process [read $ch] [expr {[file extension $filename] == ".dtd" ? "dtd" : "xml"}] $out -baseurl file://[file join [pwd] $filename]} err]} {

    tk_messageBox -message [format [mc {Unable to process document "%s" due to "%s"}] $filename $err] -icon error -default ok -parent . -type ok
    } else {
    tk_messageBox -message [mc "DTD Saved OK"] -icon info -default ok -parent . -type ok
    }

    close $ch
    close $out
    set status {}
    grab release .elementDecls
    . configure -cursor $oldcursor
    return {}
}

/*  Main script*/

/*  Initialize message catalog, in case it is used*/
package require msgcat
namespace import msgcat::mc
catch {::msgcat::mc

/*  Usage: flatten.tcl file1 file2 ...*/
/*  "-" reads input from stdin*/
/*  No arguments - Tk means read from stdin*/
/*  Files read from stdin assumed to be XML documents*/
/*  When given files to read, all output goes to stdout*/
/*  No arguments + Tk means use GUI*/

switch [llength $argv] {
    0 {
    if {![catch {package require Tk}]} {
        /*  Create a nice little GUI*/
        array  config =  {wantElementDecls 1 wantPEDecls 0 wantAttlistDecls 1 wantComments 0}
        checkbutton .wantElementDecls -variable config(wantElementDecls)
        label .elementDeclLabel -text [mc "Element declarations:"]
        label .elementDecls -textvariable elementDeclCount
        checkbutton .wantPEDecls -variable config(wantPEDecls)
        label .peDeclLabel -text [mc "PE declarations:"]
        label .peDecls -textvariable PEDeclCount
        checkbutton .wantAttListDecls -variable config(wantAttListDecls)
        label .attListDeclLabel -text [mc "Atttribute List declarations:"]
        label .attListDecls -textvariable AttListDeclCount
        checkbutton .wantComments -variable config(wantComments)
        label .commentLabel -text [mc "Comments:"]
        label .comments -textvariable CommentCount
        label .status -textvariable status -foreground red
        grid .wantElementDecls .elementDeclLabel .elementDecls
        grid .wantPEDecls .peDeclLabel .peDecls
        grid .wantAttListDecls .attListDeclLabel .attListDecls
        grid .wantComments .commentLabel .comments
        grid .status - -
        . configure -menu .menu
        menu .menu -tearoff 0
        .menu add cascade -label [mc File] -menu .menu.file
        menu .menu.file
        .menu.file add command -label [mc Open] -command Open
        .menu.file add separator
        .menu.file add command -label [mc Quit] -command exit
         currentDir =  [pwd]
    } else {
        Process [read stdin] xml stdout
    }
    }
    default {
    foreach filename $argv {
        if {$filename == "-"} {
        Process [read stdin] xml stdout
        } else {
         ch =  [open $filename]
        Process [read $ch] [expr {[file extension $filename] == ".dtd" ? "dtd" : "xml"}] stdout -baseurl file://[file join [pwd] $filename]
        close $ch
        }
    }
    }
}