Tk Source Code

Artifact 01bfd7b39a8f2feacbef262eb015b0066d21007d2c310221c4f737eb0b755088:

Attachment "analyse.tcl" to ticket [718cbc30] added by erikleunissen 2024-12-16 20:52:52.

---

#! /bin/sh
# If executed as a shell script, the next line replaces the shell \
exec tclsh "$0" ${1+"$@"}

# define directories and files
set pwd [pwd]
set tkTestsDir [expr {[info exists env(TK_TESTS_DIR)]?$env(TK_TESTS_DIR):[file normalize ./tk/tests]}]
set xrefFile [file normalize [file join $pwd xref.out]]
set procInfoFile [file normalize [file join $pwd procinfo.txt]]

cd [file join $tkTestsDir ttk]
set ttkFiles [glob *]
cd $pwd

# handle arguments
set validTargets [list xref procinfo]
set usage "Usage: $argv0 ([join $validTargets |])"
if {[llength $argv] != 1} {
	puts $usage
	exit 1
}
set target [lindex $argv 0]

set visualTestTclFiles [list arc.tcl bevel.tcl butGeom.tcl butGeom2.tcl canvPsArc.tcl \
		canvPsBmap.tcl canvPsGrph.tcl canvPsImg.tcl cmap.tcl]

switch -- $target {
	xref {
		# generate cross reference info using the tclchecker program in TclDevKit
		puts -nonewline "Generating tk tests xref info ... "; flush stdout
		cd $tkTestsDir
		catch {exec tclchecker -xref {*}[glob *] {*}[glob ttk/*]} txt

		# delete lines from variables section onwards
		set index [string first "\nvariable" $txt]
		set txt [string range $txt 0 $index]

		# delete lines from package section onwards up to commands section
		set index1 [string first "\npackage" $txt]
		set index2 [string first "command" $txt]
		set newTxt [string range $txt 0 $index1]
		append newTxt [string range $txt $index2 end]
		set txt $newTxt

		# replace file hashes with file names
		foreach {unused hash path} [regexp -all -inline {file ([0-9A-F]{32}) \{\s+path\s+(\S+)\n} $txt] {
			set fileName [file tail $path]
			lappend mapping $hash $fileName
		}
		set txt [string map $mapping $txt]

		# remove files section
		set index [string first "command" $txt]
		set txt [string range $txt $index end]

		# remove info regarding procs renamed to {}
		set index [string first "command" $txt 10]
		set txt [string range $txt $index end]

		# write result
		set diff 99
		if {[file isfile $xrefFile]} {
			set fd [open $xrefFile r]
			set oldTxt [read $fd]
			close $fd
			set diff [string compare $txt $oldTxt]
			file rename -force $xrefFile $xrefFile.sav
		}
		set fd [open $xrefFile w]
		puts -nonewline $fd $txt
		close $fd
		cd $pwd
		puts done
		if {$diff != 99} {
		    if {$diff != 0} {
			    puts "New cross reference differs from the old one"
		    } else {
			    puts "New cross reference is identical to the old one"
		    }
		}
		flush stdout
	}
	procinfo {
		# retrieve cross reference info
		if {! [info exists txt]} {
			set fd [open $xrefFile r]
			set txt [read $fd]
			puts "Retrieved xref info from $xrefFile"; flush stdout
		}

		puts -nonewline "Collecting proc definitions ... "; flush stdout
		array set filesByProc {}
		set newDefinition 0
		foreach line [split $txt \n] {
			if {[regexp -- {command ([^ ]+)} $line -- proc]} {
				continue
			}
			if {[string match "*type       proc*" $line]} {
				set newDefinition 1
				continue
			}
			if {$newDefinition && [regexp -- {loc\s+ \{([^ ]+) (\d+) \{(\d+) (\d+)\}} $line -- file lineNr startIndex strLength]} {
				if {! [info exists filesByProc($proc)] || ($file ni $filesByProc($proc))} {
					lappend filesByProc($proc) $file
				}
				# store the proc's locations
				lappend locations($proc) [list $file $lineNr $startIndex $strLength]
				set newDefinition 0
			}
		}

		# distinguish categories of utility procs
		foreach proc [lsort [array names filesByProc]] {
			if {[lindex $filesByProc($proc) 0] in $visualTestTclFiles} {
				lappend procs(D) $proc
				unset locations($proc)
			} elseif {[lindex $filesByProc($proc) 0] eq "constraints.tcl"} {
				lappend procs(A) $proc
			} elseif {[llength $filesByProc($proc)] > 1} {
				lappend procs(B) $proc
			} else {
				lappend procs(C) $proc
			}
		}

		# write categorized output
		if {[file isfile $procInfoFile]} {
			file rename -force $procInfoFile $procInfoFile.sav
		}
		set fd [open $procInfoFile w]
		puts $fd "# Line format: procName|location|location|..."
		puts $fd "# Location format: fileName lineNr startIndex length\n"
		set header(A) "A. UTILITY PROCS, COLLECTED IN CONSTRAINTS.TCL"
		set header(B) "B. UTILITY PROCS, DEFINED IN MULTIPLE TEST FILES"
		set header(C) "C. UTILITY PROCS DEFINED IN A SINGLE TEST FILE"
		set header(D) "D. VISUAL TEST UTILITY PROCS"
		foreach category {A B C D} {
			if {[incr i] > 1} {
				puts $fd ""
			}
			puts $fd $header($category)
			puts $fd [string repeat = [string length $header($category)]]
			foreach proc $procs($category) {
				if {$category ne "D"} {
					puts $fd "$proc|[join [lsort -index 0 $locations($proc)] |]|"
				} else {
					puts $fd "$proc: $filesByProc($proc)"
				}
			}
		}
		puts "done"
	}
	default {
		puts "invalid target argument \"$target\""
	}
	close $debug_fd
}

# EOF