optparse.tcl

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

# optparse.tcl --
#
#       (Private) option parsing package
#
#       This might be documented and exported in 8.1
#       and some function hopefully moved to the C core for
#       efficiency, if there is enough demand. (mail! ;-)
#
#  Author:    Laurent Demailly  - [e-mail] - [e-mail]
#
#  Credits:
#             this is a complete 'over kill' rewrite by me, from a version
#             written initially with Brent Welch, itself initially
#             based on work with Steve Uhler. Thanks them !
#
# RCS: @(#) $Id: optparse.tcl 144 2003-02-05 10:56:26Z mdejong $

package provide opt 0.3

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
             Lassign Lvarpop Lvarset Lvarincr Lfirst \
             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 ! ###############
# You should really not look any further :
# The following is private unexported undocumented unblessed... code 
# time to hit "q" ;-) !

# Hmmm... ok, you really want to know ?

# You've been warned... Here it is...

    # 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 [Lfirst $program] >= 2
# while
#   llength [Lfirst $singleStep] == 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 compare $key ""] == 0} {
        # 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 [Lfirst $res];
        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 [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 namespace current];
    if {   ([string match $name "::*"]) 
        || ([string compare $namespace "::"]==0)} {
        # 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 [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} {
	Lfirst $lst;
    }
    # 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 {[Lfirst $item]=="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 [Lfirst $lst] 1 end] {
	    lappend res [Lget $lst $idx];
	}
	return $res;
    }

    # Advance to next description
    proc OptNextDesc {descName} {
        uplevel [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} {
        Lfirst $item
    }
    
    # current state
    proc OptCurState {descriptions} {
        OptState [OptCurDesc $descriptions];
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now
    proc OptCurrentArg {lst} {