diff --git a/tcl/linter.tcl b/tcl/linter.tcl index 2701f68..db7127d 100644 --- a/tcl/linter.tcl +++ b/tcl/linter.tcl @@ -224,6 +224,45 @@ proc linter_tcl_commands {script} { return $commands } +proc linter_tcl_command_words {command} { + #| Get the Tcl words that make up the command. + #| + #| Original author: PYK. + #| https://wiki.tcl-lang.org/page/cmdSplit + + if {![info complete $command]} { + error [list {not a complete command} $command] + } + + set words {} + set logical {} + set command [string trimleft $command[set command {}] "\f\n\r\t\v " ] + set pattern {([^\f\n\r\t\v ]*)([\f\n\r\t\v ]+)(.*)} + + while {[regexp $pattern $command full first delim last]} { + append logical $first + + if {[info complete $logical\n]} { + lappend words $logical + set logical {} + } else { + append logical $delim + } + + set command $last[set last {}] + } + + if {$command ne {}} { + append logical $command + } + + if {$logical ne {}} { + lappend words $logical + } + + return $words +} + proc linter_report_procs_over_length { files max_proc_length @@ -275,21 +314,33 @@ proc linter_proc_lengths {string} { set proc_lengths [dict create] foreach command $commands { - switch -regexp $command { - {^proc} { - set proc_name [lindex $command 1] - set proc_body [lindex $command 3] - set body_length [llength [split [string trim $proc_body] "\n"]] - set query_count [llength [linter_sql_query_indices $proc_body]] - set query_length [linter_sql_queries_length $proc_body] - set body_length [expr {$body_length - $query_length + $query_count}] - - dict set proc_lengths $proc_name $body_length - } - {^namespace eval} { + set words [linter_tcl_command_words $command] + set command_name [lindex $words 0] + + if { $command_name eq "proc" } { + lassign $words \ + command_name \ + proc_name \ + proc_args \ + proc_body + set proc_body [join $proc_body] + set body_length [llength [split [string trim $proc_body] "\n"]] + set query_count [llength [linter_sql_query_indices $proc_body]] + set query_length [linter_sql_queries_length $proc_body] + set body_length [expr {$body_length - $query_length + $query_count}] + + dict set proc_lengths $proc_name $body_length + } elseif { $command_name eq "namespace" } { + lassign $words \ + command_name \ + subcommand \ + name \ + body + + if { $subcommand eq "eval" } { set proc_lengths [dict merge \ $proc_lengths \ - [linter_proc_lengths [lindex $command 3]]] + [linter_proc_lengths [join $body]]] } } } @@ -328,20 +379,29 @@ proc linter_procs_without_proc_comment {string} { set commands [linter_tcl_commands $string] foreach command $commands { - set command_name [lindex $command 0] + set words [linter_tcl_command_words $command] + set command_name [lindex $words 0] if { $command_name eq "proc" } { - lassign $command command_name proc_name args body - set body_lines [split [string trim $body] "\n"] + lassign $words \ + command_name \ + proc_name \ + args \ + body + set body_lines [split [string trim [join $body]] "\n"] if { [lsearch -regexp $body_lines {^#\|}] == -1 } { lappend procs $proc_name } } elseif { $command_name eq "namespace" } { - lassign $command command_name subcommand namespace body + lassign $words \ + command_name \ + subcommand \ + namespace \ + body if { $subcommand eq "eval" } { - lappend procs {*}[linter_procs_without_proc_comment $body] + lappend procs {*}[linter_procs_without_proc_comment [join $body]] } } } diff --git a/tests/tcl/linter.test b/tests/tcl/linter.test index f338bd3..f1ececa 100644 --- a/tests/tcl/linter.test +++ b/tests/tcl/linter.test @@ -152,6 +152,44 @@ test linter_tcl_commands-1.0 \ } \ -result 1 +test linter_tcl_command_words-1.0 \ + {Get the Tcl words from a simple Tcl command.} \ + -setup $setup \ + -body { + set script {set foo "bar"} + set commands [linter_tcl_commands $script] + set words [linter_tcl_command_words [lindex $commands 0]] + + if { $words ne {set foo {"bar"}} } { + error "Expected {set foo \{\"bar\"\}} but got $words" + } + + return 1 + } \ + -result 1 + +test linter_tcl_command_words-2.0 \ + {Get the Tcl words from a proc.} \ + -setup $setup \ + -body { + set script { + proc test_1 {args} { + # This is a test proc. + return 1 + } + } + + set commands [linter_tcl_commands $script] + set words [linter_tcl_command_words [lindex $commands 0]] + + if { [llength $words] != 4 } { + error "Expected 4 words but got [llength $words]" + } + + return 1 + } \ + -result 1 + test linter_sql_query_indices-1.0 \ {Get the indices of queries in a string.} \ -setup $setup \