ycl

Artifact 698ad8cfbbfe42db7964138a38a76779ecd5ebe8:

• File packages/package/lib/package.tcl — part of check-in [231419a2e9] at 2022-01-16 22:08:03 on branch trunk — list lcs

  new procedure

  diff

  string

  use [=] instead of [expr]

  various minor fixes (user: pooryorick size: 7663)

#! /bin/env tclsh

::namespace eval doc {}

variable scriptpath [::info script]
variable ycldir [::file dirname [::file dirname [::file dirname [::file dirname [
	::file normalize $scriptpath/...]]]]]


proc autoupdate args {
	variable autoupdate
	switch [llength $args] {
		0 {}
		1 {
			set autoupdate [expr {!![lindex $args 0]}]
		}
		default {
			error [list {wrong # args}]
		}
	}
	return $autoupdate
}


proc file {package version} {
	variable packages
	dict get packages package $version location
}


proc info {package version} {
	variable packages
	dict get $packages $package $version
}


proc ns {name version} {
	variable packages
	dict get $packages $name $version ns
}


proc uniquens unique {
	return [yclprefix]::.loaded::$unique
}


variable doc::loaded {
	description {
		return a list of all loaded packages
	}
}


proc loaded {} {
	set res [list]
	foreach name [package names] {
		if {[package provide $name] ne {}} {
			lappend res $name
		}
	}
	return $res
}


##to do: finish or delete
#proc namespace {package version ns} {
#	variable packages
#	set namespace [uplevel 1 [list namespace eval $ns {::namespace current}]]
#	set routine [uplevel 1 [list ::namespace eval $ns [list ::namespace ensemble create
#	-command [namespace current]::[::info cmdcount]_[namespace tail $package]]]]
#	trace add command $routine delete [list ::apply [list {} {
#	} [namespace current]]]
#	return
#}


variable doc::packagesource {
	description {

		uses the script contained in $location as the body of a procedure, and
		calls that procedure procedure in the named namespace for the specified
		package 

		a package that sources multiple scripts in multiple namespace can call
		this routine once for each sourced script

		in order to avoid bootstrapping issues this routine does not require
		any other packages 
	}

}
proc packagesource {package version ns location args} {
	variable packages

	set encoding utf-8 
	while {[llength $args]} {
		set args [lassign $args[set args {}] opt]
		switch $opt {
			encoding {
				set args [lassign $args[set args {}] encoding]
			}
			default {
				error [list {unknown option} $opt]
			}
		}
	}

	set chan [open $location rb]
	try {
		set encoded [read $chan]
	} finally {
		close $chan
	}
	set currentscript [::info script]
	::info script $location
	try {
		if {$encoding eq {}} {
			set script $encoded
		} else {
			set script [encoding convertfrom $encoding $encoded]
			set reencoded [encoding convertto $encoding $script]
			if {$reencoded ne $encoded} {
				error [list {invalid encoding for location} $location]
			}
		}
		uplevel 1 [list ::namespace eval $ns {}]
		set res [uplevel 1 [list ::apply [
			list {package version} $script $ns] $package $version]]
		set info [dict create encoding $encoding \
			ns $ns script $script result $res]
		dict set packages $package $version location $location $info
	} finally {
		::info script $currentscript
	}
	return $res
}


proc loadpackage {dir package version ns body} {
	variable loading
	lappend loading [list $package $version $ns]
	try {
		uplevel 1 [list ::apply [
			list {dir package version ns} $body] $dir $package $version $ns]
	} finally {
		set loading [lreplace $loading[set loading {}] end end]
	}
	package provide $package $version
}


proc prep name {
	#[yclprefix] exports the root namespace 
	set yclprefix [yclprefix]
	if {[string match ::* $name]} {
		set fullname $name
	} else {
		set fullname [set name ${yclprefix}::$name]
	}
	set yclprefix [yclprefix]
	while {$name ne $yclprefix} {
		#if {![namespace ensemble exists $name] && ![::info object isa object $name]} 
		if {[::namespace which $name] eq {}} {
			::namespace eval $name {
				#::namespace eval imports {}
				#::namespace path [list imports {*}[::namespace path]]
				::namespace export *
				::namespace ensemble create -prefixes 0
			}
		}
		set name [::namespace parent $name]
	}
	::namespace eval $fullname {
		::namespace eval doc {}
	}
	return $fullname
}


variable doc::require {
	description {
		A wrapper for [package require]

			can automatically update packages as source files change

		if a package is stale

			i.e.
				if the source code for a package or any package it requires has
				changed

			then

				[package forget] the package before calling [package require]

		otherwise
			do nothing
	}
}
proc require {package args} {
	variable loading
	variable packageepoch
	variable packages
	variable autoupdate
	set version [uplevel 1 [list ::package require $package {*}$args]]
	if {![dict exists $packages $package $version]} {
		dict set packages $package $version {} 
	 }
	if {![dict exists $packages $package $version epoch]} {
		dict set packates $package $version epoch 0
	}
	if {$autoupdate} {
		set stale 0
		if {[dict exists $packages $package $version requirement]} {
			dict for {requirement version} [dict get $packages $package $version requirement] {
				set info [dict get $packages $requirement] 
				set repoch1 [dict get $info epoch]
				set rargs [dict get $info args]
				uplevel 1 [list [namespace which require] $requirement {*}$rargs]
				set repoch2 [dict get $packages $requirement epoch] 
				if {$repoch1 != $repoch2} {
					set stale 1
				}
			}
		}
		if {!$stale} {
			set stale [stale? $package $version]
		}
		if {$stale} {
			package forget $package
			set version [uplevel 1 [list ::package require $package {*}$args]]
			dict set packages $package $version epoch [incr packageepoch]
		}

	}

	if {[llength $loading]} {
		lassign [lindex $loading end] dependant dversion
		dict set packages $dependant $dversion requirement $package $version [dict create args $args]
	}
	return $version
}

variable doc::shelf {
	description {
		load a package and return the name of its shelf 
	}
}
proc shelf {name version fspath} {
	variable ycldir
	package require {ycl shelf shelf}
	set qname [yclprefix]::[join $name ::]
	[yclprefix] shelf shelf $qname
	$qname .eval [list ::source $fspath]
	package provide [list ycl {*}$name] $version 
	return $name
}


proc source {name file} {
	set fullname [prep $name]
	#source the file after the export commands so that the file can override them
	::namespace eval $fullname [list ::source $file]
}


proc stale? {package version} {
	variable packages
	set stale 0
	if {[dict exists $packages $package $version location]} {
		foreach {location linfo} location [dict get $packages $package $version location] {
			set chan [open $location rb]
			set script [read $chan]
			close $chan
			if {$script ne [dict get $info script]} {
				set stale 1
			}
		}
	} else {
		set stale 1
	}
	return $stale
}


proc vcomp {a b} {
	variable vcompre
	foreach varname {a b} {
		upvar 0 $varname var 
		regsub -all {[[:punct:]]+} $var { } $varname
		regsub -all $vcompre $var { \0 } $varname
		regsub -all {[[:space:]]+} $var { } $varname
		set $varname [string trim $var]
	}
	set length [llength $a]
	set idx 0
	foreach apart $a bpart $b {
		foreach varname {apart bpart} {
			upvar 0 $varname var
			if {[string is integer $apart]} {
				scan $var %d $varname
			}
		}
		if {$apart > $bpart} {
			return 1
		} elseif {$bpart > $apart} {
			return -1
		}
	}
}


### convenience commands **


proc yclifneeded {name version filename} {
	package ifneeded [list ycl $name] $version [list apply {{dir} {
		package require {ycl package}
		[yclprefix]::package::source $name \
			 [::file join $dir {*}$filename] 
		package provide [list ycl $name] $version 
	}} $dir]
}


variable autoupdate 0
variable loading {}
variable packageepoch 0
variable packages {}

variable vcompre
foreach class {upper lower digit cntrl} {
	lappend vcompre (\[\[:$class:]]+)
	set vcompre [join $vcompre |]
	unset class
}