mdref.tcl

# -*- tcl -*- Copyright (c) 2013-2024 Andreas Kupries
# # ## ### ##### ######## ############# #####################
## TEApot meta data support: references.

# # ## ### ##### ######## ############# #####################
## Export (internals - )

namespace eval ::kettle::mdref {
    namespace export {[a-z]*} 2tcl
    namespace ensemble create
}

# # ## ### ##### ######## ############# #####################
## State

# # ## ### ##### ######## ############# #####################
## API.

proc ::kettle::mdref::valid {ref {mv {}}} {
    if {$mv ne ""} {upvar 1 $mv message}

    # Get size to check, implicitly also checks that the reference is
    # a valid list.

    if {[catch {
	set size [llength $ref]
    } msg]} {
	set message $msg
	return 0
    }

    # Basics: Empty is bad. Just the package name is ok.

    if {$size == 0} {set message "Empty" ; return 0}
    if {$size == 1} {return 1}

    set ref [lrange $ref 1 end] ; # Cut name

    while {[llength $ref]} {
	# Scan until first option
	set v [lindex $ref 0]
	if {[string match -* $v]} break
	# Check that the non-option is a valid requirements.
	if {![Vreqvalid $v message]} {
	    return 0
	}
	set ref [lrange $ref 1 end] ; # Cut requirement
    }

    # Uneven length is bad. The last option will have no
    # value. Remember, first element is name, then requirements, then
    # option/value pairs. An even length is expected when looking at
    # the option/value pairse.

    if {[llength $ref] % 2 == 1} {
	set message "Last option is without value"
	return 0
    }

    # Scan the options and validate them.

    foreach {k v} $ref {
	switch -exact -- $k {
	    -require {
		if {![Vreqvalid $v message]} {
		    return 0
		}
	    }
	    -platform -
	    -archglob {}
	    -is {
		if {![Evalid $v message]} {
		    return 0
		}
	    }
	    default {
		set message "Unknown option \"$k\""
		return 0
	    }
	}
    }

    return 1
}

proc ::kettle::mdref::normalize {references} {
    # Take a list of references and remove redundancies in each
    # reference, and across all references.

    # In a first iteration each reference is brought into canonical
    # form. This removes the redundancies in each reference. Then we
    # sort the references by package name, and for each package with
    # more than one reference we put them together and re-construct
    # the canonical form.

    array set package {}

    # Bug 72969. Keep the order of dependencies, it may be important
    # during setup.

    set names {}

    foreach ref $references {
	set name [lindex $ref 0]
	set spec [lrange $ref 1 end]

	set ref [Conslist $name $spec]

	set name [lindex $ref 0]
	set spec [lrange $ref 1 end]

	if {![info exists package($name)]} {
	    lappend names $name
	}
	lappend package($name) $spec
    }

    set references {}
    foreach name $names {
	set specs $package($name)

	if {[llength $specs] == 1} {
	    # Single reference, reconstruct from parts, is canonical
	    # already.

	    lappend references [linsert [lindex $specs 0] 0 $name]
	} else {
	    # Multiple references to one package.
	    # Merge specs into one list and re-canonicalize.

	    set spec [concat {*}$specs]
	    lappend references [Conslist $name $spec]
	}
    }

    return $references
}

proc ::kettle::mdref::2tcl {ref} {
    # Convert internal form (requirements are 1/2-element lists) to
    # Tcl form, requirements are 'a', 'a-b', 'a-'. This form is
    # accepted on input, easier to read by a user, and no difference
    # to regular Tcl. We additionally convert -require options into
    # plain non-option requirements sitting between name and the
    # option/value part.

    set res [lindex $ref 0]

    # Non-option requirements.

    set oidx 1
    foreach v [lrange $ref 1 end] {
	# Scan until first option
	if {[string match -* $v]} break
	incr oidx
	lappend res [Vreqstring $v]
    }
    set options [lrange $ref $oidx end]

    # Option requirements to non-option requirements.

    foreach {k v} $options {
	if {$k ne "-require"} continue
	lappend res [Vreqstring $v]
    }

    # All other options.

    foreach {k v} $options {
	if {$k eq "-require"} continue
	lappend res $k $v
    }
    return $res
}

# # ## ### ##### ######## ############# #####################
## Internals

proc ::kettle::mdref::Conslist {name spec} {

    # The constructor for references recognizes not only the options
    # for the newer syntax, but also for the new syntax (see top of
    # file). The latter are accepted if and only if not mixed with the
    # newer options, and are converted on the fly to the newer syntax.
    # Requirements between name and options are recognized and
    # collected as well.

    # Additional work done by the constructor is
    # - Removal of redundant switches
    #   @ -platform, -archglob, -is = Only last value counts.
    #   @ -require                  = Only unique ranges, non-redundant ranges
    # - Sort of switches.
    # This generates a canonical reference.

    # Quick return if reference is plain name without switches.

    if {![llength $spec]} {
	return [list $name]
    }

    # Phase I. Take spec apart into requirements and regular switches.

    set ver   {} ; set hasver  0 ; # Data for -version,  flag when used.
    set exact 0  ; set hasex   0 ; # Data for -exact,    flag when used.
    set plat  {} ; set hasplat 0 ; # Data for -platform, flag when used.
    set ag    {} ; set hasag   0 ; # Data for -archglob, flag when used.
    set is    {} ; set hasis   0 ; # Data for -is,       flag when used.

    array set reqs {}

    set oidx 0
    foreach v $spec {
	# Scan until first option
	if {[string match -* $v]} break
	incr oidx
	set reqs($v) .
    }

    foreach {o v} [lrange $spec $oidx end] {
	switch -exact -- $o {
	    -exact    {set exact $v ; set hasex   1}
	    -version  {set ver   $v ; set hasver  1}
	    -platform {set plat  $v ; set hasplat 1}
	    -archglob {set ag    $v ; set hasag   1}
	    -is       {set is    $v ; set hasis   1}
	    -require  {set reqs($v) .}
	}
    }

    # Phase II. Validate the input, basics. Check for old vs. new, and
    # various other simple validations.

    if {$hasver || $hasex} {
	if {[array size reqs]} {
	    return -code error "Cannot mix old and new style version requirements"
	}

	# -exact implies -version
	if {$hasex && !$hasver} {
	    return -code error "-exact without -version"
	}

	if {$hasex && ![string is boolean -strict $exact]} {
	    return -code error "Expected boolean for -exact, but got \"$v\""
	}
	if {$hasver && ![Vvalid $ver message]} {
	    return -code error $message
	}

	# Translate to new form.

	lappend item $ver
	if {$exact} {
	    lappend item [Vnext $ver]
	} else {
	    # Cap at next major version.
	    # -version 8   => 8-9
	    # -version 8.4 => 8.4-9

	    lappend item [expr {[lindex [split $ver .] 0]+1}]
	}
	set reqs($item) .
    }

    if {$hasis} {
	set is [string tolower $is]
	if {![Evalid $is message]} {
	    return -code error $message
	}
    }

    # Phase III. Get over the requirements and remove redundant
    # ranges. Validate them first. If there is only one range it
    # cannot be redundant.

    if {[array size reqs]} {
	foreach req [array names reqs] {
	    Vreqcheck $req
	    # Translate X-Y forms into the list form for all internal use
	    if {[string match *-* $req]} {
		set rx [split $req -]
		unset reqs($req)
		set reqs($rx) .
	    }
	}

	if {[array size reqs] > 1} {
	    foreach req [array names reqs] {
		foreach other [array names reqs] {
		    # Ignore self.
		    if {$other eq $req} continue
		    if {[Subset $req $other]} {
			unset reqs($req)
			break
		    }
		}
	    }
	}
    }

    # Phase IV. Put the pieces back together to get the canonical
    # form. Which contains every requirement in option form.

    set ref [list $name]
    if {$hasis}   {lappend ref -is $is}
    if {$hasag}   {lappend ref -archglob $ag}
    if {$hasplat} {lappend ref -platform $plat}

    if {[array size reqs]} {
	foreach req [lsort -dict [array names reqs]] {
	    lappend ref -require $req
	}
    }

    # No validation required, we know that the result is ok. We
    # checked all the inputs in the same manner as the validator.

    return $ref
}

proc ::kettle::mdref::Subset {a b} {
    # Returns true if the requirement A is a true subset of requirement B.

    # 1  A = vA            B = vB
    # 2  A = vA -          B = vB -
    # 3  A = vAmin vAmax   B = vBmin vBmax

    # 3 cases per A and B, for a total of 9 combinations.

    # This can be reduced by recognizing that (1) is actually (3),
    # with the max value implied, i.e. derived from the min value.
    # This reduces the situation to four combinations.

    set a [Rtype $a mina maxa]
    set b [Rtype $b minb maxb]

    # 22, 32 are one case, they have the same condition to check. See below.
    ##
    # 22 :
    # A and B are ranges from a minimum to infinity.
    # The range with the larger minimum is the true subset.
    # This implies: A is a true subset of B iff minA > minB. ** same
    ##
    # 32 :
    # A is min to a max,    i.e. of finite size.
    # B is min to infinity, i.e. of infinite size.
    # This implies: A is a true subset iff minA > minB.      ** same
    ##
    # 23 :
    # A is min to infinity, i.e. of infinite size.
    # B is min to a max,    i.e. of finite size.
    # An infinite subset of a finite set is not possible.
    # This implies: A is not a true subset of B
    ##
    # 33 :
    # Both A and B are finite ranges. A is a true subset of B iff
    # (minA >  minB) && (maxA <= maxB) or
    # (minA >= minB) && (maxA <  maxB)

    switch -exact -- $a$b {
	22 -
	32 {return [expr {[package vcompare $mina $minb] > 0}]}
	23 {return 0}
	33 {return [expr {
			  (([package vcompare $mina $minb] >  0) &&
			   ([package vcompare $maxa $maxb] <= 0)) ||
			  (([package vcompare $mina $minb] >= 0) &&
			   ([package vcompare $maxa $maxb] <  0))
		      }]}
    }
}

proc ::kettle::mdref::Rtype {a minv maxv} {
    upvar 1 $minv min $maxv max

    if {[llength $a] == 1} {
	# (1), make it a (3)
	set min   [lindex $a 0]
	set major [lindex [split $min .] 0]
	set max   $major
	# Bug 67186
	incr max
	return 3
    } else {
	# (llength a == 2)
	# (2), (3)
	foreach {min max} $a break
	return [expr {$max eq "" ? 2 : 3}]
    }
}

proc ::kettle::mdref::Evalid {e {mv {}}} {
    variable name
    if {$mv ne ""} {upvar 1 $mv message}

    set ex [string tolower $e]
    set ok [expr {$x in {package application}}]

    if {!$ok} {
	set message "Unknown entity type \"$e\", expected application, or package"
    }
    return $ok
}


proc ::kettle::mdref::Vreqcheck {req} {
    if {![Vreqvalid $req message]} {return -code error $message}
}

proc ::kettle::mdref::Vreqvalid {req {mv {}}} {
    if {$mv ne ""} {upvar 1 $mv message}

    if {[string match *-* $req]} {
	set rx [split $req -]
    } else {
	set rx $req
    }
    if {[llength $rx] == 1} {
	if {![valid [lindex $rx 0] message]} {return 0}
    } elseif {[llength $rx] == 2} {
	foreach {min max} $rx break
	if {![valid $min message]}                 {return 0}
	if {($max ne "") && ![Vvalid $max message]} {return 0}
    } else {
	set message "Bad requirement \"$req\""
	return 0
    }
    return 1
}

proc ::kettle::mdref::Vreqstring {req} {
    if {[llength $req] == 1} {
	return [lindex $req 0]
    } elseif {[llength $req] == 2} {
	foreach {min max} $req break
	if {$max eq ""} {
	    return ${min}-
	} else {
	    return ${min}-$max
	}
    }
}

proc ::kettle::mdref::Vvalid {v {mv {}}} {
    if {$mv ne ""} {upvar 1 $mv message}

    # Defer to the underlying Tcl interpreter. While there is no
    # direct validation (sub)command we can mis-use "packagevcompare"
    # for our purposes. Provide a valid version number as second
    # argument and discard the comparison result. We are only
    # interested in the ok/error status, the latter thrown if and only
    # if the argument is a syntactically invalid version number.

    set ok [expr {[catch {
	package vcompare $v 0
    }] ? 0 : 1}]

    if {!$ok} {
	set message "Bad version \"$v\""
    }
    return $ok
}

proc ::kettle::mdref::Vnext {v} {
    # Examples:
    # * 8.4   -> 8.5
    # * 8.5.9 -> 8.5.10
    #
    # Note: We remove leading zeros (via [scan]) to prevent
    # mis-interpretation as an octal number.

    set vn [split $v .]
    ##nagelfar ignore
    scan [lindex $vn end] %d last
    return [join [lreplace $vn end end [incr last]] .]
}

# # ## ### ##### ######## ############# #####################
## Initialization

# # ## ### ##### ######## ############# #####################
return