optparse.tcl

linux 下的源代码分析阅读器 red hat公司新版

        Lfirst $lst;
    }
    # Advance to next argument
    proc OptNextArg {argsName} {
        uplevel [list Lvarpop $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 compare "--" $arg] == 0} {
                    # 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];

    # make sure -help always give usage
    if {[string compare "-help" [string tolower $arglist]] == 0} {
	return -code error [OptError "Usage information:" $desc 1];
    }

    OptDoAll desc arglist;

    if {![Lempty $arglist]} {
	return -code error [OptTooManyArgs $desc $arglist];
    }
    
    # Analyse the result
    # Walk through the tree:
    OptTreeVars $desc "#[expr {[info level]-1}]" ;
}

    # determine string length for nice tabulated output
    proc OptTreeVars {desc level {vnamesLst {}}} {
	foreach item $desc {
	    if {[OptIsCounter $item]} continue;
	    if {[OptIsPrg $item]} {
		set vnamesLst [OptTreeVars $item $level $vnamesLst];
	    } else {
		set vname [OptVarName $item];
		upvar $level $vname var
		if {[OptHasBeenSet $item]} {
#		    puts "adding $vname"
		    # lets use the input name for the returned list
		    # it is more usefull, for instance you can check that
		    # no flags at all was given with expr
		    # {![string match "*-*" $Args]}
		    lappend vnamesLst [OptName $item];
		    set var [OptValue $item];
		} else {
		    set var [OptDefaultValue $item];
		}
	    }
	}
	return $vnamesLst
    }


# Check the type of a value
# and emit an error if arg is not of the correct type
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
#    puts "checking '$arg' against '$type' ($typeArgs)";

    # only types "any", "choice", and numbers can have leading "-"

    switch -exact -- $type {
        int {
            if {![regexp {^(-+)?[0-9]+$} $arg]} {
                error "not an integer"
            }
	    return $arg;
        }
        float {
            return [expr {double($arg)}]
        }
	script -
        list {
	    # if llength fail : malformed list
            if {[llength $arg]==0} {
		if {[OptIsFlag $arg]} {
		    error "no values with leading -"
		}
	    }
	    return $arg;
        }
        boolean {
	    if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
		error "non canonic boolean"
            }
	    # convert true/false because expr/if is broken with "!,...
	    if {$arg} {
		return 1
	    } else {
		return 0
	    }
        }
        choice {
            if {[lsearch -exact $typeArgs $arg] < 0} {
                error "invalid choice"
            }
	    return $arg;
        }
	any {
	    return $arg;
	}
	string -
	default {
            if {[OptIsFlag $arg]} {
                error "no values with leading -"
            }
	    return $arg
        }
    }
    return neverReached;
}

    # internal utilities

    # returns the number of flags matching the given arg
    # sets the (local) prg counter to the list of matches
    proc OptHits {descName arg} {
        upvar $descName desc;
        set hits 0
        set hitems {}
	set i 1;

	set larg [string tolower $arg];
	set len  [string length $larg];
	set last [expr {$len-1}];

        foreach item [lrange $desc 1 end] {
            set flag [OptName $item]
	    # lets try to match case insensitively
	    # (string length ought to be cheap)
	    set lflag [string tolower $flag];
	    if {$len == [string length $lflag]} {
		if {[string compare $larg $lflag]==0} {
		    # Exact match case
		    OptSetPrgCounter desc $i;
		    return 1;
		}
	    } else {
		if {[string compare $larg [string range $lflag 0 $last]]==0} {
		    lappend hitems $i;
		    incr hits;
		}
            }
	    incr i;
        }
	if {$hits} {
	    OptSetPrgCounter desc $hitems;
	}
        return $hits
    }

    # Extract fields from the list structure:

    proc OptName {item} {
        lindex $item 1;
    }
    # 
    proc OptHasBeenSet {item} {
	Lget $item {2 0};
    }
    # 
    proc OptValue {item} {
	Lget $item {2 1};
    }

    proc OptIsFlag {name} {
        string match "-*" $name;
    }
    proc OptIsOpt {name} {
        string match {\?*} $name;
    }
    proc OptVarName {item} {
        set name [OptName $item];
        if {[OptIsFlag $name]} {
            return [string range $name 1 end];
        } elseif {[OptIsOpt $name]} {
	    return [string trim $name "?"];
	} else {
            return $name;
        }
    }
    proc OptType {item} {
        lindex $item 3
    }
    proc OptTypeArgs {item} {
        lindex $item 4
    }
    proc OptHelp {item} {
        lindex $item 5
    }
    proc OptNeedValue {item} {
        string compare [OptType $item] boolflag
    }
    proc OptDefaultValue {item} {
        set val [OptTypeArgs $item]
        switch -exact -- [OptType $item] {
            choice {return [lindex $val 0]}
	    boolean -
	    boolflag {
		# convert back false/true to 0/1 because expr !$bool
		# is broken..
		if {$val} {
		    return 1
		} else {
		    return 0
		}
	    }