# Commenter - a utility to parse tcl source files and associate out-line
# comments with procs.
#
package require fileutil
package provide Commenter 1.0
namespace eval Commenter {
# gather leading comment block
proc leadin {text} {
set leadin {}
set lnum 0
foreach line $text {
set line [string trim $line " \t"]
incr lnum
if {[string match \#* $line]} {
lappend leadin $line
} else {
return [list $leadin [lrange $text $lnum end]]
}
}
return [list $leadin {}]
}
# parse a tcl source into a dict containing:
# provides - the package provided by this source
# requires - the packages required by this source
# contexts - the contexts provided by this source (namespace, global, snit)
# entities - the procs, vars, options and methods provided by this source
proc parse {text} {
set text [split $text \n]
# leadin is a comment block terminated by a non-comment
lassign [leadin $text] leadin text
set lnum [llength $leadin]
#puts stderr "$lnum line leadin"
set comment {} ;# free-standing comment block
set current "" ;# current context
array set context [list "" [list name "" type global comment $leadin]] ;# context of declaration
set requires {} ;# packages required
set provides "" ;# package provided
set accum "" ;# we're not in proc scope
foreach line $text {
set line [string trim $line " \t"]
incr lnum
if {$accum ne ""} {
# we're in proc context
append accum \n $line
#puts stderr $accum
if {![info complete $accum]} {
continue
} else {
set accum "" ;# we're out of proc context
}
}
switch -glob -- $line {
\#* {
# accumulate comments en bloc
lappend comment $line
}
package* {
# provide
# require
regsub {[ \t]+} $line " " line
set line [split $line]
switch -- [lindex $line 1] {
provide {
set provides [lindex $line 2]
#puts stderr "provides $provides"
}
require {
if {[string match -* [lindex $line 2]]} {
lappend requires [lindex $line 3]
} else {
lappend requires [lindex $line 2]
}
#puts stderr "requires $requires"
}
}
set comment {}
}
namespace* {
# eval
regsub {[ \t]+} $line " " line
set line [split $line]
if {[lindex $line 1] eq "eval"} {
set name [lindex $line 2]
set context($name) [list name $name comment $comment type namespace]
set current $name
set comment {}
}
#puts stderr "namespace $name"
}
snit::type* {
regsub {[ \t]+} $line " " line
set line [split $line]
set name [lindex $line 1]
set context($name) [list name $name comment $comment type snit]
#puts stderr "snit $name"
}
variable* -
option* -
method* -
proc* {
regsub {[ \t]+} $line " " line
set accum $line ;# enter proc context
set line [split $line]
set name [lindex $line 1]
if {[lindex $line 0] in {variable option}} {
set trailing [lindex [split [join $line] \#] 1]
lappend comment $trailing
}
set entities($name) [list name $name comment $comment line $lnum context $current type [lindex $line 0]]
set comment {}
#puts stderr "[lindex $line 0] $name"
}
}
}
return [list contexts [array get context] entities [array get entities] provides $provides requires $requires]
}
# same as parse, but operates on the contents of a file
proc parseF {path} {
return [parse [::fileutil::cat $path]]
}
namespace export -clear *
namespace ensemble create -subcommands {}
}
if {[info exists argv0] && ($argv0 eq [info script])} {
set path [info script]
puts stderr [Commenter parseF $path]
}