# ------------------------------------------------------------------------------
# Starkit support, see http://www.equi4.com/starkit/
# by Jean-Claude Wippler, July 2002
# Revisions for v2 by Keith Nash, April 2026
# ------------------------------------------------------------------------------

package require tcl 9

namespace eval starkit {
    # These variables are defined after the first call to starkit::startup.
    # They are special in that a second call will not alter them
    # (as needed when a starkit sources others for more packages).
    variable topdir     ;# root directory (while the starkit is mounted)
    variable mode       ;# startup mode (starpack, starkit, unwrapped, sourced)
    variable trueMode   ;# starpack, starkit, unwrapped, sourced+unwrapped,
		         # sourced+starkit

    # Not special.  Used by each call to starkit::startup.
    variable kitDict {} ;# records of all loaded starkits
    variable count   1  ;# number of next starkit to be mounted
}

# Accessor procs so that scripts do not need to peek at starkit variables.
proc starkit::mode {} {
    variable mode
    return $mode
}
proc starkit::topdir {} {
    variable topdir
    return $topdir
}

# ------------------------------------------------------------------------------
#  Command starkit::header
# ------------------------------------------------------------------------------
# This command is called only from the script header of a starkit.
# - Starpacks do not have a script header that mounts them - Tcl itself mounts
#   their zip files at "[zipfs root]app".
# - Do not mount a starkit if it is already mounted.
# ------------------------------------------------------------------------------

proc starkit::header {driver args} {
    if {[catch {
	set self [fullnormalize [info script]]
	if {$driver eq {zip}} {
	    set mountpoint [mount $self]
	    set startFile [file join $mountpoint main.tcl]
	    if {![file isfile $startFile]} {
		panic "this starkit \"$self\" does not have file main.tcl\
			at \"$startFile\""
	    }
	    uplevel [list source $startFile]
	} elseif {$driver eq {mk4}} {
	    panic "this is an mk4 starkit - it must be converted to zipfs format"
	} else {
	    panic "format \"$driver\" is not supported"
	}
    } result errorOpts]} {
	panic $result
    }
}

proc starkit::mount {zipkit} {
    variable count

    set mounted 0
    set zipkit [fullnormalize $zipkit]

    # If zipkit is already mounted, do not mount it again.
    foreach {point kit} [zipfs mount] {
	if {[fullnormalize $kit] eq $zipkit} {
	    set mountpoint $point
	    set mounted 1
	    break
	}
    }
    if {!$mounted} {
	# count may have been incremented by another interpreter.
	# Check that its mountpoint is free.
	set count [NextMountNumber $count]
	set mountpoint \
	      [zipfs mount $zipkit [file join [zipfs root] starkit$count]]
	incr count
    }
    return $mountpoint
}

# Cannot just "incr count" because the VFS is shared with other unsafe
# interpreters, any of which may mount a starkit.
proc starkit::NextMountNumber {num} {
    while {[zipfs mount [file join [zipfs root] starkit$num]] ne {}} {
	incr num
    }
    return $num
}

# ------------------------------------------------------------------------------
#  Command starkit::fullnormalize
# ------------------------------------------------------------------------------
# Normalizes a path completely. I.e. a symlink in the last element is resolved
# as well, not only symlinks in the higher elements.
#
# SNARFED from tcllib/fileutil.
# Updated to fix Windows bug as in fileutil commit [664f9dd378] 2007-08-08.
# ------------------------------------------------------------------------------

proc starkit::fullnormalize {path} {
    return [file dirname [file normalize $path/__dummy__]]
}

# ------------------------------------------------------------------------------
#  Command starkit::startup
# ------------------------------------------------------------------------------
# called from the main.tcl script of a starkit to init topdir and auto_path
# 2003/10/21, added in 1.3: remember startup mode in starkit::mode
#
# Options:
# -extend no|top|lib|both default
# ------------------------------------------------------------------------------

proc starkit::startup {args} {
    variable kitDict
    if {![info exists starkit::mode]}     { variable mode }
    if {![info exists starkit::trueMode]} { variable trueMode }

    if {[llength $args] == 0} {
	set extendMe top
    } elseif {    [llength $args] == 2
               && [lindex $args 0] eq {-extend}
               && [lindex $args 1] in {both top lib none}
    } {
	set extendMe [lindex $args 1]
    } else {
        panic {usage: starkit::startup ?-extend both|top|lib|none?}
    }

    # Determine what this "kit" is.

    set script [fullnormalize [info script]]
    set topDir [file dirname $script]
    set root   [zipfs root]
    set zfslen [string length $root]
    set mode   [FindMode]
    set kit    [zipfs mount $topDir]

    if {($mode eq {sourced}) && ([string range $topDir 0 $zfslen-1] eq [zipfs root])} {
	set trueMode sourced+starkit
    } elseif {$mode eq {sourced}} {
        set trueMode sourced+unwrapped
    } else {
	set trueMode $mode
    }

    # Record properties in kitDict
    # - $kit is the same as $topDir if unwrapped.

    dict set kitDict $topDir [dict create mode $mode kit $kit \
	    trueMode $trueMode extend $extendMe]

    # Extend package paths.
    # Duplicate or non-existent paths will not be added.

    if { ($extendMe in {both top}) } {
	autoextend $topDir withTM
    }
    set libDir [file join $topDir lib]
    if { ($extendMe in {both lib})  &&  [file isdirectory $libDir] } {
	autoextend $libDir withTM
    }

    return $mode
}

# Read dict of calls to starkit::startup.
proc starkit::getKitDict {args} {
    variable kitDict
    if {[llength $args] > 2} {
        return -code error {usage: starkit::getKitDict ?topdir ?key??}
    }
    dict get $kitDict {*}$args
}

# Returns how the script was launched: starkit, starpack, unwrapped, or
# sourced.
proc starkit::FindMode {} {
    global argv0

    # 2003/02/11: new behavior, if starkit::topdir exists, don't disturb it
    if {![info exists starkit::topdir]} { variable topdir }

    set script [fullnormalize [info script]]
    set topdir [file dirname $script]
    set root   [zipfs root]
    set zfslen [string length $root]

    ### Determine mode ###

    if {    [fullnormalize [zipfs mount $topdir]]
	 eq [fullnormalize [info nameofexecutable]]
    } {
	return starpack
    }

    set a0 [fullnormalize $argv0]
    if {   ([string range $topdir 0 $zfslen-1] eq [zipfs root])
	&& ($a0 eq [fullnormalize [zipfs mount [file dirname [info script]]]])
    } {
	return starkit
    } elseif {[string range $topdir 0 $zfslen-1] eq [zipfs root]} {
	# Means that the basekit/starpack/starkit *sources the starkit file*
	# - See other "sourced" case below.
	return sourced
    }

    # Means that the starkit is unwrapped AND
    # the basekit executes its main.tcl.
    if {$script eq $a0} { return unwrapped }

    # Means that the starkit is unwrapped AND
    # the basekit/starpack/starkit *sources its main.tcl*.
    # - See other "sourced" case above.
    return sourced
}

# Append an entry to auto_path if it is not yet listed.
# Also module paths if requested by ($withTm ne {}) and if
# the subdirectory tcl9/ exists.
proc starkit::autoextend {dir {withTm {}}} {
    global auto_path
    set dir [fullnormalize $dir]
    set got 0
    foreach path $auto_path {
	if {[fullnormalize $path] eq $dir} {
	    set got 1
	    break
	}
    }
    if {!$got} {
	lappend auto_path $dir
    }
    if {$withTm eq {}} { return }
    set dlen [string length $dir]
    lassign [split $::tcl_version .] major
    set lm [string length tcl$major]
    foreach path [tcl::tm::list] {
	if {    [string range [fullnormalize $path] 0 $dlen+$lm]
	     eq [file join $dir tcl$major]
	} {
	    return
	}
    }
    if {[file isdirectory [file join $dir tcl$major]]} {
	tcl::tm::roots $dir
    }
    return
}

# To remount the first starkit with different options.
# For compatibility. Has no effect.
proc starkit::remount {args} {
    return
}

# Terminate with an error message, using most appropriate mechanism.
proc starkit::panic {msg} {
    if {([info commands wm] ne "")} {
	catch { wm withdraw . }
	tk_messageBox -icon error -message $msg -title "Fatal error"
    } elseif {[info commands ::eventlog] ne ""} {
	eventlog error $msg
    } else {
	puts stderr $msg
    }
    exit
}

# Copied from the critcl package, v 3.3, proc platform::generic.
proc starkit::platform {} {
    global tcl_platform

    set plat [string tolower [lindex $tcl_platform(os) 0]]
    set cpu  $tcl_platform(machine)

    switch -glob -- $cpu {
	sun4* {
	    set cpu sparc
	}
	intel -
	i*86* {
	    set cpu ix86
	}
	x86_64 {
	    if {$tcl_platform(wordSize) == 4} {
		# See Example <1> at the top of this file.
		set cpu ix86
	    }
	}
	"Power*" {
	    set cpu powerpc
	}
	"arm*" {
	    set cpu arm
	}
	ia64 {
	    if {$tcl_platform(wordSize) == 4} {
		append cpu _32
	    }
	}
    }

    switch -glob -- $plat {
	cygwin* {
	    set plat cygwin
	}
	windows {
	    if {$tcl_platform(platform) == "unix"} {
		set plat cygwin
	    } else {
		set plat win32
	    }
	    if {$cpu eq "amd64"} {
		# Do not check wordSize, win32-x64 is an IL32P64 platform.
		set cpu x86_64
	    }
	}
	sunos {
	    set plat solaris
	    if {[string match "ix86" $cpu]} {
		if {$tcl_platform(wordSize) == 8} {
		    set cpu x86_64
		}
	    } elseif {![string match "ia64*" $cpu]} {
		# sparc
		if {$tcl_platform(wordSize) == 8} {
		    append cpu 64
		}
	    }
	}
	darwin {
	    set plat macosx
	    # Correctly identify the cpu when running as a 64bit
	    # process on a machine with a 32bit kernel
	    if {$cpu eq "ix86"} {
		if {$tcl_platform(wordSize) == 8} {
		    set cpu x86_64
		}
	    }
	}
	aix {
	    set cpu powerpc
	    if {$tcl_platform(wordSize) == 8} {
		append cpu 64
	    }
	}
	hp-ux {
	    set plat hpux
	    if {![string match "ia64*" $cpu]} {
		set cpu parisc
		if {$tcl_platform(wordSize) == 8} {
		    append cpu 64
		}
	    }
	}
	osf1 {
	    set plat tru64
	}
    }

    return "${plat}-${cpu}"
}

# Load extension from a platform-specific subdirectory.
proc starkit::pload {dir name args} {
  set f [file join $dir [platform] $name[info sharedlibext]]
  uplevel 1 [linsert $args 0 load $f]
}

package provide starkit 2.3.0
