MyTcl Syntax 파일 생성하기

MyTcl의 syntax 정의 파일을 Tcl/Tk Documentation html파일에서 읽어 생성하고 있습니다. syntax 파일은 mytcl_dev_20090519 버전부터 포함됩니다.

package require htmlparse
proc callback {tag slash param textbehind} {
        if { $tag == "H3" && $slash == "" } { set ::h3 1 }
        if { $tag == "H3" && $slash == "/"} { set ::h3 0 }

        if { $::h3 } {
                if { [string match "NAME=*" $param] } {
                        set ::name  0
                        set ::synopsis 0
                        set ::options 0

                        if { $textbehind == "NAME" } {
                                set ::name 1
                        } elseif { $textbehind == "SYNOPSIS" } {
                                set ::synopsis 1
                        } elseif { [string match "*OPTIONS" $textbehind] } {
                                set ::options 1
                        } elseif { [string match "*DESCRIPTION" $textbehind] } {
                                set ::options 1
                        }
                }
        }
        set text {}
        if { $tag == "B" || $tag == "I" || $tag == "BR" } {
                if { $tag != "" } {
                        if { $slash == "" } {
                                set text ${text}\[${tag}\]
                        } else {
                                set text ${text}\[/${tag}\]
                        }
                }
        }
        if { $textbehind != {} } { set text ${text}${textbehind} }

        if { $::h3 == 0 && $::name } {
                set ::name_str "$::name_str$text"
        }
        if { $::h3 == 0 && $::synopsis } {
                set ::synopsis_str "$::synopsis_str$text"
        }
        if { $::h3 == 0 && $::options } {
                if { [string index $textbehind 0] == "-" } {
                        set option [lindex [split $textbehind ,] 0]
                        if { [llength $option] > 1 } {
                                set option [lindex [split $textbehind] 0]
                        }
                        if { $option != "-" && $option != "--" } {
                                set ::options_str "$::options_str$option "
                        }
                }
        }
}

proc trim_newline {str} {
        if { [string index $str 0] == "\n" } {
                set str [string range $str 1 end]
        }
        if { [string index $str end] == "\n" } {
                set str [string range $str 0 end-1]
        }

        return $str
}

foreach {outname indir} [list "tcl" "TclCmd" "tk" "TKCmd"] {
        set ::name 0
        set ::synopsis 0
        set ::options 0

        set ::h3 0

        set fw [open "${outname}.mytcl" w]
        puts $fw {<?xml version="1.0" encoding="utf-8"?>}
        puts $fw {<MYTCL>}
               
        foreach file [glob -dir $indir * .htm] {
                set cmd [file rootname [file tail $file]]
                if { $cmd == "contents" \
                        || $cmd == "Tcl" \
                        || $cmd == "contents" \
                        || $cmd == "re_syntax" \
                        || $cmd == "tm" \
                        || $cmd == "safe" } continue

                set fin [open $file r]
                set html [read $fin]
                close $fin

                set ::name_str {}
                set ::synopsis_str {}
                set ::options_str {}

                ::htmlparse::parse -cmd callback $html
               
                set ::name_str [trim_newline $::name_str]      
                set ::synopsis_str [trim_newline $::synopsis_str]      
                set ::options_str [lsort -unique $::options_str]

                foreach cmd [split [lindex [split $name_str -] 0] ,] {
                        set cmd [string trim $cmd]
                        puts -nonewline $fw "\t<${cmd} package=\"tk\""
                        puts -nonewline $fw " name=\"$name_str\""
                        puts -nonewline $fw " synopsis=\"$synopsis_str\""
                        puts -nonewline $fw " options=\"$options_str\""
                        puts -nonewline $fw "/>\n"
                }
        }

        puts $fw "</MYTCL>"
        close $fw
}