#JMN 2005 - Public Domain
#
#REVIEW: This package may not robustly output xml. More testing & development required.
#

#NOTE: the 'x' attribute on the 'info' tag may have its value truncated. 
#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute.
#Use the fact that the corresponding 'info' tag directly follows its 'require' tag.


#changes
#2021-09-17
# - added variable ::packagetrace::showpresent with default 1
#   setting this to 0 will hide the <present/> tags which sometimes make the output too verbose.
# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr.

namespace eval packagetrace::class {
    if {[info commands [namespace current]::tracer] eq ""} {
        oo::class create tracer  {
            method get {} {
            }
            method test {} {
                return tracertest
            }
        }
    }
}


namespace eval packagetrace {
    variable tracerlist [list]
    variable chan stderr
    variable showpresent 1
    variable output ""


    proc help {} {
        return {
            REVIEW - documentation inaccurate
Enable  package tracing using 'package require packagetrace'
Disable package tracing using 'package forget packagetrace; package require packagetrace'
    (This 2nd 'package require packagetrace' will raise an error. This is deliberate.)
use packagetrace::channel <chan> to desired output channel or none. (default stderr)

set packagetrace::showpresent 0 to skip <present/> output
}
    }

    # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
    # Maintenance - tm_version... functions - primary source is punk::lib module
    #             - these should be synced with code from latest punk::lib
    # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
    proc tm_version_isvalid {versionpart} {
        #Needs to be suitable for use with Tcl's 'package vcompare'
        if {![catch [list package vcompare $versionpart $versionpart]]} {
            return 1
        } else {
            return 0
        }
    }
    proc tm_version_major {version} {
        if {![tm_version_isvalid $version]} {
            error "Invalid version '$version' is not a proper Tcl module version number"
        }
        set firstpart [lindex [split $version .] 0]
        #check for a/b in first segment
        if {[string is integer -strict $firstpart]} {
            return $firstpart
        }
        if {[string first a $firstpart] > 0} {
            return [lindex [split $firstpart a] 0]
        }
        if {[string first b $firstpart] > 0} {
            return [lindex [split $firstpart b] 0]
        }
        error "tm_version_major unable to determine major version from version number '$version'"
    }
    proc tm_version_canonical {ver} {
        #accepts a single valid version only - not a bounded or unbounded spec
        if {![tm_version_isvalid $ver]} {
            error "tm_version_canonical version '$ver' is not valid for a package version"
        }
        set parts [split $ver .]
        set newparts [list]
        foreach o $parts {
            set trimmed [string trimleft $o 0]
            set firstnonzero [string index $trimmed 0]
            switch -exact -- $firstnonzero {
                "" {
                    lappend newparts 0
                }
                a - b {
                    #e.g 000bnnnn -> bnnnnn
                    set tailtrimmed [string trimleft [string range $trimmed 1 end] 0]
                    if {$tailtrimmed eq ""} {
                        set tailtrimmed 0
                    }
                    lappend newparts 0$firstnonzero$tailtrimmed
                }
                default {
                    #digit
                    if {[string is integer -strict $trimmed]} {
                        #e.g 0100 -> 100
                        lappend newparts $trimmed
                    } else {
                        #e.g 0100b003 -> 100b003 (still need to process tail)
                        if {[set apos [string first a $trimmed]] > 0} {
                            set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
                            set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits
                            set rhs [string trimleft $rhs 0]
                            if {$rhs eq ""} {
                                set rhs 0
                            }
                            lappend newparts ${lhs}a${rhs}
                        } elseif {[set bpos [string first b $trimmed]] > 0} {
                            set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
                            set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits
                            set rhs [string trimleft $rhs 0]
                            if {$rhs eq ""} {
                                set rhs 0
                            }
                            lappend newparts ${lhs}b${rhs}
                        } else {
                            #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b
                            error "tm_version_canonical error - trimfail - unexpected"
                        }
                    }
                }
            }
        }
        return [join $newparts .]
    } 
    proc tm_version_required_canonical {versionspec} {
        #also trim leading zero from any dottedpart?
        #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
        #e.g 1.01 is equivalent to 1.1 and 01.001
        #also 1b3 == 1b0003

        if {[string trim $versionspec] eq ""} {return ""}  ;#unspecified = any version
        set errmsg "tm_version_required_canonical - invalid version specification" 
        if {[string first - $versionspec] < 0} {
            #no dash  
            #looks like a minbounded version (ie a single version with no dash)  convert to min-max form 
            set from $versionspec
            if {![tm_version_isvalid $from]} {
                error "$errmsg '$versionpec'"
            }
            if {![catch {tm_version_major $from} majorv]} {
                set from [tm_version_canonical $from]
                return "${from}-[expr {$majorv +1}]"
            } else {
                error "$errmsg '$versionspec'"
            }
        } else {
            # min- or min-max 
            #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
            set parts [split $versionspec -] ;#we expect only 2 parts
            lassign $parts from to
            if {![tm_version_isvalid $from]} {
                error "$errmsg '$versionspec'"
            }
            set from [tm_version_canonical $from]
            if {[llength $parts] == 2} {
                if {$to ne ""} {
                    if {![tm_version_isvalid $to]} {
                        error "$errmsg '$versionspec'"
                    }
                    set to [tm_version_canonical $to]
                    return $from-$to
                } else {
                    return $from-
                }
            } else {
                error "$errmsg '$versionspec'"
            }
            error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
        }
    }
    # end tm_version... functions
    # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==

    #convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird.
    #REVIEW
    proc unload {} {
        package forget packagetrace
        if {[catch {package require packagetrace}]} {
            return 1 ;#yes - we get an error if we unloaded successfully 
        } else {
            error "packagetrace was not unloaded"
        }
    }
    proc emit {str} {
        variable chan
        variable output 
        append output $str
        if {$chan ne "none"} {
            puts -nonewline $chan $str
        }
        return
    }
    proc get {{as raw}} {
        variable output
        switch -- [string tolower $as] {
            asxml {
                if {[package provide tdom] eq ""} {
                    set previous_output $output
                    package require tdom
                    set output $previous_output
                }
                set d [dom parse $output]
                return [$d asXML]
            }
            aslist {
                if {[package provide tdom] eq ""} {
                    set previous_output $output
                    package require tdom
                    set output $previous_output
                }
                set d [dom parse $output]
                return [$d asList]
            }
            default {
                return $output
            }
        }
    }
    proc channel {{ch ""}} {
        variable chan
        switch -exact -- $ch {
            "" {
                return $chan
            }
            none {
                set chan none
                return none
            }
            stderr - stdout {
                #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work
                set chan $ch
                return $ch
            }
            default {
                if {$ch in [chan names]} {
                    set chan $ch
                    return $ch
                } else {
                    error "chan '$ch' not in \[chan names\]: [chan names]"
                }
            }
        }
    }
    proc init {} {
        uplevel 1 {
            set ::packagetrace::level -1
            if {![llength [info commands tcl_findLibrary]]} {
                tcl::namespace::eval :: $::auto_index(tcl_findLibrary)
            }
            package require commandstack
            

            set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary
            set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] {
                set marg [string repeat {  } $::packagetrace::level]
                packagetrace::emit "${marg}<extra> tcl_findLibrary $basename $version $patch $initScript $enVarName $varName </extra>\n"
                uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName]
            }]
            if {[dict get $stackrecord implementation] ne ""} {
                set old_tcl_findLibrary [dict get $stackrecord implementation]
                puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override"
            } else {
                puts stderr "packagetrace::init failed to rename $targetcommand"
            }
            

        
            set package_command [namespace which package] 
            set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} {
                set tracerlist $::packagetrace::tracerlist
                set tracer [lindex $tracerlist end]
                if {$tracer eq ""} {
                    
                }
                set ch $::packagetrace::chan
                set next $COMMANDSTACKNEXT 
                if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} {
                    puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next"
                }
                
                #cache $ch instead of using upvar, 
                #because namespace may be deleted during call.

                #!todo - optionally silence Tcl & Tk requires to reduce output?
                #if {[lindex $args 0] eq "Tcl"} {
                #	return [$next $subcommand {*}$args]
                #}
                switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] {
                    require {
                        #columns
                        set c1 [string repeat { } 30] ;#tree col
                        set c1a "      "
                        set c2 [string repeat { } 20] ;#package name col
                        set c2a "    "			;# close require/present tags
                        set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation
                        set c4 [string repeat { } 12] ;#timing col  5 chars of punct leaving remainder for value. 
                        set c5 [string repeat { } 10] ;#module col
                        set c5a [string repeat { } 3] ;#close result tag col

                        #we assume 'package require' API sticks to solo option flags like -exact and is relatively stable. 
                        set argidx 0
                        set is_exact 0
                        foreach a $args {
                            if {[string range $a 0 0] ne "-"} {
                                #assume 1st non-dashed argument is package name
                                set pkg $a
                                set v_requirements [lrange $args $argidx+1 end]
                                #normalize
                                if {$is_exact} {
                                    set req [lindex $v_requirements 0] ;#only one is allowed for -exact
                                    set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact
                                } else {
                                    set reqs [list]
                                    foreach req $v_requirements {
                                        lappend reqs [::packagetrace::tm_version_required_canonical $v_requirement] ;#empty remains empty, v -> v-<majorv+1>, leading zeros stripped from all segments. 
                                    }
                                    set v_requirements $reqs ;#each normalised
                                }
                                set pkg_ [lrange $args $argidx end]  ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9"
                                break
                            } else {
                                if {$a eq "-exact"} {
                                    set is_exact 1
                                }
                            }
                            incr argidx
                        }	
                        
                        
                        incr ::packagetrace::level
                        if {$::packagetrace::level == 0} {
                            set packagetrace::output ""
                        }


                        set marg [string repeat {  } $::packagetrace::level]
                        set margnext [string repeat {  } [expr {$::packagetrace::level + 1}]]

                        if {![catch {set ver [$next present {*}$args]}]} {
                            if {$::packagetrace::showpresent} {
                                #already loaded..
                                set f1 [packagetrace::overtype::left $c1 "${marg}<present"]
                                set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
                                set f2a $c2a 
                                set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]
                                set f4 $c4 
                                set f5 $c5 
                                set f5a "/> "
                                #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
                                packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
                            }
                        } else {
                            set f1 [packagetrace::overtype::left $c1 "${marg}<require"]
                            set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
                            set f2a $c2a 
                            set f3  $c3 
                            set f4  $c4 
                            set f5  $c5 
                            set f5a " >  "
                            #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
                            packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
                    
                            set errMsg ""
                            #set t0 [clock clicks -milliseconds]
                            set t0 [clock microseconds]
                            
                            if {[catch {set ver [$next require {*}$args]} errMsg]} {
                                set ver ""	
                                #
                                #NOTE error must be raised at some point - see below
                            }
                            #set t [expr {[clock clicks -millisec]-$t0}]
                            set t [expr {([clock microseconds]-$t0)/1000.0}]
                            

                            
                            
                            #jmn
                            set f1 [packagetrace::overtype::left $c1 "${margnext}<info "]
                            #set f1a "<info "
                            set f1a ""
                            
                            set f2 [packagetrace::overtype::left -ellipsis 1  [string range $c2 0 end-1] "x= \"$args"]
                            if {[string length [string trimright $f2]] <= [expr [string length $c2]-1]} {
                                #right-trimmed value shorter than field.. therefore we need to close attribute
                                set f2 [packagetrace::overtype::left $c2 [string trimright $f2]\"]
                            }

                            #we use the attributename x because this is not necessarily the same as p! may be truncated.
                            
                            set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]

                            #truncate time to c4 width - possibly losing some precision. If truncated - add closing double quote.
                            set f4 [packagetrace::overtype::left -overflow 1 $c4 "t= \"[lrange $t 0 1]\""]
                            if {[string length [string trimright $f4]] > [expr {[string length $c4]}]} {
                                set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\""
                            }

                            if {[string length $ver]} {
                                set num ""
                                foreach c [split $ver ""] {
                                    if {[string is digit $c] || $c eq "."} {
                                        append num $c
                                    } else {
                                        break
                                    }
                                }
                                set ver $num

                                #review - scr not guaranteed to be valid tcl list - should parse properly? 
                                set scr [$next ifneeded $pkg $ver]
                                if {[string range $scr end-2 end] ne ".tm"} {
                                    set f5 $c5
                                } else {
                                    #!todo - optionally output module path instead of boolean?
                                    #set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"]
                                    set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"]
                                    if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} {
                                        set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"]
                                    }
                                }
                            } else {
                                set f5 $c5
                            }

                            set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of <info
                            #puts -nonewline $ch "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
                            packagetrace::emit "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
                                
                                
                            set f1 [packagetrace::overtype::left $c1 "${marg}</require>"]
                            set f1a ""
                            set f2 ""
                            set c2a ""
                            set f3 ""
                            set f4 ""
                            set f5 ""
                            set f5a ""
                            #puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
                            packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
                                

                            if {![string length $ver]} {
                                if {[lindex $args 0] eq "packagetrace"} {
                                    #REVIEW - what is going on here?
                                    namespace delete ::packagetrace::overtype
                                }

                                #we must raise an error if original 'package require' would have
                                incr ::packagetrace::level -1
                                error $errMsg
                            }

                        }
                        incr ::packagetrace::level -1
                        return $ver
                    }
                    vcompare - vsatisifies - provide - ifneeded {
                        set result [$next $subcommand {*}$args]
                        #puts -nonewline $ch "     -- package $subcommand $args\n"
                        return $result
                    }
                    default {
                        set result [$next $subcommand {*}$args]
                        #puts $ch "*** here $subcommand $args"
                        return $result
                    }
                }
            
            }]
            if {[set stored_target [dict get $stackrecord implementation]] ne ""} {
                puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override"
                set f1 [string repeat { } 30]
                #set f1a "      " 
                set f1a ""
                set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"]
                set f2a "   "
                set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"]
                set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"]
                set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"]

                #puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n"
                #packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n"
                puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n"
                unset f1 f1a f2 f2a f3 f4 f5
            } else {
                puts stderr "packagetrace::init failed to rename $package_command"
            }
        }
    }
}



#The preferred source of the ::overtype::<direction> functions is the 'overtype' package
# - pasted here because packagetrace should have no extra dependencies.
# - overtype package has better support for ansi and supports wide chars
namespace eval packagetrace::overtype {set version INLINE}

namespace eval packagetrace::overtype {
    proc left {args} {
        # @c overtype starting at left (overstrike) 
        # @c can/should we use something like this?: 'format "%-*s" $len $overtext 

        if {[llength $args] < 2} {
            error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
        }
        foreach {undertext overtext} [lrange $args end-1 end] break

        set opt(-ellipsis)		0
        set opt(-ellipsistext)	{...}
        set opt(-overflow)	0
        array set opt [lrange $args 0 end-2]


        set len [string length $undertext]
        set overlen [string length $overtext]
        set diff [expr {$overlen - $len}]
        if {$diff > 0} {
            if {$opt(-overflow)} {
                return $overtext
            } else {
                if {$opt(-ellipsis)} {
                    return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)]
                } else {
                    return [string range $overtext 0 [expr {$len -1}]]
                }
            }
        } else {
            
            return "$overtext[string range $undertext $overlen end]"
        }
    }

    proc centre {args} {
        if {[llength $args] < 2} {
            error {usage: ?-bias [left|right]?  ?-overflow [1|0]? undertext overtext}
        }
        foreach {undertext overtext} [lrange $args end-1 end] break

        set opt(-bias)		left
        set opt(-overflow)	0
        array set opt [lrange $args 0 end-2]
        

        set olen [string length $overtext]
        set ulen [string length $undertext]
            set diff [expr {$ulen - $olen}]
        if {$diff > 0} {
            set half [expr {round(int($diff / 2))}]
            if {[string match right $opt(-bias)]} {
                if {[expr {2 * $half}] < $diff} {
                    incr half
                }
            }
            
            set rhs [expr {$diff - $half - 1}]
            set lhs [expr {$half - 1}]

            set a [string range $undertext 0 $lhs]
            set b $overtext
            set c [string range $undertext end-$rhs end]
            return $a$b$c
        } else {
            if {$diff < 0} {
                if {$opt(-overflow)} {
                    return $overtext
                } else {
                    return [string range $overtext 0 [expr {$ulen - 1}]]
                }
            } else {
                return $overtext
            }
        }
    }

    proc right {args} {
        if {[llength $args] < 2} {
            error {usage: ?-overflow [1|0]? undertext overtext}
        }
        lassign [lrange $args end-1 end] undertext overtext
        
        set opt(-overflow)	0
        array set opt [lrange $args 0 end-2]

        set olen [string length $overtext]
        set ulen [string length $undertext]

        if {$opt(-overflow)} {
            return [string range $undertext 0 end-$olen]$overtext
        } else {
            if {$olen > $ulen} {	
                set diff [expr {$olen - $ulen}]
                return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff]
            } else {
                return [string range $undertext 0 end-$olen]$overtext
            }
        }
    }

}





proc packagetrace::deinit {} {
    packagetrace::disable
    #namespace delete packagetrace
    #package forget packagetrace
}
proc packagetrace::disable {} {
    ::commandstack::remove_rename {::tcl_findLibrary packagetrace}
    ::commandstack::remove_rename {::package packagetrace}
}
proc packagetrace::enable {} {
    #init doesn't clear state - so this is effectively an alias
    tailcall packagetrace::init
}

#clear state  - reset to defaults 
proc packagetrace::clear {} {
    variable chan 
    set chan stderr
    variable showpresent 
    set showpresent 1
}

package provide packagetrace [namespace eval packagetrace {
    set version 0.8
}]