# optparse.tcl --

#

#       (private) Option parsing package

#       Primarily used internally by the safe:: code.

#

#	WARNING: This code will go away in a future release

#	of Tcl.  It is NOT supported and you should not rely

#	on it.  If your code does rely on this package you

#	may directly incorporate this code into your application.

#

# RCS: @(#) $Id: optparse.tcl,v 1.8.2.1 2003/09/10 20:29:59 dgp Exp $

package require Tcl 8.2

# When this version number changes, update the pkgIndex.tcl file

# and the install directory in the Makefiles.

package provide opt 0.4.4.1

namespace eval ::tcl {

    # Exported APIs

    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \

             OptProc OptProcArgGiven OptParse \

	     Lempty Lget \

             Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \

             SetMax SetMin

#################  Example of use / 'user documentation'  ###################

    proc OptCreateTestProc {} {

	# Defines ::tcl::OptParseTest as a test proc with parsed arguments

	# (can't be defined before the code below is loaded (before "OptProc"))

	# Every OptProc give usage information on "procname -help".

	# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and

	# then other arguments.

	# 

	# example of 'valid' call:

	# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\

	#		-nostatics false ch1

	OptProc OptParseTest {

            {subcommand -choice {save print} "sub command"}

            {arg1 3 "some number"}

            {-aflag}

            {-intflag      7}

            {-weirdflag                    "help string"}

            {-noStatics                    "Not ok to load static packages"}

            {-nestedloading1 true           "OK to load into nested slaves"}

            {-nestedloading2 -boolean true "OK to load into nested slaves"}

            {-libsOK        -choice {Tk SybTcl}

		                      "List of packages that can be loaded"}

            {-precision     -int 12        "Number of digits of precision"}

            {-intval        7               "An integer"}

            {-scale         -float 1.0     "Scale factor"}

            {-zoom          1.0             "Zoom factor"}

            {-arbitrary     foobar          "Arbitrary string"}

            {-random        -string 12   "Random string"}

            {-listval       -list {}       "List value"}

            {-blahflag       -blah abc       "Funny type"}

	    {arg2 -boolean "a boolean"}

	    {arg3 -choice "ch1 ch2"}

	    {?optarg? -list {} "optional argument"}

        } {

	    foreach v [info locals] {

		puts stderr [format "%14s : %s" $v [set $v]]

	    }

	}

    }

###################  No User serviceable part below ! ###############

    # Array storing the parsed descriptions

    variable OptDesc;

    array set OptDesc {};

    # Next potentially free key id (numeric)

    variable OptDescN 0;

# Inside algorithm/mechanism description:

# (not for the faint hearted ;-)

#

# The argument description is parsed into a "program tree"

# It is called a "program" because it is the program used by

# the state machine interpreter that use that program to

# actually parse the arguments at run time.

#

# The general structure of a "program" is

# notation (pseudo bnf like)

#    name :== definition        defines "name" as being "definition" 

#    { x y z }                  means list of x, y, and z  

#    x*                         means x repeated 0 or more time

#    x+                         means "x x*"

#    x?                         means optionally x

#    x | y                      means x or y

#    "cccc"                     means the literal string

#

#    program        :== { programCounter programStep* }

#

#    programStep    :== program | singleStep

#

#    programCounter :== {"P" integer+ }

#

#    singleStep     :== { instruction parameters* }

#

#    instruction    :== single element list

#

# (the difference between singleStep and program is that \

#   llength [lindex $program 0] >= 2

# while

#   llength [lindex $singleStep 0] == 1

# )

#

# And for this application:

#

#    singleStep     :== { instruction varname {hasBeenSet currentValue} type 

#                         typeArgs help }

#    instruction    :== "flags" | "value"

#    type           :== knowType | anyword

#    knowType       :== "string" | "int" | "boolean" | "boolflag" | "float"

#                       | "choice"

#

# for type "choice" typeArgs is a list of possible choices, the first one

# is the default value. for all other types the typeArgs is the default value

#

# a "boolflag" is the type for a flag whose presence or absence, without

# additional arguments means respectively true or false (default flag type).

#

# programCounter is the index in the list of the currently processed

# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).

# If it is a list it points toward each currently selected programStep.

# (like for "flags", as they are optional, form a set and programStep).

# Performance/Implementation issues

# ---------------------------------

# We use tcl lists instead of arrays because with tcl8.0

# they should start to be much faster.

# But this code use a lot of helper procs (like Lvarset)

# which are quite slow and would be helpfully optimized

# for instance by being written in C. Also our struture

# is complex and there is maybe some places where the

# string rep might be calculated at great exense. to be checked.

#

# Parse a given description and saves it here under the given key

# generate a unused keyid if not given

#

proc ::tcl::OptKeyRegister {desc {key ""}} {

    variable OptDesc;

    variable OptDescN;

    if {[string equal $key ""]} {

        # in case a key given to us as a parameter was a number

        while {[info exists OptDesc($OptDescN)]} {incr OptDescN}

        set key $OptDescN;

        incr OptDescN;

    }

    # program counter

    set program [list [list "P" 1]];

    # are we processing flags (which makes a single program step)

    set inflags 0;

    set state {};

    # flag used to detect that we just have a single (flags set) subprogram.

    set empty 1;

    foreach item $desc {

	if {$state == "args"} {

	    # more items after 'args'...

	    return -code error "'args' special argument must be the last one";

	}

        set res [OptNormalizeOne $item];

        set state [lindex $res 0];

        if {$inflags} {

            if {$state == "flags"} {

		# add to 'subprogram'

                lappend flagsprg $res;

            } else {

                # put in the flags

                # structure for flag programs items is a list of

                # {subprgcounter {prg flag 1} {prg flag 2} {...}}

                lappend program $flagsprg;

                # put the other regular stuff

                lappend program $res;

		set inflags 0;

		set empty 0;

            }

        } else {

           if {$state == "flags"} {

               set inflags 1;

               # sub program counter + first sub program

               set flagsprg [list [list "P" 1] $res];

           } else {

               lappend program $res;

               set empty 0;

           }

       }

   }

   if {$inflags} {

       if {$empty} {

	   # We just have the subprogram, optimize and remove

	   # unneeded level:

	   set program $flagsprg;

       } else {

	   lappend program $flagsprg;

       }

   }

   set OptDesc($key) $program;

   return $key;

}

#

# Free the storage for that given key

#

proc ::tcl::OptKeyDelete {key} {

    variable OptDesc;

    unset OptDesc($key);

}

    # Get the parsed description stored under the given key.

    proc OptKeyGetDesc {descKey} {

        variable OptDesc;

        if {![info exists OptDesc($descKey)]} {

            return -code error "Unknown option description key \"$descKey\"";

        }

        set OptDesc($descKey);

    }

# Parse entry point for ppl who don't want to register with a key,

# for instance because the description changes dynamically.

#  (otherwise one should really use OptKeyRegister once + OptKeyParse

#   as it is way faster or simply OptProc which does it all)

# Assign a temporary key, call OptKeyParse and then free the storage

proc ::tcl::OptParse {desc arglist} {

    set tempkey [OptKeyRegister $desc];

    set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res];

    OptKeyDelete $tempkey;

    return -code $ret $res;

}

# Helper function, replacement for proc that both

# register the description under a key which is the name of the proc

# (and thus unique to that code)

# and add a first line to the code to call the OptKeyParse proc

# Stores the list of variables that have been actually given by the user

# (the other will be sets to their default value)

# into local variable named "Args".

proc ::tcl::OptProc {name desc body} {

    set namespace [uplevel 1 [list ::namespace current]];

    if {[string match "::*" $name] || [string equal $namespace "::"]} {

        # absolute name or global namespace, name is the key

        set key $name;

    } else {

        # we are relative to some non top level namespace:

        set key "${namespace}::${name}";

    }

    OptKeyRegister $desc $key;

    uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];

    return $key;

}

# Check that a argument has been given

# assumes that "OptProc" has been used as it will check in "Args" list

proc ::tcl::OptProcArgGiven {argname} {

    upvar Args alist;

    expr {[lsearch $alist $argname] >=0}

}

    #######

    # Programs/Descriptions manipulation

    # Return the instruction word/list of a given step/(sub)program

    proc OptInstr {lst} {

	lindex $lst 0;

    }

    # Is a (sub) program or a plain instruction ?

    proc OptIsPrg {lst} {

	expr {[llength [OptInstr $lst]]>=2}

    }

    # Is this instruction a program counter or a real instr

    proc OptIsCounter {item} {

	expr {[lindex $item 0]=="P"}

    }

    # Current program counter (2nd word of first word)

    proc OptGetPrgCounter {lst} {

	Lget $lst {0 1}

    }

    # Current program counter (2nd word of first word)

    proc OptSetPrgCounter {lstName newValue} {

	upvar $lstName lst;

	set lst [lreplace $lst 0 0 [concat "P" $newValue]];

    }

    # returns a list of currently selected items.

    proc OptSelection {lst} {

	set res {};

	foreach idx [lrange [lindex $lst 0] 1 end] {

	    lappend res [Lget $lst $idx];

	}

	return $res;

    }

    # Advance to next description

    proc OptNextDesc {descName} {

        uplevel 1 [list Lvarincr $descName {0 1}];

    }

    # Get the current description, eventually descend

    proc OptCurDesc {descriptions} {

        lindex $descriptions [OptGetPrgCounter $descriptions];

    }

    # get the current description, eventually descend

    # through sub programs as needed.

    proc OptCurDescFinal {descriptions} {

        set item [OptCurDesc $descriptions];

	# Descend untill we get the actual item and not a sub program

        while {[OptIsPrg $item]} {

            set item [OptCurDesc $item];

        }

	return $item;

    }

    # Current final instruction adress

    proc OptCurAddr {descriptions {start {}}} {

	set adress [OptGetPrgCounter $descriptions];

	lappend start $adress;

	set item [lindex $descriptions $adress];

	if {[OptIsPrg $item]} {

	    return [OptCurAddr $item $start];

	} else {

	    return $start;

	}

    }

    # Set the value field of the current instruction

    proc OptCurSetValue {descriptionsName value} {

	upvar $descriptionsName descriptions

	# get the current item full adress

        set adress [OptCurAddr $descriptions];

	# use the 3th field of the item  (see OptValue / OptNewInst)

	lappend adress 2

	Lvarset descriptions $adress [list 1 $value];

	#                                  ^hasBeenSet flag

    }

    # empty state means done/paste the end of the program

    proc OptState {item} {

        lindex $item 0

    }

    # current state

    proc OptCurState {descriptions} {

        OptState [OptCurDesc $descriptions];

    }

    #######

    # Arguments manipulation

    # Returns the argument that has to be processed now

    proc OptCurrentArg {lst} {

        lindex $lst 0;

    }

    # Advance to next argument

    proc OptNextArg {argsName} {

        uplevel 1 [list Lvarpop1 $argsName];

    }

    #######

    # Loop over all descriptions, calling OptDoOne which will

    # eventually eat all the arguments.

    proc OptDoAll {descriptionsName argumentsName} {

	upvar $descriptionsName descriptions

	upvar $argumentsName arguments;

#	puts "entered DoAll";

	# Nb: the places where "state" can be set are tricky to figure

	#     because DoOne sets the state to flagsValue and return -continue

	#     when needed...

	set state [OptCurState $descriptions];

	# We'll exit the loop in "OptDoOne" or when state is empty.

        while 1 {

	    set curitem [OptCurDesc $descriptions];

	    # Do subprograms if needed, call ourselves on the sub branch

	    while {[OptIsPrg $curitem]} {

		OptDoAll curitem arguments

#		puts "done DoAll sub";

		# Insert back the results in current tree;

		Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\

			$curitem;

		OptNextDesc descriptions;

		set curitem [OptCurDesc $descriptions];

                set state [OptCurState $descriptions];

	    }

#           puts "state = \"$state\" - arguments=($arguments)";

	    if {[Lempty $state]} {

		# Nothing left to do, we are done in this branch:

		break;

	    }

	    # The following statement can make us terminate/continue

	    # as it use return -code {break, continue, return and error}

	    # codes

            OptDoOne descriptions state arguments;

	    # If we are here, no special return code where issued,

	    # we'll step to next instruction :

#           puts "new state  = \"$state\"";

	    OptNextDesc descriptions;

	    set state [OptCurState $descriptions];

        }

    }

    # Process one step for the state machine,

    # eventually consuming the current argument.

    proc OptDoOne {descriptionsName stateName argumentsName} {

        upvar $argumentsName arguments;

        upvar $descriptionsName descriptions;

	upvar $stateName state;

	# the special state/instruction "args" eats all

	# the remaining args (if any)

	if {($state == "args")} {

	    if {![Lempty $arguments]} {

		# If there is no additional arguments, leave the default value

		# in.

		OptCurSetValue descriptions $arguments;

		set arguments {};

	    }

#            puts "breaking out ('args' state: consuming every reminding args)"

	    return -code break;

	}

	if {[Lempty $arguments]} {

	    if {$state == "flags"} {

		# no argument and no flags : we're done

#                puts "returning to previous (sub)prg (no more args)";

		return -code return;

	    } elseif {$state == "optValue"} {

		set state next; # not used, for debug only

		# go to next state

		return ;

	    } else {

		return -code error [OptMissingValue $descriptions];

	    }

	} else {

	    set arg [OptCurrentArg $arguments];

	}

        switch $state {

            flags {

                # A non-dash argument terminates the options, as does --

                # Still a flag ?

                if {![OptIsFlag $arg]} {

                    # don't consume the argument, return to previous prg

                    return -code return;

                }

                # consume the flag

                OptNextArg arguments;

                if {[string equal "--" $arg]} {

                    # return from 'flags' state

                    return -code return;

                }

                set hits [OptHits descriptions $arg];

                if {$hits > 1} {

                    return -code error [OptAmbigous $descriptions $arg]

                } elseif {$hits == 0} {

                    return -code error [OptFlagUsage $descriptions $arg]

                }

		set item [OptCurDesc $descriptions];

                if {[OptNeedValue $item]} {

		    # we need a value, next state is

		    set state flagValue;

                } else {

                    OptCurSetValue descriptions 1;

                }

		# continue

		return -code continue;

            }

	    flagValue -

	    value {

		set item [OptCurDesc $descriptions];

                # Test the values against their required type

		if {[catch {OptCheckType $arg\

			[OptType $item] [OptTypeArgs $item]} val]} {

		    return -code error [OptBadValue $item $arg $val]

		}

                # consume the value

                OptNextArg arguments;

		# set the value

		OptCurSetValue descriptions $val;

		# go to next state

		if {$state == "flagValue"} {

		    set state flags

		    return -code continue;

		} else {

		    set state next; # not used, for debug only

		    return ; # will go on next step

		}

	    }

	    optValue {

		set item [OptCurDesc $descriptions];

                # Test the values against their required type

		if {![catch {OptCheckType $arg\

			[OptType $item] [OptTypeArgs $item]} val]} {

		    # right type, so :

		    # consume the value

		    OptNextArg arguments;

		    # set the value

		    OptCurSetValue descriptions $val;

		}

		# go to next state

		set state next; # not used, for debug only

		return ; # will go on next step

	    }

        }

	# If we reach this point: an unknown

	# state as been entered !

	return -code error "Bug! unknown state in DoOne \"$state\"\

		(prg counter [OptGetPrgCounter $descriptions]:\

			[OptCurDesc $descriptions])";

    }

# Parse the options given the key to previously registered description

# and arguments list

proc ::tcl::OptKeyParse {descKey arglist} {

    set desc [OptKeyGetDesc $descKey];