api.dtx

%
% \endinput
% 
% This isn't really a literate source file, but simply a normal .tcl 
% file (for something which was written as a standalone package) with 
% a bit of wrapper, to make it fit with the "build a huge .tcl with all 
% the code in it" structure that had to be applied to the rest of 
% cmplutil2.
% 
%<*pkg>
package require Tcl 8.2
package provide API 1.1

namespace eval ::API {
    namespace export static nstatic staticn recursive
}

## 
 # ::API::static - basic API query handler
 # 
 # Synopsis:
 #   ::API::static $dict ?$interface ?$version??
 #   
 #   dict       - Dictionary of supported interfaces and 
 #                versions.
 #   interface  - Name of interface to query about.
 #   version    - Version of interface to check support for.
 # 
 # Result:
 #   Depending on the number of arguments specified, this 
 #   procedure returns the $dict, a list of versions, or a 
 #   boolean.
 #   
 # Usage:
 #   To implement an API subcommand, append the arguments of 
 #   that subcommand to a command prefix
 #       ::API::static $dict
 #   where $dict (typically an explicit constant in your code) is 
 #   the list of interfaces and versions for which you want to 
 #   claim support.
 # 
 ##

proc ::API::static {dict args} {
    if {[llength $args] == 0} then {
        return $dict
    } elseif {[llength $args] > 2} then {
        return -code error "Too many arguments!"
    }
    array set A $dict
    foreach {i version} $args {break}
    if {[llength $args] == 1} then {
        if {[info exists A($i)]} then {
            return $A($i)
        } else {
            return ""
        }
    } else {
        if {![info exists A($i)]} then {return 0}
        foreach hasver $A($i) {
            if {[package vsatisfies $hasver $version]} then {return 1}
        }
        return 0
    }
}


## 
 # ::API::nstatic - basic API query handler in the presence of parameters
 # 
 # Synopsis:
 #   ::API::nstatic $n {*}$ignored $dict ?$interface ?$version??
 #   
 #   dict       - Dictionary of supported interfaces and 
 #                versions.
 #   interface  - Name of interface to query about.
 #   version    - Version of interface to check support for.
 #   ignored    - Ignored arguments.
 #   n          - Number of arguments to ignore.
 # 
 # Result:
 #   Depending on the number of arguments specified, this 
 #   procedure returns the $dict, a list of versions, or a 
 #   boolean.
 #   
 # Usage:
 #   This is a minor variation of the static command, which takes the 
 #   same arguments as it but only following some fixed number of 
 #   initial arguments which should be skipped. It might be used to 
 #   implement an API subcommand for an ensemble with parameters that 
 #   has the API dictionary as the final parameter. In that case, 
 #   one would map API to a command prefix
 #       ::API::nstatic $n
 #   where $n is one less than the number of ensemble parameters.
 #   
 #   The case $n==0 is equivalent to ::API::static.
 # 
 ##

proc ::API::nstatic {n args} {
    set dict [lindex $args $n]
    set args [lreplace $args 0 $n]
    if {[llength $args] == 0} then {
        return $dict
    } elseif {[llength $args] > 2} then {
        return -code error "Too many arguments!"
    }
    array set A $dict
    foreach {i version} $args {break}
    if {[llength $args] == 1} then {
        if {[info exists A($i)]} then {
            return $A($i)
        } else {
            return ""
        }
    } else {
        if {![info exists A($i)]} then {return 0}
        foreach hasver $A($i) {
            if {[package vsatisfies $hasver $version]} then {return 1}
        }
        return 0
    }
}


## 
 # ::API::staticn - basic API query handler in the presence of parameters
 # 
 # Synopsis:
 #   ::API::staticn $n $dict {*}$ignored ?$interface ?$version??
 #   
 #   dict       - Dictionary of supported interfaces and 
 #                versions.
 #   interface  - Name of interface to query about.
 #   version    - Version of interface to check support for.
 #   ignored    - Ignored arguments.
 #   n          - Number of arguments to ignore.
 # 
 # Result:
 #   Depending on the number of arguments specified, this 
 #   procedure returns the $dict, a list of versions, or a 
 #   boolean.
 #   
 # Usage:
 #   This is another minor variation of the static command, which has 
 #   the $dict before the ignored arguments rather than (as in the case 
 #   of nstatic) after them. It might be used to implement an API 
 #   subcommand for an ensemble with parameters that has the API 
 #   dictionary as first parameter; in that case, 
 #   one would map API to a command prefix
 #       ::API::nstatic $n
 #   where $n is one less than the number of ensemble parameters. 
 #   It might also be used to implement an API subcommand for an 
 #   ensemble with parameters that does not have the API dictionary as 
 #   a parameter; in that case, one would map API to a command prefix
 #       ::API::nstatic $n $dict
 #   where $n is the number of ensemble parameters. 
 #   
 #   The case $n==0 is equivalent to ::API::static.
 # 
 ##

proc ::API::staticn {n dict args} {
    set args [lrange $args $n end]
    if {[llength $args] == 0} then {
        return $dict
    } elseif {[llength $args] > 2} then {
        return -code error "Too many arguments!"
    }
    array set A $dict
    foreach {i version} $args {break}
    if {[llength $args] == 1} then {
        if {[info exists A($i)]} then {
            return $A($i)
        } else {
            return ""
        }
    } else {
        if {![info exists A($i)]} then {return 0}
        foreach hasver $A($i) {
            if {[package vsatisfies $hasver $version]} then {return 1}
        }
        return 0
    }
}


## 
 # ::API::recursive - recursive API query handler
 # 
 # Synopsis:
 #   ::API::recursive $APIargs $tests ?$key $prefix ...?
 #   
 #   APIargs  - Like $args list of ::API::static.
 #   tests    - Interfaces and named tests dictionary (see below)
 #   prefix   - Prefix for recursive API queries
 #   key      - Key associated with prefix
 # 
 # Result:
 #   Depending on the number of elements in $APIargs, this procedure 
 #   returns an interface dictionary, a list of versions, or a boolean.
 #   
 # Side-effects:
 #   None, unless scripts embedded in $tests have side-effects.
 #   
 # Details:
 #   The recursive command is meant to be called from within a procedure 
 #   body. It is sort of a control structure that aims to arrive at the 
 #   answer to an API query with as little work as possible, by using 
 #   demand-driven computation.
 #   
 #   The interface support is specified in the $tests nested dictionary. 
 #   The first level keys are interface names, whereas the second level 
 #   keys are versions. The second level values are *requirement scripts* 
 #   that state the conditions needed for that version of the interface 
 #   to be supported. Alternatively, the first level key can be the name 
 #   of a *test* (local to this $tests dictionary), in which case the first 
 #   level value is a list of length 1 having a requirement script as its 
 #   element.
 #   
 #   Requirement scripts are semantically lists of conditions to test, 
 #   but they are scripts in syntax, so items are newline (or semicolon) 
 #   separated, and standard Tcl comments are allowed. The supported 
 #   commands are
 #     API $key $interface $version ?$version ...?
 #     eval $script
 #     expr $expression
 #     try $script
 #     not $requirementsScript
 #     test $name
 #     self $interface $version
 #   The API command performs an API test for whether some $version of 
 #   the specified $interface is supported by the command prefix associated 
 #   with the $key in the call to ::API::recursive. The eval command evaluates 
 #   the $script in the calling context; it is supposed to return a boolean 
 #   where true means condition satisfied. The expr command is similar, 
 #   but evaluates an ::expr $expression instead of a script. The try 
 #   command evaluates a script, but looks at its return code rather than 
 #   its result: ok is success, anything else is fail.
 #   
 #   The not command processes its $requirementsScript, but negates the 
 #   outcome; the not condition is satisfied if any condition in the 
 #   $requirementsScript fails. (Two levels of not's can be used to 
 #   achieve logical or of two or more conditions.) The test command 
 #   uses the value of a named test. The self command queries the API being 
 #   computed, treating the $interface-$version combination as the composite 
 #   name of a test. (In particular the $version is compared by string 
 #   equality; it needs to be that exact version.)
 #   
 #   An example of a partial $tests dictionary is
 #     foo {1.0 {} 1.3 {test foo}}
 #     bar {1.0 {test foo; expr {$baz>3}}}
 #   which means:
 #     foo version 1.0 is always supported, 
 #     foo version 1.3 is supported if the test named foo is satisfied,
 #     bar version 1.0 is supported if the test named foo is satisfied
 #                        and additionally the $baz variable in the 
 #                        calling context is greater than 3.
 #   Whether a named test is satisfied is evaluated the first time that 
 #   test is referenced by a test requirements script command. The result 
 #   is then cached, which makes named tests appropriate when some set of 
 #   conditions is common for several different interface versions. 
 #   An example might be that in
 #     Tk {{
 #        try {package require Tk}
 #     }} colordisplay {{
 #        test Tk
 #        expr {[winfo screendepth .] > 1}
 #     }}
 #   the [package require Tk] call is performed at most once per 
 #   ::API::recursive call. Whether the [package require Tk] was done in 
 #   response to some interface referring to the colordisplay test or 
 #   directly to the Tk test is irrelevant.
 #   
 # Notes:
 #   The implementation is optimised for cases where individual 
 #   requirements are expensive to compute. If the satisfaction status 
 #   for an interface version can be deduced from previous computed 
 #   satisfaction statuses for other versions, then later requirement 
 #   scripts might be ignored.
 #   
 ##

proc ::API::recursive {APIargs tests args} {
    array set testA $tests
    array set prefixA $args
    array set testres {}
    # testres array entries are 0 for a failed test and 1 for a successful
    # test. There are three types of index:
    #  - a list "$test", caching the result for a named test.
    #  - a list "$interface $version", caching the result for a version 
    #    in the API being computed.
    #  - a list "$key $interface $version", caching the result
    #    of a recursive API call.
    
    # There are two main cases: Test for a specific version, or test 
    # for all versions.
    if {[llength $APIargs] > 1} then {
        if {
            ![info exists testA([lindex $APIargs 0])] ||
            1&[llength $testA([lindex $APIargs 0])]
        } then {return 0}
        set target [lindex $APIargs 1]
        foreach {version reqs} $testA([lindex $APIargs 0]) {
            if {[package vsatisfies $version $target] && (
                ![info exists best] || [package vsatisfies $best $version]
            )} then {
                set best $version
                set bestreq $reqs
            }
        }
        return [expr {[info exists best] && ![catch {
            recursive,parse eval $bestreq
        }]}]
    }
    # The area where there can be implications is within different versions 
    # of the same interface, so the code for handling that is common for 
    # the all interfaces and single interfaces case. To that end, the 
    # single interface case is handled by removing all other keys  
    # from the $interfaces dictionary.
    if {[llength $APIargs]} then {
        set interface [lindex $APIargs 0]
        if {
            ![info exists testA($interface)] ||
            1&[llength $testA($interface)]
        } then {return ""}
        set tests [list $interface $testA($interface)]
    } else {
        set res {}
    }
    foreach {interface verlist} $tests {
        # If the $verlist has odd length then this is a test,
        # so don't treat that here.
        if {1&[llength $verlist]} then {continue}
        # For each specific interface, the versions are tested in 
        # the order they are listed, and it is remembered which pass 
        # and which fail. Additional versions are first compared against 
        # those for which the result is known, to avoid evaulating 
        # a reqscript for which the result should already be known.
        set yesL {}
        set noL {}
        foreach {version reqs} $verlist {
            if {[info exists testres([list $interface $version])]} then {
                if {$testres([list $interface $version])} then {
                    lappend yesL $version
                } else {
                    lappend noL $version
                }
                continue
            }
            set known 0
            foreach ver $yesL {
                if {[package vsatisfies $ver $version]} then {
                    set known 1; break
                }
            }
            if {$known} then {
                set testres([list $interface $version]) 1
                continue
            }
            foreach ver $noL {
                if {[package vsatisfies $version $ver]} then {
                    set known 1; break
                }
            }
            if {$known} then {
                set testres([list $interface $version]) 0
                continue
            }
            if {[catch {
                recursive,parse eval $reqs
            }]} then {
                lappend noL $version
                set testres([list $interface $version]) 0
            } else {
                lappend yesL $version
                set testres([list $interface $version]) 1
            }
        }
        if {[llength $yesL]} then {
            lappend res $interface $yesL
        }
    }
    if {[llength $APIargs]} then {
        return $yesL
    } else {
        return $res
    }
}


## 
 # ::API::recursive,parse* - helpers for ::API::recursive
 # 
 # The various recursive,parse* commands are helpers that access the 
 # local context of ::API::recursive using upvar and uplevel. "uplevel 1" 
 # is the local context of ::API::recursive, whereas "uplevel 2" is the 
 # context from which ::API::recursive was called; the latter context is 
 # used by the "API", "eval", "expr", and "try" requirements commands.
 # 
 # ::API::recursive,parse itself is the slave command of an interp that 
 # is empty except for the six requirement script commands, which in 
 # turn are aliases back to corresponding ::API::recursive,parse_* commands. 
 # A requirements condition that is not satisfied will throw an error, 
 # thereby short-circuit testing of subsequent conditions. A requirements 
 # condition that is satisfied returns with a code of ok, allowing parsing 
 # to continue with the next condition. Thus what is done to parse a 
 # requirements script is to [::API::recursive,parse eval] it.
 # 
 # There are three arrays in the "uplevel 1" context which are used by 
 # ::API::recursive,parse_* commands, namely testA, prefixA, and testres. 
 # Recursive calls to the ::API::recursive,parse interpreter must be 
 # uplevel'ed so that these are in the local context (but note that 
 # local context levels are per interpreter, so the switches to and from 
 # ::API::recursive,parse interpreter are invisible in the uplevel counts).
 # 
 ##


interp create -safe ::API::recursive,parse
::API::recursive,parse hide namespace
::API::recursive,parse invokehidden namespace delete ::


::API::recursive,parse alias API ::API::recursive,parse_API
proc ::API::recursive,parse_API {key interface args} {
    upvar 1 prefixA prefixA testres testres
    foreach version $args {
        if {![info exists testres([list $key $interface $version])]} then {
            set testres([list $key $interface $version]) [
                uplevel 2 [linsert $prefixA($key) end API $interface $version]
            ]
        }
        if {$testres([list $key $interface $version])} then {return}
    }
    return -code error
}

::API::recursive,parse alias test ::API::recursive,parse_test
proc ::API::recursive,parse_test {name} {
    upvar 1 testA testA testres testres
    if {![info exists testres([list $name])]} then {
        set testres([list $name]) [expr {
            [info exists testA($name)] && 
            [llength $testA($name)]==1 && 
            ![catch {
                uplevel 1 [list\
                  ::API::recursive,parse eval [lindex $testA($name) 0]]
            }]
        }]
        # One could guard against circular test definitions 
        # by setting testres($data) to a non-boolean value before 
        # making the recursive call, but the recursionlimit should 
        # also catch such errors.
    }
    return -code [expr {!$testres([list $name])}]
}

::API::recursive,parse alias self ::API::recursive,parse_self
proc ::API::recursive,parse_self {name version} {
    upvar 1 testA testA testres testres
    if {![info exists testres([list $name $version])]} then {
        set testres([list $name $version]) [expr {
            [info exists testA($name)] && 
            !([llength $testA($name)]&1) && 
            [array set A $testA($name); info exists A($version)] &&
            ![catch {
                uplevel 1 [list ::API::recursive,parse eval $A($version)]
            }]
        }]
        # One could guard against circular test definitions 
        # by setting testres($data) to a non-boolean value before 
        # making the recursive call, but the recursionlimit should 
        # also catch such errors.
    }
    return -code [expr {!$testres([list $name $version])}]
}

::API::recursive,parse alias try uplevel 1

::API::recursive,parse alias eval ::API::recursive,parse_eval
proc ::API::recursive,parse_eval {script} {
    return -code [expr {![uplevel 2 $script]}]
}

::API::recursive,parse alias expr ::API::recursive,parse_expr
proc ::API::recursive,parse_expr {expression} {
    return -code [expr {![uplevel 2 [list ::expr $expression]]}]
}

::API::recursive,parse alias not ::API::recursive,parse_not
proc ::API::recursive,parse_not {script} {
    return -code [expr {![catch {
        uplevel 1 [list ::API::recursive,parse eval $script]
    }]}]
}
%</pkg>
%
%
\endinput