From e2e5bcc4f2994de4d93bed0ac5eb5081c5c62731 Mon Sep 17 00:00:00 2001 From: Nicky Johnstone Date: Tue, 18 Apr 2023 23:16:24 +0100 Subject: [PATCH 1/3] Added proc linter_tcl_command_words to get words from a command. Updated procs that parse commands to use words from the command --- tcl/linter.tcl | 95 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 77 insertions(+), 18 deletions(-) diff --git a/tcl/linter.tcl b/tcl/linter.tcl index 2701f68..db4afa5 100644 --- a/tcl/linter.tcl +++ b/tcl/linter.tcl @@ -224,6 +224,44 @@ 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 " ] + + while {[regexp {([^\f\n\r\t\v ]*)([\f\n\r\t\v ]+)(.*)} $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 +313,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 +378,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]] } } } From e1899b500e202972395f66ec7f9851230c18f433 Mon Sep 17 00:00:00 2001 From: Nicky Johnstone Date: Wed, 19 Apr 2023 12:45:02 +0100 Subject: [PATCH 2/3] Added tests for linter_tcl_command_words --- tests/tcl/linter.test | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) 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 \ From 33abcd46e3438999264bd2f42afc96691fb4a62e Mon Sep 17 00:00:00 2001 From: Nicky Johnstone Date: Wed, 19 Apr 2023 12:50:58 +0100 Subject: [PATCH 3/3] Reduce line lengths in linter_tcl_command_words --- tcl/linter.tcl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tcl/linter.tcl b/tcl/linter.tcl index db4afa5..db7127d 100644 --- a/tcl/linter.tcl +++ b/tcl/linter.tcl @@ -237,8 +237,9 @@ proc linter_tcl_command_words {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 {([^\f\n\r\t\v ]*)([\f\n\r\t\v ]+)(.*)} $command full first delim last]} { + while {[regexp $pattern $command full first delim last]} { append logical $first if {[info complete $logical\n]} {