#JMN 2021 - Public Domain
#cooperative command renaming 
#
# REVIEW 2024 - code was originally for specific use in packageTrace
#  - code should be reviewed for more generic utility. 
#  - API is obscure and undocumented. 
#  - unclear if intention was only for builtins 
#  - consider use of newer 'info cmdtype' - (but need also support for safe interps)
#  - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
#  - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename
#changes:
#2024   
#    - mungecommand to support namespaced commands
#    - fix mistake - hardcoded _originalcommand_package  -> _originalcommand_<mungedcommand> 
#2021-09-18 
#   - initial version
#   - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
#   - They need to be able to load and unload in any order.
#

#strive for no other package dependencies here.


namespace eval commandstack {
    variable all_stacks
    variable debug
    set debug 0
    variable known_renamers [list ::packagetrace ::packageSuppress]
    if {![info exists all_stacks]} {
        #don't wipe it 
        set all_stacks [dict create]
    }
}

namespace eval commandstack::util {
    #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
    #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
    #A magic comment was chosen as the identifying method. 
    #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.

    #return unspecified if the command is a proc with a body but no magic comment ID
    #return unknown if the command doesn't have a proc body to analyze
    #otherwise return the package name identified in the magic comment
    proc get_IMPLEMENTOR {command} {
        #assert - command has already been resolved to a namespace ie fully qualified
        if {[llength [info procs $command]]} {
            #look for *IMPLEMENTOR_*!
            set prefix IMPLEMENTOR_ 
            set suffix "!"
            set body [uplevel 1 [list info body $command]]
            if {[string match "*$prefix*$suffix*" $body]} {
                 set prefixposn [string first "$prefix" $body] 
                 set pkgposn [expr {$prefixposn + [string length $prefix]}]
                 #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
                 set suffixposn [string first $suffix $body $pkgposn]
                 return [string range $body $pkgposn $suffixposn-1]
            } else {
                return unspecified
            }
        } else {
            if {[info commands tcl::info::cmdtype] ne ""} {
                #tcl9 and maybe some tcl 8.7s ?
                switch -- [tcl::info::cmdtype $command] {
                    native {
                        return builtin
                    }
                    default {
                        return undetermined
                    }
                }
            } else {
                return undetermined 
            }
        }
    }
}
namespace eval commandstack::renamed_commands {}
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place

namespace eval commandstack {
    namespace export {[a-z]*}
    proc help {} {
        return {
        
        }   
    }

    proc debug {{on_off {}}} {
        variable debug
        if {$on_off eq ""} {
            return $debug
        } else {
            if {[string is boolean -strict $debug]} {
                set debug [expr {$on_off && 1}]
                return $debug
            }
        }
    }

    proc get_stack {command} {
        variable all_stacks
        set command [uplevel 1 [list namespace which $command]]
        if {[dict exists $all_stacks $command]} {
            return [dict get $all_stacks $command]
        } else {
            return [list]
        }
    }

    #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
    #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
    #e.g if renaming builtin 'package' - this command is generally called 'a lot'
    proc get_next_command {command renamer tokenid} {
        variable all_stacks
        if {[dict exists $all_stacks $command]} {
            set stack [dict get $all_stacks $command]
            set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
            if {$posn > -1} {
                set record [lindex $stack $posn]
                return [dict get $record implementation]
            } else {
                error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
            }
        } else {
            return $command
        }
    }
    proc basecall {command args} {
        variable all_stacks
        set command [uplevel 1 [list namespace which $command]]
        if {[dict exists $all_stacks $command]} {
            set stack [dict get $all_stacks $command]
            if {[llength $stack]} {
                set rec1 [lindex $stack 0]
                tailcall [dict get $rec1 implementation] {*}$args
            } else {
                tailcall $command {*}$args
            }
        } else {
            tailcall $command {*}$args
        }
    }


    #review.
    #<renamer> defaults to calling namespace - but can be arbitrary string
    proc rename_command {args} {
        #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
        # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
        # 
        if {[lindex $args 0] eq "-renamer"} {
            set renamer [lindex $args 1]
            set arglist [lrange $args 2 end]
        } else {
            set renamer ""
            set arglist $args
        }
        if {[llength $arglist] != 3} {
            error "commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody"
        }
        lassign $arglist command procargs procbody

        set command [uplevel 1 [list namespace which $command]]
        set mungedcommand [string map {:: _ns_} $command]
        set mungedrenamer [string map {:: _ns_} $renamer]
        variable all_stacks
        variable known_renamers 
        variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done.
        if {$renamer eq ""} {
            set renamer [uplevel 1 [list namespace current]]
        }
        if {$renamer ni $known_renamers} {
            lappend known_renamers $renamer
            dict set renamer_command_tokens [list $renamer $command] 0
        }

        #TODO - reduce emissions to stderr - flag for debug? 

        #e.g packageTrace and packageSuppress packages use this convention.
        set nextinfo [uplevel 1 [list\
            apply {{command renamer procbody} {
                #todo - munge dash so we can make names in renamed_commands separable
                # {- _dash_} ?
                set mungedcommand [string map {:: _ns_} $command]
                set mungedrenamer [string map {:: _ns_} $renamer]
                set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
                set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid   ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
                set do_rename 0
                if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
                    #$command is not the standard builtin - something has replaced it, could be ourself.
                    set next_implementor [::commandstack::util::get_IMPLEMENTOR $command]
                    set munged_next_implementor [string map {:: _ns_} $next_implementor]
                    #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it.
                    if {[dict exists $::commandstack::all_stacks $command]} {
                        set comstacks [dict get $::commandstack::all_stacks $command] 
                    } else {
                        set comstacks [list]
                    }
                    set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer')
                    if {[llength $this_renamer_previous_entries]} {
                        if {$next_implementor eq $renamer} {
                            #previous renamer was us. Rather than assume our job is done.. compare the implementations 
                            #don't rename if immediate predecessor is same code.
                            #set topstack [lindex $comstacks end]
                            #set next_impl [dict get $topstack implementation]
                            set current_body [info body $command]
                            lassign [commandstack::lib::split_body $current_body] _ current_code
                            set current_code [string trim $current_code]
                            set new_code     [string trim $procbody]
                            if {$current_code eq $new_code} {
                                puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
                                puts stderr [::commandstack::show_stack $command]
                            } else {
                                puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
                                puts stdout "----------"
                                puts stdout "$current_code"
                                puts stdout "----------"
                                puts stdout "$new_code"
                                puts stdout "----------"
                                set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
                                set do_rename 1
                            }
                        } else {
                            puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
                            puts stderr
                            set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
                            set do_rename 1
                        }
                    } elseif {$next_implementor in $::commandstack::known_renamers} {
                        set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
                        set do_rename 1
                    } elseif {$next_implementor in {builtin}} {
                        #native/builtin could still have been renamed
                        set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
                        set do_rename 1
                    } elseif {$next_implementor in {unspecified undetermined}} {
                        #could be a standard tcl proc, or from application or package
                        set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
                        set do_rename 1
                    } else {
                        puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
                        set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
                        set do_rename 1
                    }
                } else {
                    #_originalcommand_<mungedcommand>
                    #assume builtin/original
                    set next_implementor original
                    #rename $command $next_target
                    set do_rename 1
                }
                #There are of course other ways in which $command may have been renamed - but we can't detect.
                set token [list $command $renamer $tokenid]
                return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename]
            } } $command $renamer $procbody]
        ]

        
        variable debug
        if $debug {
            if {[dict exists $all_stacks $command]} {
                set stack [dict get $all_stacks $command]
                puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]).  Renaming to [dict get $nextinfo next_target]"
            } else {
                #assume this is the original
                puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]"
            }
        }
        
        #token is always first dict entry. (Value needs to be searched with lsearch -index 1 )
        #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) 
        set new_record [dict create\
            token               [dict get $nextinfo token]\
            renamer $renamer\
            next_implementor    [dict get $nextinfo next_implementor]\
            next_getter         [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\
            implementation      [dict get $nextinfo next_target]\
        ]
        if {![dict get $nextinfo do_rename]} {
            #review
            puts stderr "no rename performed"
            return [dict create implementation ""] 
        }
        catch {rename ::commandstack::temp::testproc ""}
        set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] {
            #IMPLEMENTOR_%renamer%!  (mechanism: 'commandstack::rename_command -renamer %renamer% %command% <procargs> <procbody> )
            set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. 
            set COMMANDSTACKNEXT [%next_getter%]
            #<commandstack_separator>#
        }]
        set final_procbody "$nextinit$procbody"
        #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command
        #(e.g due to invalid argument specifiers)
        proc ::commandstack::temp::testproc $procargs $final_procbody 
        uplevel 1 [list rename $command [dict get $nextinfo next_target]]
        uplevel 1 [list rename ::commandstack::temp::testproc $command]
        dict lappend all_stacks $command $new_record


        return $new_record
    }

    #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
    #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
    #todo - removal of all entries pertaining to a particular renamer
    #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? 

    #remove by token, or by commandname if called from same context as original rename_command
    #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. 
    #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
    #similarly a nonexistant token or renamer will not remove anything and will just return the current stack
    proc remove_rename {token_or_command} {
        if {[llength $token_or_command] == 3} {
            #is token
            lassign $token_or_command command renamer tokenid
        } elseif {[llength $token_or_command] == 2} {
            #command and renamer only supplied
            lassign $token_or_command command renamer
            set tokenid ""
        } elseif {[llength $token_or_command] == 1} {
            #is command name only
            set command $token_or_command
            set renamer [uplevel 1 [list namespace current]]
            set tokenid ""
        }
        set command [uplevel 1 [list namespace which $command]]
        variable all_stacks
        variable known_renamers 
        if {$renamer ni $known_renamers} {
            error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}"
        }
        if {[dict exists $all_stacks $command]} {
            set stack [dict get $all_stacks $command]
            if {$tokenid ne ""} {
                #token_or_command is a token as returned within the rename_command result dictionary
                #search first dict value
                set doomed_posn [lsearch -index 1 $stack $token_or_command]
            } else {
                #search second dict value
                set matches [lsearch -all -index 3 $stack $renamer]
                set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
            }
            if {$doomed_posn ne "" && $doomed_posn > -1} {
                set doomed_record [lindex $stack $doomed_posn]
                if {[llength $stack] == ($doomed_posn + 1)} {
                #last on stack - put the implemenation from the doomed_record back as the actual command
                    uplevel #0 [list rename $command ""]
                    uplevel #0 [list rename [dict get $doomed_record implementation] $command]
                } elseif {[llength $stack] > ($doomed_posn + 1)} {
                    #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
                    set rewrite_posn [expr {$doomed_posn + 1}]
                    set rewrite_record [lindex $stack $rewrite_posn]
                    
                    if {[dict get $rewrite_record next_implementor] ne $renamer} {
                        puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
                    } else {
                        uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
                    }
                    dict set rewrite_record next_implementor    [dict get $doomed_record next_implementor]
                    #don't update next_getter - it always refers to self
                    dict set rewrite_record implementation      [dict get $doomed_record implementation]
                    lset stack $rewrite_posn $rewrite_record
                    dict set all_stacks $command $stack
                }
                set stack [lreplace $stack $doomed_posn $doomed_posn]
                dict set all_stacks $command $stack
                
            }
            return $stack
        }
        return [list]
    }

    proc show_stack {{commandname_glob *}} {
        variable all_stacks
        if {![regexp {[?*]} $commandname_glob]} {
            #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
            set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
        }
        if {[package provide punk::lib] ne "" && [package provide punk] ne ""} {
            #punk pipeline also needed for patterns
            return [punk::lib::pdict -channel none  all_stacks $commandname_glob/@*/@*.@*]
        } else {
            set result ""
            set matchedkeys [dict keys $all_stacks $commandname_glob]
            #don't try to calculate widest on empty list
            if {[llength $matchedkeys]} {
                set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
                set indent [string repeat " " [expr {$widest + 3}]]
                set indent2 "${indent}       " ;#8 spaces for " i = " where i is 4 wide
                set padkey [string repeat " " 20]
                foreach k $matchedkeys {
                    append result "$k = "
                    set i 0
                    foreach stackmember [dict get $all_stacks $k] {
                        if {$i > 0} {
                            append result "\n$indent" 
                        }
                        append result [string range "$i   " 0 4] " = "
                        set j 0
                        dict for {k v} $stackmember {
                            if {$j > 0} {
                                append result "\n$indent2"
                            }
                            set displaykey [string range "$k$padkey" 0 20]
                            append result "$displaykey = $v"
                            incr j
                        }
                        incr i
                    }
                    append result \n
                }
            }
            return $result
        }
    }

    #review
    #document when this is to be called. Wiping stacks without undoing renames seems odd.
    proc Delete_stack {command} {
        variable all_stacks
        if {[dict exists $all_stacks $command]} {
            dict unset all_stacks $command
            return 1
        } else {
            return 1
        }
    }

    #can be used to temporarily put a stack aside - should manually rename back when done.
    #review - document how/when to use. example? intention?
    proc Rename_stack {oldname newname} {
        variable all_stacks
        if {[dict exists $all_stacks $oldname]} {
            if {[dict exists $all_stacks $newname]} {
                error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
            } else {
                #set stackval [dict get $all_stacks $oldname]
                #dict unset all_stacks $oldname
                #dict set all_stacks $newname $stackval
                dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
            }
        }
    }
}








namespace eval commandstack::lib {
    proc splitx {str {regexp {[\t \r\n]+}}} {
        #snarfed from tcllib textutil::splitx to avoid the dependency
        # Bugfix 476988
        if {[string length $str] == 0} {
            return {}
        }
        if {[string length $regexp] == 0} {
            return [::split $str ""]
        }
        if {[regexp $regexp {}]} {
            return -code error  "splitting on regexp \"$regexp\" would cause infinite loop"
        }

        set list  {}
        set start 0
        while {[regexp -start $start -indices -- $regexp $str match submatch]} {
            foreach {subStart subEnd} $submatch break
            foreach {matchStart matchEnd} $match break
            incr matchStart -1
            incr matchEnd
            lappend list [string range $str $start $matchStart]
            if {$subStart >= $start} {
                lappend list [string range $str $subStart $subEnd]
            }
            set start $matchEnd
        }
        lappend list [string range $str $start end]
        return $list
    }
    proc split_body {procbody} {
        set marker "#<commandstack_separator>#"
        set header ""
        set code ""
        set found_marker 0
        foreach ln [split $procbody \n] {
            if {!$found_marker} {
                if {[string trim $ln] eq $marker} {
                    set found_marker 1
                } else {
                    append header $ln \n
                }
            } else {
                append code $ln \n
            }
        }
        if {$found_marker} {
            return [list $header $code] 
        } else {
            return [list "" $procbody]
        }
    }
}

package provide commandstack [namespace eval commandstack {
    set version 0.3
}]