test.tcl

来自「多发法定阿凡阿道夫埃罚罚 埃担罚大多发叮罚罚多发」· TCL 代码 · 共 80 行

proc ShowBlockProp {id} {
    global fp
    puts $fp "  <---- properties ----"
    puts $fp "  npiType=[npi_get $id -npiType]"
    puts $fp "  npiFile=[npi_get $id -npiFile]"
    puts $fp "  npiLineNo=[npi_get $id -npiLineNo]"
    set type [npi_get $id -npiType]
    if {$type == "npiNamedBegin"||$type == "npiNamedFork"} {
        puts $fp "  npiName = [npi_get $id -npiName]"
    }
    puts $fp "  >---- properties ----"
}

proc foreach_IterateHandle {iter_handle iter_type} {
    global fp
    set Object_Handle [npi_scan $iter_handle]
    puts $fp "    <---$iter_type--->"
    while {$Object_Handle != "NULL"} {
        puts $fp "    <---begin npi_scan \$iter_handle--->"
        puts $fp "    npiType = [npi_get $Object_Handle -npiType]"
        puts $fp "    npiLineNo = [npi_get $Object_Handle -npiLineNo]"
        puts $fp "    <---end of npi_scan \$iter_handle--->"
        set Object_Handle  [npi_scan $iter_handle]
    }
    puts $fp "    <---end of $iter_type--->"
}

proc ShowHandleProp {Handle type} {
    global fp
    puts $fp "    <---$type --->"
    if {$Handle != "NULL"} {
        puts $fp "    npiType = [npi_get $Handle -npiType]"
        puts $fp "    npiLineNo = [npi_get $Handle -npiLineNo]"
    }
    puts $fp "    <---end of $type --->"
}

proc ShowBlockRelationship {id} {
    global fp
    puts $fp "  <---relationship --->"
    set stmt_iter [npi_iterate $id -npiType npiStmt]
    foreach_IterateHandle $stmt_iter "npi_iterate \$id -npiType npiStmt"
    puts $fp "  <---end of relationship --->"
}

proc ShowBlockPropAndRelationship {var} {
    global fp
    puts $fp "<---begin showing block information--->"
    ShowBlockProp $var
    ShowBlockRelationship $var
    puts $fp "<---end of showing block information--->"
}
proc ShowNamedBeginPropAndRelationship {} {
    global g_NamedBegin
    ShowBlockPropAndRelationship $g_NamedBegin
}
proc ShowNamedForkPropAndRelationship {} {
    global g_NamedFork
    ShowBlockPropAndRelationship $g_NamedFork
}
proc ShowBeginPropAndRelationship {} {
    global g_Begin
    ShowBlockPropAndRelationship $g_Begin
}
proc ShowForkPropAndRelationship {} {
    global g_Fork
    ShowBlockPropAndRelationship $g_Fork
}
set log_file [file join [file dirname [info script]] [file tail [info script]].out]
set fp [open $log_file w]
fconfigure $fp -buffering none

npi_register_cb -npiModuleBased NamedBegin ShowNamedBeginPropAndRelationship
npi_register_cb -npiModuleBased NamedFork ShowNamedForkPropAndRelationship
npi_register_cb -npiModuleBased Begin ShowBeginPropAndRelationship
npi_register_cb -npiModuleBased Fork ShowForkPropAndRelationship
npi_traverse_model -npiModuleBased

close $fp