# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::mix::commandset::loadedlib 0.1.0
# Meta platform     tcl
# Meta license      <unspecified>
# @@ Meta End



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Requirements
##e.g package require frobz
package require punk::ns
package require punk::lib



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::loadedlib {
    namespace export *
    #search automatically wrapped in * * - can contain inner * ? globs
    punk::args::define {
        @id     -id ::punk::mix::commandset::loadedlib::search
        @cmd    -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
        -return  -type string -default table -choices {table tableobject list lines}
        -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
            "(unimplemented) Display only those that are 0:absent 1:present 2:either"
        -highlight -type boolean -default 1 -help\
            "Highlight which version is present with ansi underline and colour"
        -refresh -default 0 -type boolean -help "Re-scan the tm and library folders"
        searchstrings -default * -multiple 1 -help\
            "Names to search for, may contain glob chars (* ?) e.g *lib*
            If no glob chars are explicitly specified, the searchstring will be wrapped with star globs.
            eg name -> *name*
            To search for an exact name prefix it with =
            e.g =name -> name
            "
    }
    proc search {args} {
        set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args]
        set searchstrings [dict get $argd values searchstrings]
        set opts [dict get $argd opts]
        set opt_return      [dict get $opts -return]
        set opt_highlight   [dict get $opts -highlight]

        #REVIEW - this doesn't result in full scans
        catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything

        if {[catch {package require natsort}]} {
            set has_natsort 0
        } else {
            set has_natsort 1
        }
        set packages [package names]
        set matches [list]
        foreach search $searchstrings {
            if {[regexp {[?*\[]} $search]} {
                #caller has specified specific glob pattern - use it
                #todo - respect supplied case only if uppers present? require another flag?
                lappend matches {*}[lsearch -all -inline -nocase $packages $search]
            } elseif {[string match =* $search]} {
                lappend matches {*}[lsearch -all -inline -exact $packages [string range $search 1 end]]
            } else {
                #make it easy to search for anything
                lappend matches {*}[lsearch -all -inline -nocase $packages "*$search*"]
            }
        }
        set matches [lsort -unique $matches][unset matches]
        set matchinfo [list]
        set highlight_ansi [a+ web-limegreen underline]
        set RST [a]
        foreach m $matches {
            set versions [package versions $m]
            if {![llength $versions]} {
                #e.g builtins such as zlib - shows no versions - but will show version when package present/provide used
                set versions [package provide $m]
                #if {![catch {package present $m} v]} {
                #    set versions $v
                #}
            }
            if {$has_natsort} {
                set versions [natsort::sort $versions]
            } else {
                set versions [lsort $versions]
            }
            if {$opt_highlight} {
                set v [package provide $m]
                if {$v ne ""} {
                    set posn [lsearch $versions $v]
                    if {$posn >= 0} {
                        #FIXME! (probably in textblock::pad ?)
                        #TODO - determine why underline is extended to padding even with double reset. (space or other char required to prevent)
                        set highlighted "$highlight_ansi$v$RST $RST"
                        set versions [lreplace $versions $posn $posn $highlighted]
                    } else {
                        #shouldn't be possible?
                        puts stderr "failed to find version '$v' in versions:$versions for package $m"
                    }
                }
            }
            lappend matchinfo [list $m $versions]
        }
        switch -- $opt_return {
            list {
                return $matchinfo 
            }
            lines {
                return [join $matchinfo \n]
            }
            table - tableobject {
                set t [textblock::class::table new]
                $t add_column -headers "Package"
                $t add_column -headers "Version"
                $t configure -show_hseps 0
                foreach m $matchinfo {
                    $t add_row [list [lindex $m 0] [join [lindex $m 1] " "]]
                }
                if {$opt_return eq "tableobject"} {
                    return $t
                }
                set result [$t print]
                $t destroy
                return $result
            }
        }
    }
    proc loaded.search {searchstring} {
        set search_result [search $searchstring]
        set all_libs [split $search_result \n]
        set col1items [list]
        set col2items [list]
        set col3items [list]
        foreach libinfo $all_libs {
            if {[string trim $libinfo] eq ""} {
                continue
            }
            set versions [lassign $libinfo libname]
            if {[set ver [package provide $libname]] ne ""} {
                lappend col1items $libname
                lappend col2items $versions
                lappend col3items $ver
            }
        }

        package require overtype
        set title1 "Library"
        set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]]
        set col1 [string repeat " " $widest1]
        set title2 "Versions Avail."
        set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]]
        set col2 [string repeat " " $widest2]
        set title3 "Loaded Version"
        set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]]
        set col3 [string repeat " " $widest3]


        set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}]

        set table ""
        append table [string repeat - $tablewidth] \n
        append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n
        append table [string repeat - $tablewidth] \n
        foreach c1 $col1items c2 $col2items c3 $col3items {
            append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n
        }

        return $table


        set loaded_libs [list]
        foreach libinfo $all_libs {
            if {[string trim $libinfo] eq ""} {
                continue
            }
            set versions [lassign $libinfo libname]
            if {[set ver [package provide $libname]] ne ""} {
                lappend loaded_libs "$libname $versions (loaded $ver)"
            }
        }
        return [join $loaded_libs \n]
    }

    proc info {libname} {
        if {[catch {package require natsort}]} {
            set has_natsort 0
        } else {
            set has_natsort 1
        }
        catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched  - using unsatisfiable version range
        set pkgsknown [package names]
        if {[set posn [lsearch $pkgsknown $libname]] >= 0} {
            puts stdout "Found package [lindex $pkgsknown $posn]"
        } else {
            puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path"
        }
        set versions [package versions [lindex $libname 0]]
        if {$has_natsort} {
            set versions [natsort::sort $versions]
        } else {
            set versions [lsort $versions]
        }
        if {![llength $versions]} {
            puts stderr "No version numbers found for library/module $libname"
            return false
        }
        puts stdout "Versions of $libname found: $versions"
        set alphaposn [lsearch $versions "999999.*"]
        if {$alphaposn >= 0} {
            set alpha [lindex $versions $alphaposn]
            #remove and tack onto beginning..
            set versions [lreplace $versions $alphaposn $alphaposn] 
            set versions [list $alpha {*}$versions]
        }
        foreach ver $versions {
            set loadinfo [package ifneeded $libname $ver]
            puts stdout "$libname $ver"
            puts stdout "--- 'package ifneeded' script ---"
            puts stdout $loadinfo
            puts stdout "---"
        }
        return
    }

    proc copyasmodule {library modulefoldername args} {
        set defaults [list -askme 1]
        set opts [dict merge $defaults $args]
        set opt_askme [dict get $opts -askme]

        if {[catch {package require natsort}]} {
            set has_natsort 0
        } else {
            set has_natsort 1
        }

        catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range)

        if {[file pathtype $modulefoldername] eq "absolute"} {
            if {![file exists $modulefoldername]} {
                error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules"
            }
            #use the target folder as the source of projectdir info
            set pathinfo [punk::repo::find_repos $modulefoldername]
            set projectdir [dict get $pathinfo closest]
            set modulefolder_path $modulefoldername
        } else {
            #use the current working directory as the source of projectdir info
            set pathinfo [punk::repo::find_repos [pwd]]
            set projectdir [dict get $pathinfo closest]
            if {$projectdir ne ""} {
                set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir]
                set majorv [lindex [split [info tclversion] .] 0]
                foreach k [list modules modules_tcl$majorv vendormodules vendormodules_tcl$majorv] {
                    set knownfolder [file join $projectdir src $k]
                    if {$knownfolder ni $modulefolders} {
                        lappend modulefolders $knownfolder
                    }
                }
                set mtails [list]
                foreach path $modulefolders {
                    lappend mtails [file tail $path]
                }

                #special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules
                lappend modulefolders [file join $projectdir src bootsupport/modules]

                if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules bootsupport/modules_tcl$majorv"} {
                    set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n"
                    append msg "Known module folders: [lsort $mtails]\n"
                    append msg "Use a name from the above list, or a fully qualified path\n"
                    error $msg
                }

                if {$modulefoldername eq "bootsupport"} {
                    set modulefoldername "bootsupport/modules"
                }
                set modulefolder_path [file join $projectdir src $modulefoldername]
            } else {
                set msg     "No current project found at or above current directory\n"
                append msg  "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n
                append msg  "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n
                error $msg
            }
        }
        puts stdout "-----------------------------"
        if {$projectdir ne ""} {
            puts stdout "Using projectdir: $projectdir for lib.copyasmodule"
        } else {
            puts stdout "No current project."
        }
        puts stdout "-----------------------------"
        if {![file exists $modulefolder_path]} {
            error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first"
        }

       
        set libfound [lsearch -all -inline [package names] $library]
        if {[llength $libfound] != 1 || ![string length $libfound]} {
            error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'"
        }

        set versions [package versions [lindex $libfound 0]]
        set versions [lsort -command {package vcompare} $versions]
        #if {$has_natsort} {
        #    set versions [natsort::sort $versions]
        #} else {
        #    set versions [lsort $versions]
        #}
        if {![llength $versions]} {
            error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually"
        }
        puts stdout "Versions of $libfound found: $versions"
        set alphaposn [lsearch $versions "999999.*"]
        if {$alphaposn >= 0} {
            set alpha [lindex $versions $alphaposn]
            #remove and tack onto beginning..
            set versions [lreplace $versions $alphaposn $alphaposn] 
            set versions [list $alpha {*}$versions]
        }

        set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare?
        if {[llength $versions] > 1} {
            puts stdout  "Version selected: $ver"
        }

        set loadinfo [package ifneeded $libfound $ver]
        set loadinfo [string map {\r\n \n} $loadinfo]
        set loadinfo_lines [split $loadinfo \n]
        if {[catch {llength $loadinfo}]} {
            set loadinfo_is_listshaped 0
        } else {
            set loadinfo_is_listshaped 1
        }
        
        #check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result
        #- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version?
        set is_package_require_self_recased 0
        set is_package_require_diversion 0
        set lib_diversion_name ""
        if {[llength $loadinfo_lines] == 1} {
            #e.g Thread 3.0b1 diverts to thread 3.0b1
            set line1 [lindex $loadinfo_lines 0]
            #check if multiparted with semicolon
            #We need to distinguish "package require <lib> <ver>; more stuff"  from "package require <lib> ver> ;"  possibly with trailing comment?
            set parts [list]
            if {[regexp {;} $line1]} {
                foreach p [split $line1 {;}] {
                    set p [string trim $p]
                    if {[string length $p]} {
                        #only append parts with some content that doesn't look like a comment
                        if {![string match "#*" $p]} {
                            lappend parts $p
                        }
                    }
                }

            }
            if {[llength $parts] == 1} {
                #seems like a lone package require statement.
                #check if package require, package\trequire etc
                if {[string match "package*require" [lrange $line1 0 1]]} {
                    set is_package_require_diversion 1
                    if {[lindex $line1 2] eq "-exact"} {
                        #package require -exact <pkg> <ver>
                        set lib_diversion_name [lindex $line1 3]
                        #check not an exact match - but is a -nocase match - i.e differs in case only
                        if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} {
                            if {[lindex $line1 4] eq $ver} {
                                set is_package_require_self_recased 1
                            } 
                        }
                    } else {
                        #may be package require <pkg> <ver>
                        #or package require <pkg> <ver> ?<ver>?...
                        set lib_diversion_name [lindex $line1 2]
                        #check not an exact match - but is a -nocase match - i.e differs in case only
                        if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} {
                            set requiredversions [lrange $line1 3 end]
                            if {$ver in $requiredversions} {
                                set is_package_require_self_recased 1
                            }
                        }
                    }
                } 
            }
        }

        if {$is_package_require_self_recased && [string length $lib_diversion_name]} {
            #we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?)    
            set libfound $lib_diversion_name
            set loadinfo [package ifneeded $libfound $ver]
            set loadinfo [string map {\r\n \n} $loadinfo]
            set loadinfo_lines [split $loadinfo \n]
            if {[catch {llength $loadinfo}]} {
                set loadinfo_is_listshaped 0
            } else {
                set loadinfo_is_listshaped 1
            }


        } else {
            if {$is_package_require_diversion} {
                #single 
                #for now - we'll abort and tell the user to run again with specified pkg/version
                #We could automate - but it seems likely to be surprising.
                puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines"
                puts stderr "Review and consider trying with the pkg/version described in the result above."
                return
            }
        }


        if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} {
            set source_file [lindex $loadinfo 1]
        } elseif {[string match "*source*" $loadinfo]} {
            set parts [list]
            foreach ln $loadinfo_lines {
                if {![string length $ln]} {continue}
                lappend parts {*}[split $ln ";"]
            }
            set sources_found [list]
            set loads_found [list]
            set dependencies [list]
            set incomplete_lines [list]
            foreach p $parts {
                set p [string trim $p]
                if {![string length $p]} {
                    continue ;#empty line or trailing colon
                }
                if {[string match "*tclPkgSetup*" $p]} {
                    puts stderr "Unable to process load script for library $libfound"
                    puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'"
                    return false
                }
                if {![::info complete $p]} {
                    #
                    #probably a perfectly valid script - but slightly more complicated than we can handle
                    #better to defer to manual processing
                    lappend incomplete_lines $p
                    continue
                }
                if {[lindex $p 0] eq "source"} {
                    #may have args.. e.g -encoding utf-8
                    lappend sources_found [lindex $p end]
                }
                if {[lindex $p 0] eq "load"} {
                    lappend loads_found [lrange $p 1 end]
                }
                if {[lrange $p 0 1] eq "package require"} {
                    lappend dependencies [lrange $p 2 end]
                }
            }
            if {[llength $incomplete_lines]} {
                puts stderr "unable to interpret load script for library $libfound"
                puts stderr "Load info: $loadinfo"
                return false
            }
            if {[llength $loads_found]} {
                puts stderr "package $libfound appears to have binary components"
                foreach l $loads_found {
                    puts stderr " binary - $l"
                }
                foreach s $sources_found {
                    puts stderr " script - $s"
                } 
                puts stderr "Unable to automatically copy binary libraries to your module folder."
                return false 
            }

            if {[llength $sources_found] != 1} {
                puts stderr "sorry - unable to interpret source library location"
                puts stderr "Only 1 source supported for now"
                puts stderr "Load info: $loadinfo"
                return false
            }
            if {[llength $dependencies]} {
                #todo - check/ignore if dependency is Tcl ?
                puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required."
                foreach d $dependencies {
                    puts stderr " - $d"
                }
            } 

            set source_file [lindex $sources_found 0]
        } else {
            puts stderr "sorry - unable to interpret source library location"
            puts stderr "Load info: $loadinfo"
            return false
        }

        # -- ---------------------------------------
        #Analyse source file
        if {![file exists $source_file]} {
            error "Unable to verify source file existence at: $source_file"
        }
        set source_data [fcat -translation binary $source_file] 
        if {![string match "*package provide*" $source_data]} {
            puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort  - copy manually"
            return false
        } else {
            if {![string match "*$libfound*" $source_data]} {
                # as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules
                #e.g anyname-0.1.tm example
                if {![string match "*package provide \$pkg \$version*" $source_data]} {
                    puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually"
                    return false
                }
            }
        }


        if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} {
            puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module"
            puts stderr "Copy the library across to a lib folder instead"
            return false
        }
        # -- ---------------------------------------

        set moduleprefix [punk::ns::nsprefix $libfound]
        if {[string length $moduleprefix]} {
            set moduleprefix_parts [punk::ns::nsparts $moduleprefix]
            set relative_path [file join {*}$moduleprefix_parts]
        } else {
            set relative_path ""
        }
        set pkgtail [punk::ns::nstail $libfound] 
        set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm]

        if {$opt_askme} {
            puts stdout "WARNING - you should check that there aren't extra required files for the library/modules"
            puts stdout ""
            puts stdout "This is not intended for binary modules - use at own risk and check results"
            puts stdout ""
            puts stdout "Base module path: $modulefolder_path"
            puts stdout "Target path     :  $target_path"
            puts stdout "results of 'package ifneeded $libfound'"
            puts stdout "---"
            puts stdout "$loadinfo"
            puts stdout "---"
            set question "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" 
            set answer [punk::lib::askuser $question] ;#takes account of previous stdin state and terminal raw vs line state
            if {[string tolower $answer] ne "y"} {
                puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed)  use -askme 0 to avoid prompts."
                return
            }
        }

        if {![file exists $modulefolder_path]} {
            puts stdout "Creating module base folder at $modulefolder_path"
            file mkdir $modulefolder_path
        }
        if {![file exists [file dirname $target_path]]} {
            puts stdout "Creating relative folder at [file dirname $target_path]"
            file mkdir [file dirname $target_path]
        }

        if {[file exists $target_path]} {
            puts stdout "WARNING - module already exists at $target_path"
            if {$opt_askme} {
                set question "Copy anyway? Y|N" 
                set answer [punk::lib::askuser $question]
                if {[string tolower $answer] ne "y"} {
                    puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed)  use -askme 0 to avoid prompts."
                    return
                }
            }
        }

        file copy -force $source_file $target_path
        
        return $target_path
    }



}














# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Ready   
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib {
    variable version
    set version 0.1.0 
}]
return