pax_global_header00006660000000000000000000000064152641656050014524gustar00rootroot0000000000000052 comment=2071f82851eddd96112109aa925dfff19167145e RubyLane-parse_args-b4f953b/000077500000000000000000000000001526416560500160115ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/.github/000077500000000000000000000000001526416560500173515ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/.github/workflows/000077500000000000000000000000001526416560500214065ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/.github/workflows/release.yml000066400000000000000000000073211526416560500235540ustar00rootroot00000000000000name: Build and Release on: push: tags: ['v*'] jobs: build: runs-on: ubuntu-latest steps: - name: Install dependencies run: | sudo apt-get update sudo apt-get install -y ninja-build pandoc mingw-w64 wine64 zip pip3 install --user meson - uses: actions/checkout@v4 with: submodules: recursive - name: Build and test (native, meson fallback) run: | meson setup build meson compile -C build meson test -C build --print-errorlogs - name: Cross-compile for Windows run: | cat > /tmp/cross-mingw64.ini <<'EOF' [binaries] c = 'x86_64-w64-mingw32-gcc' cpp = 'x86_64-w64-mingw32-g++' ar = 'x86_64-w64-mingw32-ar' strip = 'x86_64-w64-mingw32-strip' windres = 'x86_64-w64-mingw32-windres' exe_wrapper = 'wine' pkg-config = 'pkg-config' [built-in options] default_library = 'shared' [properties] sys_root = '/usr/x86_64-w64-mingw32' pkg_config_libdir = '/nonexistent' [host_machine] system = 'windows' cpu_family = 'x86_64' cpu = 'x86_64' endian = 'little' EOF meson setup buildwin --cross-file /tmp/cross-mingw64.ini --buildtype=release -Ddebug=true meson compile -C buildwin - name: Test Windows build under wine run: meson test -C buildwin --print-errorlogs - name: Extract version id: version run: | ver=$(meson introspect build --projectinfo | python3 -c 'import sys,json; print(json.load(sys.stdin)["version"])') echo "version=${ver}" >> "$GITHUB_OUTPUT" echo "project=parse_args-${GITHUB_REF_NAME}" >> "$GITHUB_OUTPUT" - name: Create source tarball run: | project="${{ steps.version.outputs.project }}" # Generate README.md from docs meson compile -C build readme cp build/doc/README.md README.md # Copy workspace dereferencing symlinks, then strip build artifacts cp -aL . "/tmp/${project}" find "/tmp/${project}" -name '.git' -exec rm -rf {} + rm -rf "/tmp/${project}/.github" rm -rf "/tmp/${project}/build" "/tmp/${project}/buildwin" rm -rf "/tmp/${project}/subprojects/packagecache" rm -rf "/tmp/${project}/subprojects/tcl" rm -rf "/tmp/${project}/subprojects/libtommath-"* rm -rf "/tmp/${project}/subprojects/.wraplock" tar czf "/tmp/${project}.tar.gz" -C /tmp "${project}" cd /tmp && zip -rq "${project}-source.zip" "${project}" - name: Package Windows binaries run: | pkg_dir="parse_args-${{ steps.version.outputs.version }}" mkdir -p "/tmp/win/${pkg_dir}" cp buildwin/teabase/*parse_args.dll "/tmp/win/${pkg_dir}/" cp buildwin/teabase/pkgIndex.tcl "/tmp/win/${pkg_dir}/" cp buildwin/doc/parse_args.html "/tmp/win/${pkg_dir}/parse_args.html" cd /tmp/win zip -r "/tmp/${{ steps.version.outputs.project }}-windows-x86_64.zip" "${pkg_dir}" - name: Upload artifacts uses: actions/upload-artifact@v4 with: name: release-artifacts path: | /tmp/${{ steps.version.outputs.project }}.tar.gz /tmp/${{ steps.version.outputs.project }}-source.zip /tmp/${{ steps.version.outputs.project }}-windows-x86_64.zip - name: Create GitHub Release uses: softprops/action-gh-release@v1 with: draft: false prerelease: false generate_release_notes: true files: | /tmp/${{ steps.version.outputs.project }}.tar.gz /tmp/${{ steps.version.outputs.project }}-source.zip /tmp/${{ steps.version.outputs.project }}-windows-x86_64.zip RubyLane-parse_args-b4f953b/.gitignore000066400000000000000000000004441526416560500200030ustar00rootroot00000000000000*.swp *.o *.so pkgIndex.tcl Makefile core vgcore.* /configure /autom4te.cache /config.log /config.status /config.h doc/parse_args.n last prof tags *~ *.gcda *.gcno /build /buildwin /subprojects/.wraplock /subprojects/packagecache /subprojects/tcl /subprojects/libtommath-* /doc/parse_args.md RubyLane-parse_args-b4f953b/.gitmodules000066400000000000000000000001241526416560500201630ustar00rootroot00000000000000[submodule "teabase"] path = teabase url = https://github.com/cyanogilvie/teabase RubyLane-parse_args-b4f953b/LICENSE000066400000000000000000000041521526416560500170200ustar00rootroot00000000000000This software is copyrighted by the Ruby Lane, and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. RubyLane-parse_args-b4f953b/README.md000066400000000000000000000545361526416560500173050ustar00rootroot00000000000000# NAME parse_args - Core-style argument parsing for scripts # SYNOPSIS **package require parse_args** ?0.7.2? **parse_args::parse_args** *args* *argspec* ?*varname*? # DESCRIPTION The commands provided by the Tcl core follow a pattern of optional, named arguments (named with a leading “-” to indicate an option) in addition to positional arguments. They strongly prefer named arguments when the number of arguments and particularly optional arguments grows beyond about 3. Tcl scripts however have no access to standard argument parsing facilities to implement this pattern and have to build their named argument parsing machinery from scratch. This is slow to do in script, error prone, and creates noise in the code that distracts from the core task of the command implementation. This means that script-defined commands generally present half-baked argument handling APIs and tend to over-use positional arguments. This package aims to address this weakness by providing a robust argument parsing mechanism to script code that can implement the full set of patterns established by the core Tcl commands, is terse and readable to specify the arguments, and is fast enough to use in any situation. # COMMANDS **parse_args::parse_args** *args* *argspec* Parse the arguments supplied in *args* against the specification given in *argspec*, setting variables in the current scope as defined in the *argspec*. If the optional *varname* argument is supplied, it names a variable that will have a dictionary written to it containing the parsed arguments and no variables will be created for the arguments. See **ARGUMENT SPECIFICATION** below for the format of *argspec*. # ARGUMENT SPECIFICATION The syntax of the argument specification (given in the *argspec* argument to the **parse_args** command) is a dictionary, with the keys corresponding to the names by which the arguments will be available to the caller, either as variables created by the **parse_args** command or keys in the dictionary written to *varname* if that was specified. If the first character of the key is a “-” character it defines a named option, otherwise a positional parameter. Named options and positional parameters may be freely interleaved in the *argspec*: positional parameters are bound in the order they appear in it, and the order of the named options is irrelevant. (The arguments being parsed still need to supply any named options before the positional arguments - see **NAMED OPTION SCAN**.) Each key may only appear once: a repeated key is an error. Named options must be supplied exactly as they appear in the *argspec*: unlike **Tcl_GetIndexFromObj**, unique prefixes are not accepted. Like in proc argument definitions the name `args` is special and will consume all remaining arguments (after the leading positionals are bound and modulo any reservation for trailing **-required** positionals - see below for details); a positional may use **-args all** to opt into the same behaviour under a different name. The one difference is that `args`, like a proc’s `args`, has an implicit **-default** of the empty list, so it is always set, whereas a **-args all** positional that receives no arguments is left unset unless it has a **-default**. The values of the dictionary contain the definition of the corresponding argument, such as `-required`, which marks that argument as being required (whether a named or positional argument). The options that are available to define the argument are: **-default** *val* Provides a default value for the argument if it wasn’t supplied. Without this an argument that wasn’t supplied won’t have its corresponding variable (or dictionary key) set. *val* is permitted to be a value that is outside of the range of possible values that would be accepted from the caller, by design. **-required** If this boolean option is given, the argument is flagged as required. Failing to supply the arg causes the **parse_args** to throw an exception similar to what would happen if a required positional argument to a proc was not provided. **-validate** *cmdprefix* Append the value supplied for this argument to the *cmdprefix* and run it. The value is rejected if an exception is thrown or the value returned isn’t a Tcl boolean true value. **-name** *newname* Change the name of the variable / dictionary key that will receive the value for this argument to *newname*. By default the name will be the argspec key (without the leading “-” for named arguments). **-boolean** Flag this argument as a boolean, similar to **-nocase** to `regexp`. The variable will always be defined and be a boolean, true if the argument was supplied and false if it wasn’t. Only valid for named options; using **-boolean** on a positional argument raises an error at spec compile time. **-args** *count* By default named arguments consume a single following argument as the value for that argument. This setting changes that to *count*, which will cause the following *count* arguments to be gathered into the variable holding this argument. If *count* is the special value “all”, then all remaining arguments are gathered into a list as the value of this argument. A negative *count* is an error, and a *count* of 0 is only valid for named options (equivalent to **-boolean**); using **-args 0** on a positional argument raises an error at spec compile time. **-enum** *possible_values* Restrict the values that will be accepted for this argument to those in the *possible_values* list. Similar to using a validator that checks for inclusion in that list but with additional internal performance optimizations. **-#** *free_form_text* Embed a comment for this argument. The supplied *free_form_text* is ignored by **parse_args** and serves only to document the argument to programmers reading the code. In some future version this text may be incorporated into a usage error message that is generated when argument parsing fails. **-multi** Group a set of defined arguments together, so they act like mutually exclusive flags. Used to implement patterns like the arguments `-ascii`, `-dictionary`, `-integer` and `-real` arguments to the core **lsort** command. *name* will be the name of the variable that holds the flag that was supplied, without its leading “-” (so `-integer` gives `integer`). A **-default** setting on any of the linked **-multi** arguments (those that share a *name*) will supply a default value in *name* if none were passed. A **-required** setting on any of the linked **-multi** arguments will require that the caller supply at least one of them. If multiple different flags were given, the one last in the argument list applies, unless **-all** was specified (on any linked option), in which case all instances are grouped as a list in *name*, in the order they were specified. **-multi** is only valid for named options, and can’t be combined with **-enum**; either raises an error at spec compile time. **-alias** Treat the value supplied for this argument as a variable name and bind the resulting variable for this argument to the variable of that name in the call frame above this one (upvar 1). Not supported when a *varname* is given (dictionary mode), where it raises an error. **-all** Collect all the instances of this argument as a list, rather than the default behaviour of using the last instance as the value. **-end** Treat the remaining arguments as if **--** directly followed this option - that is: all words in *args* after those consumed by the current option are treated as positional arguments. # NAMED OPTION SCAN Named options are recognised by scanning the arguments from the start. The scan ends, and all the remaining arguments are bound to positional parameters, at the first of: - An argument that doesn’t start with “-” (including the empty string). - The argument `--`, which is consumed (it isn’t bound to any positional). Only the first `--` is special: a later one is an ordinary value. - The arguments consumed by an option marked **-end**. - The arguments reserved for trailing **-required** positionals. These are the last *n* arguments, where *n* is the total number of arguments the **-required** positionals (without a **-default**) need. They are never treated as options, even if they look like one. For example, with the *argspec* `{-x {} name {-required}}`, the arguments `-foo` and `-x 1 -foo` both set `name` to `-foo`, but `-foo bar` is an unknown option error. If the *argspec* defines no named options, there is no scan at all: every argument is positional, including any that start with “-”, and `--` is an ordinary value rather than a separator. So `parse_args {-foo} {name {-required}}` sets `name` to `-foo`, and `parse_args {--} {name {}}` sets `name` to `--`. An argument within the scan that starts with “-” and isn’t `--` must be a named option from the *argspec*, otherwise it’s an error (see **ERRORS**). To pass a positional value that may start with “-” to a command that has named options, callers should precede it with `--`. # POSITIONAL BINDING Positional parameters are bound left-to-right with one element of forward lookahead. Each positional **p** is processed in order: - If **p** is `args` (or has **-args all**): *p* consumes all remaining input arguments, except that arguments needed to satisfy any *later* **-required** positionals are reserved for them. If after that reservation *p* would consume zero arguments and it has no **-default** (`args` always has one), the variable for *p* is left unset. - If **p** is **-required** (without a **-default**): *p* consumes its *max(1, arg_count)* arguments. If too few input arguments remain to satisfy this it is a usage error. - Otherwise (optional, or **-required** with a **-default**): *p* consumes its *arg_count* arguments only when at least *arg_count* + (count needed for later **-required** positionals) arguments remain. Otherwise *p*’s **-default** is applied (if any) and consumption skips to the next positional. This means optional positionals between or before **-required** positionals are skipped automatically when the caller supplies just enough arguments to satisfy the **-required** ones, rather than greedily filling the optional and erroring on the missing required. An *argspec* may contain at most one `args`/**-args all** positional, and any positional that follows it must be **-required** without a **-default**. The string representation of an input argument is generated only for arguments that fall within the named-option scan (see **NAMED OPTION SCAN**). Arguments reserved for trailing **-required** positionals, and all arguments when the *argspec* has no named options, are bound by position only and never have their first character inspected. So shimmer-hostile values, such as large pure bytearrays whose string form is expensive to generate, pass through without being converted. # ERRORS An invalid *argspec* is reported when it is first compiled, which is the first time it is used to parse arguments (or the first time after it has lost its internal representation). Usage errors are reported with these errorcodes: `TCL LOOKUP INDEX option` *name* *name* (which starts with “-” and is in the named-option scan) isn’t a named option in the *argspec*. The message lists the valid options, as for **Tcl_GetIndexFromObj**. `TCL LOOKUP INDEX` *option* *value* *value* isn’t one of the **-enum** values for *option*. `TCL WRONGARGS` More arguments were supplied than the *argspec* can bind, or a named option was missing its value(s). The message is a usage generated from the *argspec*, in the usual **wrong \# args: should be** form but without a command name, since **parse_args** can’t know which name is right (it may be parsing a proc’s *args*, values passed into a resumed coroutine, a script’s *argv*, …). A caller that wants one can add it when handling the error. `PARSE_ARGS REQUIRED` *name* The **-required** argument *name* wasn’t supplied. `PARSE_ARGS REQUIRED_ONE_OF` *names* None of the **-multi** group *names*, one of which is **-required**, was supplied. `PARSE_ARGS WRONGARGS` *name* Too few arguments remained to fill the **-required** positional *name*, which has **-args** *count* greater than 1. `PARSE_ARGS VALIDATION` *name* The **-validate** command prefix rejected the value supplied for *name*. # C API The same argument parsing is available to C code, through a Tcl stubs table. A separately compiled extension depends on **parse_args** (pkg-config or meson **dependency(‘parse_args’)**, which supply **-DUSE_PARSE_ARGS_STUBS=1** and the stub library), includes **parse_args.h** and calls **ParseArgs_InitStubs**(*interp*) in its Init. Code compiled by **jitc** with a **package {parse_args 0.7.2}** part calls the functions directly. int **ParseArgs_BindDict**(*interp*, *argspec*, *objc*, *objv*, *dictPtr*) Bind *objc*/*objv* against the *argspec* Tcl_Obj, as the **parse_args** command does with a *varname*, leaving the result dict in \**dictPtr* (which must point to NULL or an object reference, which is replaced: **replace_tclobj** semantics). int **ParseArgs_Bind**(*interp*, *argspec*, *objc*, *objv*, *cb*, *cdata*) Bind *objc*/*objv* against the *argspec* Tcl_Obj, calling *cb*(*cdata*, *interp*, *decl_idx*, *name*, *val*) for each value bound. *decl_idx* is the index of the *argspec* entry that the value is for, counting both options and positional parameters in the order they appear in *argspec* (or -1 for the value of a **-multi** group), and *name* is its output name. *val* is only guaranteed to be valid during the callback. int **ParseArgs_BindSlots**(*interp*, *cachePtr*, *specstr*, *objc*, *objv*, *slotc*, *slots*) Bind *objc*/*objv* against the *argspec* in \**cachePtr*, which is created from the string *specstr* when \**cachePtr* is NULL (and kept there, with a reference held, for the caller to release), or for this call only if *cachePtr* is NULL. Each value is converted as directed by *slots*\[*decl_idx*\], which must have an entry for each *argspec* entry, and stored at its *addr*. A reference to the value is kept in the slot’s *hold* member (which must initially be NULL), keeping pointers into it valid until the caller releases it with **ParseArgs_ReleaseSlots**(*slotc*, *slots*). **-multi** and **-alias** are not supported. This is the mechanism behind **parseargs_bind.def**. All three leave an error message (and errorcode, as for **parse_args**) in the interp result on failure. ## parseargs_bind.def **parseargs_bind.def** declares and binds a struct local in a C command implementation, from an X-macro that declares the *argspec*: ``` c static int foo(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( special, "-boolean", BOOL ) \ ARG( a1, "-required", STRING ) \ ARG( a2, "-default 42", INT ) \ ARG( a3, "-required", WIDEINT ) \ /* line intentionally left blank */ #include // args.special, args.a1, args.a2, args.a3 ... return TCL_OK; } ``` Each entry is **OPT**(*name*, *settings*, *type*) for an option (**-**\_name\_) or **ARG**(*name*, *settings*, *type*) for a positional parameter. *name* is both the C struct member and the *argspec* name (so options are limited to names that are valid C identifiers), *settings* is a string literal with the *argspec* settings for the entry, and *type* selects the member’s C type and the conversion: | *type* | Member(s) | Conversion | |-------------|----------------------------------------------------|---------------------------------------------------------| | **OBJ** | Tcl_Obj\* *name* | The value itself (NULL if not supplied) | | **BOOL** | bool *name* | Tcl_GetBooleanFromObj | | **INT** | int *name* | Tcl_GetIntFromObj | | **WIDEINT** | Tcl_WideInt *name* | Tcl_GetWideIntFromObj | | **DOUBLE** | double *name* | Tcl_GetDoubleFromObj | | **STRING** | const char\* *name* | Tcl_GetString | | **BYTES** | const unsigned char\* *name*, Tcl_Size *name*\_len | Tcl_GetBytesFromObj | | **LIST** | Tcl_Size *name*c, Tcl_Obj\*\* *name*v | Tcl_ListObjGetElements (for **-args** *n* and **args**) | | **INDEX** | int *name* | Index of the value in the entry’s **-enum** choices | | **SKIP** | (none) | Not stored | Further types can be added by defining **PARSEARGS_OUTTYPE\_**\_type\_(*name*) (the member declaration) and **PARSEARGS_SLOTFOR\_**\_type\_(*out*, *name*) (the **struct ParseArgs_Slot** initializer, using **PARSEARGS_SLOT_CUSTOM** and a converter function). Members for entries that are not supplied and have no **-default** are left zeroed. Values are held until the struct goes out of scope, so pointer members stay valid until then. The release is done with **defer**, so the code including **parseargs_bind.def** must be compiled as C23 with **defer** support (as **jitc** cdefs are). These macros may be defined before the include to override the defaults, and are all undefined afterwards: **PARSEARGS_OUT** The name of the struct local, default **args**. **PARSEARGS_INTERP**, **PARSEARGS_OBJC**, **PARSEARGS_OBJV** Defaults **interp**, **objc-1** and **objv+1**. **PARSEARGS_CACHE** A **Tcl_Obj\*\*** in which to cache the compiled *argspec* across calls, or NULL to build it for each call. The default, **((Tcl_Obj\*\*)cdata)**, is the per-binding slot that **jitc::bind** provides as the ClientData of a jitc **OBJCMD** (and jitc releases it when the command is deleted). Under **jitc::capply** cdata is NULL, so the *argspec* is built for each call. Other code must supply its own slot, and release it. **PARSEARGS_ON_ERROR** The statement to run when binding fails, default **return TCL_ERROR**. # EXAMPLES Mimic the argument handling of the core `glob` command: ``` tcl proc glob args { parse_args::parse_args $args { -directory {} -join {-boolean} -nocomplain {-boolean} -path {} -tails {-boolean} -types {-default {}} args {-name patterns} } if {$join} { set patterns [list [file join {*}$patterns]] } if {[llength $patterns] == 0 && $nocomplain} return foreach pattern $patterns { if {[info exists directory]} { ... } } ... } ``` Mimic `regex`: ``` tcl proc regexp args { parse_args::parse_args $args { -about {-boolean} -expanded {-boolean} -indices {-boolean} -line {-boolean} -linestop {-boolean} -lineanchor {-boolean} -nocase {-boolean} -all {-boolean} -inline {-boolean} -start {-default 0} exp {-required} string {-required} matchvar {} args {-name submatchvars} } ... } ``` `lsort`: ``` tcl proc lsort args { parse_args::parse_args $args { -ascii {-name compare_as -multi -default ascii} -dictionary {-name compare_as -multi} -integer {-name compare_as -multi} -real {-name compare_as -multi} -command {} -increasing {-name order -multi -default increasing} -decreasing {-name order -multi} -indices {-boolean} -index {} -stride {-default 1} -nocase {-boolean} -unique {-boolean} list {-required} } if {![info exists command]} { switch -- $compare_as { ascii { set command {string compare} if {$nocase} { lappend command -nocase } } dictionary { ... } integer - real { set command tcl::mathop::- } } } } ``` `lsearch`: ``` tcl proc lsearch args { parse_args::parse_args $args { -exact {-name matchtype -multi} -glob {-name matchtype -multi -default glob} -regexp {-name matchtype -multi} -sorted {-boolean} -all {-boolean} -inline {-boolean} -not {-boolean} -start {-default 0} -ascii {-name compare_as -multi -default ascii} -dictionary {-name compare_as -multi} -integer {-name compare_as -multi} -real {-name compare_as -multi} -nocase {-boolean} -decreasing {-name order -multi} -increasing {-name order -multi -default increasing} -bisect {-boolean} -index {} -subindices {-boolean} } if {$sorted && $matchtype in {glob regexp}} { error "-sorted is mutually exclusive with -glob and -regexp" } } ``` A Tk widget - `entry`: ``` tcl proc entry {widget args} { parse_args::parse_args $args { -disabledbackground {-default {}} -disabledforeground {-default {}} -invalidcommand {-default {}} -readonlybackground {-default {}} -show {} -state {-default normal -enum { normal disabled readonly }} -validate {-default none -enum { none focus focusin focusout key all }} -validatecommand {-default {}} -width {-default 0} -textvariable {} } } ``` # SEE ALSO The paper presented at the 2016 Tcl Conference which discusses the approach and design choices made in this package in much greater depth: https://www.tcl-lang.org/community/tcl2016/assets/talk33/parse_args-paper.pdf # BUGS Please open an issue on the github tracker for the project if you encounter any problems: https://github.com/RubyLane/parse_args/issues # LICENSE This package is Copyright 2015-2026 Cyan Ogilvie, and is made available under the same license terms as the Tcl Core RubyLane-parse_args-b4f953b/bench/000077500000000000000000000000001526416560500170705ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/bench/parse_args.bench000066400000000000000000000372061526416560500222270ustar00rootroot00000000000000if {"bench" ni [info commands bench]} { package require bench namespace import bench::* } package require parse_args namespace import ::parse_args::* bench parse_args-1.1 {Parsing options} -batch 1000 -setup { #<<< set args { -title "Do the terms vintage and antique have the same meaning?" -category {"Shop Owners" "Item Listing Information"} -wiki {Most authorities consider the term ''''antique'''' to mean an age of at least '''100 years'''. If an item is not definitively datable to 100 or more years in age, it should not be directly referred to as an antique. The term ''''vintage'''' is applicable to a wider variety of objects, including items that may or may not be antique. As a general rule, vintage should not be used in reference to an object less than '''20 years''' old, and the object should be somewhat representational and recognizable as belonging to the era in which it was made.} } proc parse_args_tcl_uncached {arglist spec {dictvar {}}} { #<<< if {$dictvar ne ""} { upvar 1 $dictvar d } set seen {} set positional_names {} set settings [dict map {k v} $spec { set s {} if {[string index $k 0] eq "-"} { for {set j 0} {$j < [llength $v]} {incr j} { switch -- [lindex $v $j] { -default - -validate - -name - -args { if {$j >= [llength $v]-1} { error "[lindex $v $j] requires an argument" } dict set s [string range [lindex $v $j] 1 end] [lindex $v [incr j]] } -boolean { dict set s boolean 1 } -required { dict set s required 1 } default { error "Invalid arg spec option \"[lindex $v $j]\"" } } } if {![dict exists $s boolean]} { dict set s boolean 0 } if {![dict exists $s required]} { dict set s required 0 } if {![dict exists $s name]} { dict set s name [string range $k 1 end] } } else { for {set j 0} {$j < [llength $v]} {incr j} { switch -- [lindex $v $j] { -default - -validate - -name - -required { dict set s required 1 } default { error "Invalid arg spec option \"[lindex $v $j]\"" } } } if {![dict exists $s boolean]} { dict set s boolean 0 } if {![dict exists $s required]} { dict set s required 0 } if {![dict exists $s name]} { dict set s name $k } lappend positional_names $k } set s }] set p_i 0 set check_options 1 for {set i 0} {$i < [llength $arglist]} {incr i} { set arg [lindex $arglist $i] if {$check_options} { if {$arg eq "--"} { set check_options 0 continue } if {[string index $arglist 0] eq "-"} { if {![dict exists $spec $arg]} { error "Invalid option: \"$arg\"" } set s [dict get $settings $arg] if {[dict get $s boolean] && [dict exists $s args] && [dict get $s args] != 0} { error "-boolean options cannot have -args greater than 0" } if {[dict get $s boolean]} { set v 1 } else { if {![dict exists $s args]} { dict set s args 1 } if {[llength $arglist] - $i - 1 < [dict get $s args]} { error "option $arg requires [dict get $s args], but [expr {[llength $argslist] - $i - 1}] remain" } switch -- [dict get $s args] { 0 {set v 1} 1 {set v [lindex $arglist [incr i]]} default { set v [lrange $arglist $i+1 [expr { $i + [dict get $s args] - 1 }] incr i [dict get $s args] } } } # TODO: validate dict set d [dict get $s name] $v dict set seen $arg 1 continue } else { set check_options 0 } } if {$p_i >= [llength $positional_names]} { error "Too many arguments for positional params: [join $positional_names {, }]" } set pname [lindex $positional_names $p_i] set s [dict get $settings $pname] if {$p_i == [llength $positional_names]-1 && $pname eq "args"} { dict set d [dict get $s name] [lrange $arglist $i+1 end] set i [expr {[llength $arglist] - 1}] } else { # TODO: validate dict set d [dict get $s name] $arg } incr p_i } # Check -required and set -default for options that weren't specified dict for {k v} $spec { if {[string index $k 0] ne "-"} continue if {[dict exists $seen $k]} continue if {[dict get $settings $k default]} { dict set d [dict get $settings $k name] [dict get $settings $k default] } elseif {[dict get $settings $k required]} { error "option \"$k\" is required" } } # Set default values for positional params that need them foreach pname [lrange $positional_names $p_i end] { set s [dict get $settings $pname] if {[dict exists $s default]} { dict set d [dict get $s name] [dict get $s default] } else { error "argument $pname is required" } } if {$dictvar eq ""} { dict for {k v} $d { uplevel 1 [list set $k $v] } } } #>>> proc get_parsed_spec spec { #<<< global __spec_cache if {![info exists __spec_cache] || ![dict exists $__spec_cache $spec]} { set positional_names {} set settings [dict map {k v} $spec { set s {} if {[string index $k 0] eq "-"} { for {set j 0} {$j < [llength $v]} {incr j} { switch -- [lindex $v $j] { -default - -validate - -name - -args { if {$j >= [llength $v]-1} { error "[lindex $v $j] requires an argument" } dict set s [string range [lindex $v $j] 1 end] [lindex $v [incr j]] } -boolean { dict set s boolean 1 } -required { dict set s required 1 } default { error "Invalid arg spec option \"[lindex $v $j]\"" } } } if {![dict exists $s boolean]} { dict set s boolean 0 } if {![dict exists $s required]} { dict set s required 0 } if {![dict exists $s name]} { dict set s name [string range $k 1 end] } } else { for {set j 0} {$j < [llength $v]} {incr j} { switch -- [lindex $v $j] { -default - -validate - -name - -required { dict set s required 1 } default { error "Invalid arg spec option \"[lindex $v $j]\"" } } } if {![dict exists $s boolean]} { dict set s boolean 0 } if {![dict exists $s required]} { dict set s required 0 } if {![dict exists $s name]} { dict set s name $k } lappend positional_names $k } set s }] dict set __spec_cache $spec [list $settings $positional_names] } dict get $__spec_cache $spec } #>>> proc parse_args_tcl {arglist spec {dictvar {}}} { #<<< if {$dictvar ne ""} { upvar 1 $dictvar d } set seen {} lassign [get_parsed_spec $spec] settings positional_names set p_i 0 set check_options 1 for {set i 0} {$i < [llength $arglist]} {incr i} { set arg [lindex $arglist $i] if {$check_options} { if {$arg eq "--"} { set check_options 0 continue } if {[string index $arglist 0] eq "-"} { if {![dict exists $spec $arg]} { error "Invalid option: \"$arg\"" } set s [dict get $settings $arg] if {[dict get $s boolean] && [dict exists $s args] && [dict get $s args] != 0} { error "-boolean options cannot have -args greater than 0" } if {[dict get $s boolean]} { set v 1 } else { if {![dict exists $s args]} { dict set s args 1 } if {[llength $arglist] - $i - 1 < [dict get $s args]} { error "option $arg requires [dict get $s args], but [expr {[llength $argslist] - $i - 1}] remain" } switch -- [dict get $s args] { 0 {set v 1} 1 {set v [lindex $arglist [incr i]]} default { set v [lrange $arglist $i+1 [expr { $i + [dict get $s args] - 1 }] incr i [dict get $s args] } } } # TODO: validate dict set d [dict get $s name] $v dict set seen $arg 1 continue } else { set check_options 0 } } if {$p_i >= [llength $positional_names]} { error "Too many arguments for positional params: [join $positional_names {, }]" } set pname [lindex $positional_names $p_i] set s [dict get $settings $pname] if {$p_i == [llength $positional_names]-1 && $pname eq "args"} { dict set d [dict get $s name] [lrange $arglist $i+1 end] set i [expr {[llength $arglist] - 1}] } else { # TODO: validate dict set d [dict get $s name] $arg } incr p_i } # Check -required and set -default for options that weren't specified dict for {k v} $spec { if {[string index $k 0] ne "-"} continue if {[dict exists $seen $k]} continue if {[dict get $settings $k default]} { dict set d [dict get $settings $k name] [dict get $settings $k default] } elseif {[dict get $settings $k required]} { error "option \"$k\" is required" } } # Set default values for positional params that need them foreach pname [lrange $positional_names $p_i end] { set s [dict get $settings $pname] if {[dict exists $s default]} { dict set d [dict get $s name] [dict get $s default] } else { error "argument $pname is required" } } if {$dictvar eq ""} { dict for {k v} $d { uplevel 1 [list set $k $v] } } } #>>> proc tcl_vars args { parse_args_tcl $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } list $title $category $wiki $rating } proc tcl_dict args { parse_args_tcl $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } d list [dict get $d title] [dict get $d category] [dict get $d wiki] [dict get $d rating] } proc tcl_dict_with args { parse_args_tcl $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } d dict with d {} list $title $category $wiki $rating } proc native {t_a title c_a category w_a wiki {r_a rating} {rating 1.0}} { list $title $category $wiki $rating } proc c_vars args { parse_args $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } list $title $category $wiki $rating } proc c_dict args { parse_args $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } d list [dict get $d title] [dict get $d category] [dict get $d wiki] [dict get $d rating] } proc c_dict_with args { parse_args $args { -title {-required} -category {-default {}} -wiki {-required} -rating {-default 1.0 -validate {string is double -strict}} } d dict with d {} list $title $category $wiki $rating } } -compare { tcl_vars { tcl_vars {*}$args } tcl_dict { tcl_dict {*}$args } tcl_dict_with { tcl_dict_with {*}$args } native { native {*}$args } c_vars { c_vars {*}$args } c_dict { c_dict {*}$args } c_dict_with { c_dict_with {*}$args } } -cleanup { foreach p {parse_args_tcl_uncached get_parsed_spec tcl_vars tcl_dict tcl_dict_with native c_vars c_dict c_dict_with} { rename $p {} } unset -nocomplain args d title category wiki rating __spec_cache } -result {{Do the terms vintage and antique have the same meaning?} {"Shop Owners" "Item Listing Information"} {Most authorities consider the term ''''antique'''' to mean an age of at least '''100 years'''. If an item is not definitively datable to 100 or more years in age, it should not be directly referred to as an antique. The term ''''vintage'''' is applicable to a wider variety of objects, including items that may or may not be antique. As a general rule, vintage should not be used in reference to an object less than '''20 years''' old, and the object should be somewhat representational and recognizable as belonging to the era in which it was made.} 1.0} #>>> bench enum-1.1 {enum validate} -batch 1000 -setup { #<<< proc tcl {state validate} { if {$state ni {normal disabled readonly}} { throw [list TCL LOOKUP INDEX state $state] "bad state \"$state\": must be normal, disabled, or readonly" } if {$validate ni {none focus focusin focusout key all}} { throw [list TCL LOOKUP INDEX validate $validate] "bad validate \"$validate\": must be none, focus, focusin, focusout, key, or all" } list $state $validate } proc p args { parse_args $args { state {-enum {normal disabled readonly}} validate {-enum {none focus focusin focusout key all}} } list $state $validate } set state readonly set validate focusout } -compare { tcl { tcl $state $validate} parse_args { p $state $validate } } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p state validate } -result {readonly focusout} #>>> bench overhead-1.1 {nop overhead} -batch 1000 -setup { #<<< proc tcl args { set args ;# Prevent Tcl from optimizing out the call entirely } proc p args { parse_args $args { } set args } } -compare { tcl tcl parse_args p } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p } -result {} #>>> bench validate-1.1 {validation, succeeds} -batch 1000 -setup { #<<< proc tcl rating { list [catch { if {![string is double -strict $rating]} { error "Validation failed for \"rating\": 0" } set rating } r o] $r } proc p args { list [catch { parse_args $args { rating {-validate {string is double -strict}} } set rating } r o] $r } } -compare { tcl { tcl 1.2 } parse_args { p 1.2 } } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p } -result [list 0 1.2] #>>> bench validate-1.2 {validation, fails} -batch 1000 -setup { #<<< proc tcl rating { list [catch { if {![string is double -strict $rating]} { error "Validation failed for \"rating\": 0" } set rating } r o] $r } proc p args { list [catch { parse_args $args { rating {-validate {string is double -strict}} } set rating } r o] $r } } -compare { tcl { tcl x1.2 } parse_args { p x1.2 } } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p } -result [list 1 "Validation failed for \"rating\": 0"] #>>> bench multi-1.1 {multi} -batch 1000 -setup { #<<< proc tcl args { foreach arg $args { switch -- $arg { -ascii - -dictionary - -integer - -real { set compare_as [string range $arg 1 end] } } } if {![info exists compare_as]} { set compare_as ascii } set compare_as } proc p args { parse_args $args { -ascii {-multi -name compare_as -default ascii} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -real {-multi -name compare_as} } set compare_as } } -compare { tcl {tcl -dictionary} parse_args {p -dictionary} } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p } -result dictionary #>>> bench multi-1.2 {multi, default} -batch 1000 -setup { #<<< proc tcl args { foreach arg $args { switch -- $arg { -ascii - -dictionary - -integer - -real { set compare_as [string range $arg 1 end] } } } if {![info exists compare_as]} { set compare_as ascii } set compare_as } proc p args { parse_args $args { -ascii {-multi -name compare_as -default ascii} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -real {-multi -name compare_as} } set compare_as } } -compare { tcl tcl parse_args p } -cleanup { foreach p {tcl p} {rename $p {}} unset -nocomplain p } -result ascii #>>> # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/claude/000077500000000000000000000000001526416560500172465ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/claude/skills/000077500000000000000000000000001526416560500205475ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/claude/skills/using-parse-args/000077500000000000000000000000001526416560500237365ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/claude/skills/using-parse-args/SKILL.md000066400000000000000000000337411526416560500251460ustar00rootroot00000000000000--- name: using-parse-args description: Parse proc arguments in Tcl with the parse_args package - core-style named options (-flag, -opt value), positional parameters, defaults, -required, -enum, -validate, mutually exclusive -multi flag groups, -all, -alias (upvar) and -end passthrough - and the exact rules for where option scanning stops and how positionals bind. Also covers the C API (ParseArgs_Bind*, parseargs_bind.def for jitc). Use when writing or reviewing Tcl code that calls parse_args::parse_args, when designing a Tcl proc's argument interface, or when the user mentions parse_args or argspecs. --- # parse_args `parse_args::parse_args args argspec ?varname?` parses a list of words against a dict-shaped *argspec*. It sets variables in the caller's frame, or, when given *varname*, writes a dict to that variable instead. It is implemented in C and compiles and caches the argspec on the argspec object, so it is fast enough to use in any proc. ```tcl package require parse_args namespace import parse_args::parse_args ;# optional, the command is exported proc fetch args { parse_args $args { -timeout {-default 30 -validate {string is integer -strict}} -method {-default GET -enum {GET HEAD POST PUT DELETE}} -headers {-default {}} -follow {-boolean} -body {} url {-required} } if {[info exists body]} { ... } ;# options with no -default may be unset ... } fetch -method POST -body $json -follow https://example.com/ ``` Keys starting with `-` are named options, and all other keys are positional parameters. Positionals bind in argspec order. The order of options in the argspec doesn't matter, and options and positionals may be interleaved in it. The caller still has to supply all options before any positionals. A key may appear only once. ## Per-argument settings | Setting | Meaning | |---|---| | `-default v` | Value when not supplied. **Not** checked by `-validate`/`-enum` (intentionally may be out of range, e.g. `{}` as a "not given" sentinel). | | `-required` | Error if not supplied. Combined with `-default` it can never fail, so it's effectively just optional. | | `-boolean` | Options only. Always set: `1` if the flag is present, `0` if not. Takes no value word. (`-args 0` is the same thing.) | | `-args n` | Consume *n* words and set a list of them. `-args all` consumes the rest, so the remaining words aren't scanned for options. | | `-name v` | Variable/dict key to use instead of the key (minus `-`). | | `-enum list` | Value must be one of these. **Exact match, no prefixes.** Error: `bad -s "x": must be a or b`. | | `-validate cmdprefix` | `{*}cmdprefix $value` must return a true boolean (or `""`), and must not throw. | | `-multi` | Options only: mutually exclusive flag group (see below). | | `-all` | Repeated option collects a list of every value instead of last-wins. | | `-alias` | Value is a variable name in the caller's caller, which gets bound by `upvar 1`. | | `-end` | After this option (and its value), stop option scanning; the rest is positional. | | `-# text` | Comment, ignored. | Unknown settings, `-boolean`/`-multi`/`-args 0` on a positional, and a spec with an odd number of words are errors **when the spec is first used**, not when the proc is defined. So exercise every proc at least once in a test. ## Unset vs set: what you get back - If an argument is not supplied and has no `-default`, its variable is **left unset**, and in dict mode the key is absent. Test with `info exists`/`dict exists`. `-boolean` arguments are always set. - A positional named `args` has an implicit `-default {}`, so it is always set, as for a proc. A positional using `-args all` under another name is left **unset** when it gets no words, unless you give it `-default {}`. - parse_args only *sets* variables, it never unsets them. If a local already exists, for example because the proc set it before calling parse_args, or because parse_args runs repeatedly in a loop or coroutine, then an omitted argument without a default keeps its **old value**. Use `-default`, or `unset -nocomplain` first, when re-parsing in the same frame. - If two options share a `-name` without `-multi`, the later one silently wins. Don't do that. ## Where option scanning stops (the subtle part) Options are recognised by scanning from the first word. The scan stops at the first of these: 1. A word that doesn't start with `-`. This includes `""`, and that word is the first positional. 2. `--`. It is consumed. Only the first one is special; a later `--` is an ordinary value. 3. The end of the words consumed by an option marked `-end`. 4. **The reserved tail**: the last *n* words, where *n* is the total number of words needed by `-required` positionals that have no `-default`. These are never treated as options, even when they look like one. Inside the scan, any word starting with `-` must be an exact option name. Otherwise it's an error: `bad option "-foo": must be -a, -b, or -c`, with errorcode `TCL LOOKUP INDEX option -foo`. **Prefix abbreviations are not accepted** (`-dir` is not `-directory`). A value-taking option consumes the next word whatever it looks like: `-x -y` sets x to `-y`, and `-x --` sets x to `--`. **If the argspec has no options at all, there is no scan.** Every word is positional, including `-foo` and `--`: ```tcl parse_args {-foo} {name {-required}} ;# name = -foo parse_args {--} {name {}} ;# name = -- parse_args {-- -foo} {name {-required}} ;# error: wrong # args (-- is a value, not a separator) ``` The reserved tail, with argspec `{-x {} name {-required}}`: ```tcl parse_args {-foo} $spec ;# name = -foo (the reserved tail word is never an option) parse_args {-x 1 -foo} $spec ;# x = 1, name = -foo parse_args {-foo bar} $spec ;# error: bad option "-foo" (-foo is in the scan, bar is the tail) parse_args {-- -foo} $spec ;# name = -foo ``` **Practical rule for callers:** when a positional value might start with `-` (user data, file names, negative numbers) and the command has options, pass `--` before it: `mycmd -opt v -- $value`. For a command with exactly one trailing `-required` positional this isn't needed, because the tail is reserved anyway. Writing `--` is still harmless and clearer. For the proc author, a spec with only `-required` trailing positionals (the `regexp`/`lsort` shape) is robust to leading-dash values. Optional positionals and `args` are not reserved, so their values are exposed to the scan. ## Positional binding Positionals are processed left to right, with lookahead for the `-required` positionals still to come: - **`-required` without a default** consumes 1 word, or *n* for `-args n`. If too few words are left, the error is `argument b is required` (`PARSE_ARGS REQUIRED b`), not `wrong # args`. - **Optional** (including `-required -default`) consumes its words only if enough are left over for all later required positionals. Otherwise it gets its default, or stays unset. Optional positionals therefore get **skipped**, rather than greedily filled and then failing: ```tcl parse_args {1 2} {a {} b {-required} c {-required}} ;# b=1 c=2, a unset parse_args {1 2 3} {a {} b {-required} c {-required}} ;# a=1 b=2 c=3 ``` - **`args` / `-args all`** takes everything except what later required positionals need, so `{a {} args {} z {-required}}` with `1 2 3 4` gives a=1, args={2 3}, z=4. - There can be at most one `args`/`-args all` positional, and every positional after it must be `-required` with no `-default`. Any other layout is a spec error. - Leftover words give `wrong # args: should be "?a? ?b?"` (`TCL WRONGARGS`). - Options after the first positional are *not* options. They are bound as positional values, or are an arity error: `parse_args {x -a 1} {-a {} p {} args {}}` gives p=x, args={-a 1}. ## Mutually exclusive flags: -multi Options sharing a `-name` and marked `-multi` form a group. The variable holds the **name of the flag given, without its `-`**: ```tcl parse_args $args { -ascii {-name compare_as -multi -default ascii} -dictionary {-name compare_as -multi} -integer {-name compare_as -multi} -increasing {-name order -multi -default increasing} -decreasing {-name order -multi} list {-required} } # lsort-like: [mysort -integer -decreasing $l] gives compare_as=integer, order=decreasing ``` - `-default` or `-required` on **any** member applies to the group. A required group that gets no member fails with `one of -ascii -dictionary -integer are required` (`PARSE_ARGS REQUIRED_ONE_OF {...}`). - If several members are given, the last one wins, as for lsort. With `-all` on any member, the variable is the list of all members given, in order. Use that to enforce strict exclusivity yourself: `if {[llength $matchtype] > 1} {error "only one of -exact, -glob, -regexp"}`. - `-multi` can't be combined with `-enum`, and is only valid on options. Don't combine it with `-args`. Mutual exclusion is about *which* flag was given; if a member needs a value, use separate options and check in code. - In 0.7.1 and earlier, a group with `-all` ignored its `-default`. ## Validators `-validate` evaluates `{*}$cmdprefix $value` **in the proc's own frame**, so `upvar 1`/`uplevel 1` in the validator reach the proc's locals, and unqualified command names resolve in the proc's namespace. The value passes if the result is a true boolean or the empty string. A false result, a non-boolean result or an error rejects it, with `Validation failed for "-n": ` (`PARSE_ARGS VALIDATION -n`). The validator's own error code is not kept. - For `-args n`, `-args all` and `args`, the validator gets the **whole list** once. - With `-all`, it is called once **per occurrence**. - It is never called for a `-default`. - `-enum` is checked before `-validate`. - In 0.7.1 and earlier, a `-validate` on an `-args n`, `-args all` or `args` argument could crash the interpreter (use-after-free) unless the validator kept a reference to the value. If you must support old versions, avoid validators on multi-word arguments. A false result gives an unhelpful message, `Validation failed for "-port": 0`. For user-facing commands, make the validator **throw** a descriptive error instead; its message is used as the reason: ```tcl -start {-default 0 -validate {apply {v { if {!([string is integer -strict $v] && $v >= 0)} {error "must be a non-negative integer"} }}}} # -start -1 gives Validation failed for "-start": must be a non-negative integer ``` Short idioms: ```tcl -port {-validate {string is integer -strict}} -count {-validate {apply {v {expr {[string is integer -strict $v] && $v > 0}}}}} -file {-validate {file readable}} ``` ## Other patterns **Collect repeats:** `-header {-args 2 -all}` with `-header a 1 -header b 2` gives header=`{{a 1} {b 2}}`. **Variable-name arguments** (like `-textvariable`): `-var {-alias}` makes `$var` an `upvar 1` link to the named variable in the proc's caller, and `-alias` works on positionals too. **Not supported in dict mode.** There, supplying the argument raises `-alias is not yet supported in dictionary mode` (errorcode `NONE`). Leaving it out is not an error. **Wrapper passthrough with -end:** let the wrapper take its own options, then pass everything after a marker option through untouched: ```tcl proc wrap args { parse_args $args { -verbose {-boolean} --args {-boolean -end -name passthru} rest {-args all -default {}} } inner {*}$rest } wrap -verbose --args -x 1 foo ;# verbose=1, rest={-x 1 foo} ``` `-args all` on an *option* has the same effect: `-cmd {-args all}`. **Dict mode** (third argument) is useful for forwarding or inspecting the parsed set: `parse_args $args $spec opts`, then `dict exists $opts timeout`. `-boolean` keys are always present. No variables are created. **Mixed signature:** `proc entry {widget args} { parse_args $args {...} }` is fine. Fixed leading parameters stay ordinary proc parameters. **Scripts:** `parse_args $argv {...}` at global level sets globals. ## Errors | errorcode | When | message | |---|---|---| | `TCL LOOKUP INDEX option -x` | unknown option in the scan | `bad option "-x": must be -a` / `-a or -b` / `-a, -b, or -c` | | `TCL LOOKUP INDEX -opt val` | `-enum` mismatch | `bad -opt "val": must be ...` | | `TCL WRONGARGS` | too many words, or an option missing its value | `wrong # args: should be "?-x x? a ?b?"` | | `PARSE_ARGS REQUIRED -x` / `PARSE_ARGS REQUIRED b` | required option / positional missing | `option -x is required` / `argument b is required` | | `PARSE_ARGS REQUIRED_ONE_OF {...}` | required `-multi` group missing | | | `PARSE_ARGS WRONGARGS name` | required positional with `-args n>1` given some but too few words | `Expecting 2 arguments for name` | | `PARSE_ARGS VALIDATION name` | `-validate` rejected | | | `NONE` | bad argspec (on first use) | `Cannot use -boolean on positional argument "a"` etc. | The `wrong # args` usage string has **no command name**, because parse_args can't know it. Add the name if you want one: ```tcl try { parse_args $args $spec } trap {TCL WRONGARGS} {msg} { return -code error -errorcode {TCL WRONGARGS} \ [string map [list "should be \"" "should be \"[lindex [info level 0] 0] "] $msg] } ``` ## Performance - Write the argspec as a **literal** in the proc body. The compiled form is cached on the argspec object, and a literal keeps it for the life of the proc. Building the spec per call (`[list ...]`, `[subst ...]`, `"..."` with substitutions) recompiles it on every call. If it has to be computed, compute it once into a namespace variable and pass that. - Words in the reserved tail, and all words when the spec has no options, are never converted to strings. This makes large binary (bytearray) values safe to pass positionally without shimmering. ## C API C extensions and jitc cdefs can bind with the same semantics via `ParseArgs_BindDict`, `ParseArgs_Bind`, `ParseArgs_BindSlots` and the `parseargs_bind.def` X-macro, which gives you a typed struct of the args. See [c-api.md](c-api.md). RubyLane-parse_args-b4f953b/claude/skills/using-parse-args/c-api.md000066400000000000000000000176101526416560500252560ustar00rootroot00000000000000# parse_args C API The C API uses the same argspec semantics as the Tcl command: the scan rules, positional binding and errors in SKILL.md all apply. On failure, every function leaves the error message and errorcode in the interp result and returns `TCL_ERROR`. ## Getting at it - **Separately compiled extension (stubs):** use pkg-config, or in meson `dependency('parse_args')`. Either supplies `-DUSE_PARSE_ARGS_STUBS=1` and the stub library. `#include `, then in Init, after `Tcl_InitStubs`: ```c if (ParseArgs_InitStubs(interp) == NULL) return TCL_ERROR; ``` - **jitc cdef:** add the part `package {parse_args 0.7}`. The functions are linked directly, with no InitStubs needed, and `parseargs_bind.def` is on the include path. ## Functions ```c int ParseArgs_BindDict(Tcl_Interp*, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Obj** dictPtr); ``` This is the same as `parse_args $args $argspec dictvar`. `*dictPtr` must be NULL or a held reference. It is replaced with **replace_tclobj** semantics: the new dict is held for you, and you must release it. ```c typedef int (ParseArgs_BindCallback)(void* cdata, Tcl_Interp*, Tcl_Size decl_idx, Tcl_Obj* name, Tcl_Obj* val); int ParseArgs_Bind(Tcl_Interp*, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], ParseArgs_BindCallback* cb, void* cdata); ``` The callback runs once per bound value, including defaults and `0` for unsupplied `-boolean`s. - `decl_idx` is the index of the argspec entry, counting options and positionals together in argspec order. It is `-1` for a `-multi` group's value. - `name` is the output name: the `-name` setting, or the key without its `-`. - `val` is only valid during the callback, so take a reference to keep it. - Returning non-`TCL_OK` aborts the bind. Keep the `argspec` Tcl_Obj alive across calls, for example in your command's ClientData. The compiled spec is cached on it, and a fresh object per call recompiles it every time. ```c int ParseArgs_BindSlots(Tcl_Interp*, Tcl_Obj** cachePtr, const char* specstr, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Size slotc, struct ParseArgs_Slot slots[]); static inline void ParseArgs_ReleaseSlots(Tcl_Size slotc, struct ParseArgs_Slot slots[]); ``` This is the engine behind `parseargs_bind.def`, and you rarely call it directly. - If `*cachePtr` is NULL, the spec is built from `specstr` and stored there, with a reference that the caller must eventually release. If `cachePtr` itself is NULL, the spec is built just for this call. - `slots[decl_idx]` says how to convert each value. Every argspec entry must have a slot. - Each slot's `hold` must start NULL. Afterwards it keeps the value alive, so that pointers into it stay valid until `ParseArgs_ReleaseSlots`. - **`-multi` and `-alias` are not supported.** Using them is an error, e.g. `-multi is not supported by ParseArgs_BindSlots`. ## parseargs_bind.def: a typed struct of the arguments The usual way to parse args in C. Define an X-macro, then include the `.def` file **inside the function body**: A complete minimal jitc example: ```tcl package require jitc 0.8 set cdef { options {-Wall} package {parse_args 0.7} code { #include OBJCMD(scale) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( factor, "-default 1.0", DOUBLE ) \ OPT( round, "-boolean", BOOL ) \ ARG( value, "-required", DOUBLE ) \ /* line intentionally left blank */ #include double r = args.value * args.factor; Tcl_SetObjResult(interp, Tcl_NewDoubleObj(args.round ? round(r) : r)); return TCL_OK; } } } jitc::bind scale $cdef scale ;# argspec compiled once, cached in the binding scale -factor 2.5 -round 3 ;# 8.0 ``` A fuller example, with every kind of member: ```c OBJCMD(fetch) { // jitc (in an extension: a Tcl_ObjCmdProc body) #define PARSEARGS_SPEC(OPT, ARG) \ OPT( verbose, "-boolean", BOOL ) \ OPT( timeout, "-default 30", INT ) \ OPT( method, "-default GET -enum {GET POST}", INDEX ) \ OPT( body, "", BYTES ) \ ARG( url, "-required", STRING ) \ ARG( args, "", LIST ) \ /* line intentionally left blank */ #include // args.verbose args.timeout args.method (0|1) args.body/args.body_len // args.url args.argsc/args.argsv return TCL_OK; } ``` - **Entries.** `OPT(name, settings, type)` declares the option `-name`, and `ARG(name, settings, type)` a positional. *name* is both the struct member and the argspec key, so it must be a valid C identifier. Options can't contain `-` beyond the leading one. - **Settings.** *settings* is a C string literal of the usual parse_args settings, and gets wrapped in `{...}` in the generated argspec. Use `""` for none. - **The trailing line.** End the macro with a blank or comment line, so the last `\` continuation is harmless. | type | member(s) | conversion | |---|---|---| | `OBJ` | `Tcl_Obj* name` (NULL if not supplied) | the value, borrowed but held | | `BOOL` | `bool name` | Tcl_GetBooleanFromObj | | `INT` | `int name` | Tcl_GetIntFromObj | | `WIDEINT` | `Tcl_WideInt name` | Tcl_GetWideIntFromObj | | `DOUBLE` | `double name` | Tcl_GetDoubleFromObj | | `STRING` | `const char* name` | Tcl_GetString | | `BYTES` | `const unsigned char* name; Tcl_Size name_len` | Tcl_GetBytesFromObj | | `LIST` | `Tcl_Size namec; Tcl_Obj** namev` | list elements, for `-args n`, `-args all` and `args` | | `INDEX` | `int name` | index into the entry's `-enum` list | | `SKIP` | none | not stored | - **Unsupplied entries.** An entry that isn't supplied and has no `-default` is left **zeroed** (NULL, 0 or false). Unlike Tcl there's no "unset" state, so to tell "not given" from "given 0", use `OBJ`, which is NULL when not given, or add a sentinel `-default`. - **Conversion errors.** A failed conversion, such as `INT` given `abc`, fails the bind with Tcl's usual message. - **Lifetime.** Pointer members (STRING, BYTES, LIST, OBJ) stay valid until the struct goes out of scope. They are released with **`defer`**, so the code must be C23 with defer support. jitc has it. Extensions can use teabase's `defer.h`, built with `-DHAVE_NATIVE_DEFER` / `-DHAVE_DEFER_POLYFILL` as detected. - **Several binds in one function.** You can include the `.def` more than once in different functions. Every `PARSEARGS_*` setting is `#undef`'d after each include. Overridable before the include (all are reset afterwards): | macro | default | notes | |---|---|---| | `PARSEARGS_OUT` | `args` | name of the struct local | | `PARSEARGS_INTERP` | `interp` | | | `PARSEARGS_OBJC` / `PARSEARGS_OBJV` | `objc-1` / `objv+1` | skip the command name; adjust for subcommands (`objc-2`/`objv+2`) | | `PARSEARGS_CACHE` | `((Tcl_Obj**)cdata)` | where the compiled argspec is cached | | `PARSEARGS_ON_ERROR` | `return TCL_ERROR` | e.g. `goto done` for cleanup paths | **`PARSEARGS_CACHE` gotcha.** The default suits jitc. `jitc::bind` gives each `OBJCMD` a per-binding `Tcl_Obj*` slot as its cdata, and releases it when the command is deleted. Under `jitc::capply`, cdata is NULL, so the spec is rebuilt on each call, which is correct but slower. **In a hand-written extension where cdata is something else, you must define `PARSEARGS_CACHE`.** Point it at your own `Tcl_Obj*` (initialised to NULL, and released when the command is deleted), or use `NULL` to rebuild each call. Otherwise your cdata gets scribbled on. **Custom types:** define `PARSEARGS_OUTTYPE_(name)` (the member declaration) and `PARSEARGS_SLOTFOR_(out, name)` (a `struct ParseArgs_Slot` initializer using `PARSEARGS_SLOT_CUSTOM`, a converter `int conv(void* cdata, Tcl_Interp*, Tcl_Obj* val, void* addr)` and its cdata). RubyLane-parse_args-b4f953b/doc/000077500000000000000000000000001526416560500165565ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/doc/.vimrc000066400000000000000000000000161526416560500176740ustar00rootroot00000000000000set expandtab RubyLane-parse_args-b4f953b/doc/meson.build000066400000000000000000000023711526416560500207230ustar00rootroot00000000000000pandoc = find_program('pandoc', native: true, required: false) if pandoc.found() doc_md = configure_file( input: 'parse_args.md.in', output: '@BASENAME@', configuration: teaconf, ) doc_targets = [] doc_targets += custom_target('htmldoc', input: doc_md, output: 'parse_args.html', command: [pandoc, '--standalone', '--metadata', 'title=parse_args', '--from', 'markdown', '--to', 'html', '@INPUT@', '--output', '@OUTPUT@'], install: true, install_dir: get_option('datadir') / 'doc', build_by_default: true, ) doc_targets += custom_target('manpage', input: doc_md, output: 'parse_args.n', command: [pandoc, '--standalone', '--from', 'markdown', '--to', 'man', '@INPUT@', '--output', '@OUTPUT@'], install: true, install_dir: get_option('mandir'), build_by_default: true, ) doc_targets += custom_target('readme', input: doc_md, output: 'README.md', command: [pandoc, '--from', 'markdown', '--to', 'gfm', '@INPUT@', '--output', '@OUTPUT@'], install_dir: meson.project_source_root(), install_tag: 'source', build_by_default: false, ) alias_target('doc', doc_targets) endif RubyLane-parse_args-b4f953b/doc/parse_args.md.in000066400000000000000000000540221526416560500216360ustar00rootroot00000000000000% parse_args(3) @PACKAGE_VERSION@ | Advanced argument parsing for Tcl % Cyan Ogilvie % @PACKAGE_VERSION@ # NAME parse\_args - Core-style argument parsing for scripts # SYNOPSIS **package require parse_args** ?@PACKAGE_VERSION@? **parse_args::parse_args** *args* *argspec* ?*varname*? # DESCRIPTION The commands provided by the Tcl core follow a pattern of optional, named arguments (named with a leading "-" to indicate an option) in addition to positional arguments. They strongly prefer named arguments when the number of arguments and particularly optional arguments grows beyond about 3. Tcl scripts however have no access to standard argument parsing facilities to implement this pattern and have to build their named argument parsing machinery from scratch. This is slow to do in script, error prone, and creates noise in the code that distracts from the core task of the command implementation. This means that script-defined commands generally present half-baked argument handling APIs and tend to over-use positional arguments. This package aims to address this weakness by providing a robust argument parsing mechanism to script code that can implement the full set of patterns established by the core Tcl commands, is terse and readable to specify the arguments, and is fast enough to use in any situation. # COMMANDS **parse_args::parse_args** *args* *argspec* : Parse the arguments supplied in *args* against the specification given in *argspec*, setting variables in the current scope as defined in the *argspec*. If the optional *varname* argument is supplied, it names a variable that will have a dictionary written to it containing the parsed arguments and no variables will be created for the arguments. See **ARGUMENT SPECIFICATION** below for the format of *argspec*. # ARGUMENT SPECIFICATION The syntax of the argument specification (given in the *argspec* argument to the **parse_args** command) is a dictionary, with the keys corresponding to the names by which the arguments will be available to the caller, either as variables created by the **parse_args** command or keys in the dictionary written to *varname* if that was specified. If the first character of the key is a "-" character it defines a named option, otherwise a positional parameter. Named options and positional parameters may be freely interleaved in the *argspec*: positional parameters are bound in the order they appear in it, and the order of the named options is irrelevant. (The arguments being parsed still need to supply any named options before the positional arguments - see **NAMED OPTION SCAN**.) Each key may only appear once: a repeated key is an error. Named options must be supplied exactly as they appear in the *argspec*: unlike **Tcl_GetIndexFromObj**, unique prefixes are not accepted. Like in proc argument definitions the name `args` is special and will consume all remaining arguments (after the leading positionals are bound and modulo any reservation for trailing **-required** positionals - see below for details); a positional may use **-args all** to opt into the same behaviour under a different name. The one difference is that `args`, like a proc's `args`, has an implicit **-default** of the empty list, so it is always set, whereas a **-args all** positional that receives no arguments is left unset unless it has a **-default**. The values of the dictionary contain the definition of the corresponding argument, such as `-required`, which marks that argument as being required (whether a named or positional argument). The options that are available to define the argument are: **-default** *val* : Provides a default value for the argument if it wasn't supplied. Without this an argument that wasn't supplied won't have its corresponding variable (or dictionary key) set. *val* is permitted to be a value that is outside of the range of possible values that would be accepted from the caller, by design. **-required** : If this boolean option is given, the argument is flagged as required. Failing to supply the arg causes the **parse_args** to throw an exception similar to what would happen if a required positional argument to a proc was not provided. **-validate** *cmdprefix* : Append the value supplied for this argument to the *cmdprefix* and run it. The value is rejected if an exception is thrown or the value returned isn't a Tcl boolean true value. **-name** *newname* : Change the name of the variable / dictionary key that will receive the value for this argument to *newname*. By default the name will be the argspec key (without the leading "-" for named arguments). **-boolean** : Flag this argument as a boolean, similar to **-nocase** to `regexp`. The variable will always be defined and be a boolean, true if the argument was supplied and false if it wasn't. Only valid for named options; using **-boolean** on a positional argument raises an error at spec compile time. **-args** *count* : By default named arguments consume a single following argument as the value for that argument. This setting changes that to *count*, which will cause the following *count* arguments to be gathered into the variable holding this argument. If *count* is the special value "all", then all remaining arguments are gathered into a list as the value of this argument. A negative *count* is an error, and a *count* of 0 is only valid for named options (equivalent to **-boolean**); using **-args 0** on a positional argument raises an error at spec compile time. **-enum** *possible_values* : Restrict the values that will be accepted for this argument to those in the *possible_values* list. Similar to using a validator that checks for inclusion in that list but with additional internal performance optimizations. **-#** *free_form_text* : Embed a comment for this argument. The supplied *free_form_text* is ignored by **parse_args** and serves only to document the argument to programmers reading the code. In some future version this text may be incorporated into a usage error message that is generated when argument parsing fails. **-multi** : Group a set of defined arguments together, so they act like mutually exclusive flags. Used to implement patterns like the arguments `-ascii`, `-dictionary`, `-integer` and `-real` arguments to the core **lsort** command. *name* will be the name of the variable that holds the flag that was supplied, without its leading "-" (so `-integer` gives `integer`). A **-default** setting on any of the linked **-multi** arguments (those that share a *name*) will supply a default value in *name* if none were passed. A **-required** setting on any of the linked **-multi** arguments will require that the caller supply at least one of them. If multiple different flags were given, the one last in the argument list applies, unless **-all** was specified (on any linked option), in which case all instances are grouped as a list in *name*, in the order they were specified. **-multi** is only valid for named options, and can't be combined with **-enum**; either raises an error at spec compile time. **-alias** : Treat the value supplied for this argument as a variable name and bind the resulting variable for this argument to the variable of that name in the call frame above this one (upvar 1). Not supported when a *varname* is given (dictionary mode), where it raises an error. **-all** : Collect all the instances of this argument as a list, rather than the default behaviour of using the last instance as the value. **-end** : Treat the remaining arguments as if **\-\-** directly followed this option - that is: all words in *args* after those consumed by the current option are treated as positional arguments. # NAMED OPTION SCAN Named options are recognised by scanning the arguments from the start. The scan ends, and all the remaining arguments are bound to positional parameters, at the first of: * An argument that doesn't start with "-" (including the empty string). * The argument `--`, which is consumed (it isn't bound to any positional). Only the first `--` is special: a later one is an ordinary value. * The arguments consumed by an option marked **-end**. * The arguments reserved for trailing **-required** positionals. These are the last *n* arguments, where *n* is the total number of arguments the **-required** positionals (without a **-default**) need. They are never treated as options, even if they look like one. For example, with the *argspec* `{-x {} name {-required}}`, the arguments `-foo` and `-x 1 -foo` both set `name` to `-foo`, but `-foo bar` is an unknown option error. If the *argspec* defines no named options, there is no scan at all: every argument is positional, including any that start with "-", and `--` is an ordinary value rather than a separator. So `parse_args {-foo} {name {-required}}` sets `name` to `-foo`, and `parse_args {--} {name {}}` sets `name` to `--`. An argument within the scan that starts with "-" and isn't `--` must be a named option from the *argspec*, otherwise it's an error (see **ERRORS**). To pass a positional value that may start with "-" to a command that has named options, callers should precede it with `--`. # POSITIONAL BINDING Positional parameters are bound left-to-right with one element of forward lookahead. Each positional **p** is processed in order: * If **p** is `args` (or has **-args all**): *p* consumes all remaining input arguments, except that arguments needed to satisfy any *later* **-required** positionals are reserved for them. If after that reservation *p* would consume zero arguments and it has no **-default** (`args` always has one), the variable for *p* is left unset. * If **p** is **-required** (without a **-default**): *p* consumes its *max(1, arg_count)* arguments. If too few input arguments remain to satisfy this it is a usage error. * Otherwise (optional, or **-required** with a **-default**): *p* consumes its *arg_count* arguments only when at least *arg_count* + (count needed for later **-required** positionals) arguments remain. Otherwise *p*'s **-default** is applied (if any) and consumption skips to the next positional. This means optional positionals between or before **-required** positionals are skipped automatically when the caller supplies just enough arguments to satisfy the **-required** ones, rather than greedily filling the optional and erroring on the missing required. An *argspec* may contain at most one `args`/**-args all** positional, and any positional that follows it must be **-required** without a **-default**. The string representation of an input argument is generated only for arguments that fall within the named-option scan (see **NAMED OPTION SCAN**). Arguments reserved for trailing **-required** positionals, and all arguments when the *argspec* has no named options, are bound by position only and never have their first character inspected. So shimmer-hostile values, such as large pure bytearrays whose string form is expensive to generate, pass through without being converted. # ERRORS An invalid *argspec* is reported when it is first compiled, which is the first time it is used to parse arguments (or the first time after it has lost its internal representation). Usage errors are reported with these errorcodes: `TCL LOOKUP INDEX option` *name* : *name* (which starts with "-" and is in the named-option scan) isn't a named option in the *argspec*. The message lists the valid options, as for **Tcl_GetIndexFromObj**. `TCL LOOKUP INDEX` *option* *value* : *value* isn't one of the **-enum** values for *option*. `TCL WRONGARGS` : More arguments were supplied than the *argspec* can bind, or a named option was missing its value(s). The message is a usage generated from the *argspec*, in the usual **wrong # args: should be** form but without a command name, since **parse_args** can't know which name is right (it may be parsing a proc's *args*, values passed into a resumed coroutine, a script's *argv*, ...). A caller that wants one can add it when handling the error. `PARSE_ARGS REQUIRED` *name* : The **-required** argument *name* wasn't supplied. `PARSE_ARGS REQUIRED_ONE_OF` *names* : None of the **-multi** group *names*, one of which is **-required**, was supplied. `PARSE_ARGS WRONGARGS` *name* : Too few arguments remained to fill the **-required** positional *name*, which has **-args** *count* greater than 1. `PARSE_ARGS VALIDATION` *name* : The **-validate** command prefix rejected the value supplied for *name*. # C API The same argument parsing is available to C code, through a Tcl stubs table. A separately compiled extension depends on **parse_args** (pkg-config or meson **dependency('parse_args')**, which supply **-DUSE_PARSE_ARGS_STUBS=1** and the stub library), includes **parse_args.h** and calls **ParseArgs_InitStubs**(*interp*) in its Init. Code compiled by **jitc** with a **package {parse_args @PACKAGE_VERSION@}** part calls the functions directly. int **ParseArgs_BindDict**(*interp*, *argspec*, *objc*, *objv*, *dictPtr*) : Bind *objc*/*objv* against the *argspec* Tcl_Obj, as the **parse_args** command does with a *varname*, leaving the result dict in \**dictPtr* (which must point to NULL or an object reference, which is replaced: **replace_tclobj** semantics). int **ParseArgs_Bind**(*interp*, *argspec*, *objc*, *objv*, *cb*, *cdata*) : Bind *objc*/*objv* against the *argspec* Tcl_Obj, calling *cb*(*cdata*, *interp*, *decl_idx*, *name*, *val*) for each value bound. *decl_idx* is the index of the *argspec* entry that the value is for, counting both options and positional parameters in the order they appear in *argspec* (or -1 for the value of a **-multi** group), and *name* is its output name. *val* is only guaranteed to be valid during the callback. int **ParseArgs_BindSlots**(*interp*, *cachePtr*, *specstr*, *objc*, *objv*, *slotc*, *slots*) : Bind *objc*/*objv* against the *argspec* in \**cachePtr*, which is created from the string *specstr* when \**cachePtr* is NULL (and kept there, with a reference held, for the caller to release), or for this call only if *cachePtr* is NULL. Each value is converted as directed by *slots*[*decl_idx*], which must have an entry for each *argspec* entry, and stored at its *addr*. A reference to the value is kept in the slot's *hold* member (which must initially be NULL), keeping pointers into it valid until the caller releases it with **ParseArgs_ReleaseSlots**(*slotc*, *slots*). **-multi** and **-alias** are not supported. This is the mechanism behind **parseargs_bind.def**. All three leave an error message (and errorcode, as for **parse_args**) in the interp result on failure. ## parseargs_bind.def **parseargs_bind.def** declares and binds a struct local in a C command implementation, from an X-macro that declares the *argspec*: ~~~c static int foo(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( special, "-boolean", BOOL ) \ ARG( a1, "-required", STRING ) \ ARG( a2, "-default 42", INT ) \ ARG( a3, "-required", WIDEINT ) \ /* line intentionally left blank */ #include // args.special, args.a1, args.a2, args.a3 ... return TCL_OK; } ~~~ Each entry is **OPT**(*name*, *settings*, *type*) for an option (**-**_name_) or **ARG**(*name*, *settings*, *type*) for a positional parameter. *name* is both the C struct member and the *argspec* name (so options are limited to names that are valid C identifiers), *settings* is a string literal with the *argspec* settings for the entry, and *type* selects the member's C type and the conversion: | *type* | Member(s) | Conversion | |---|---|---| | **OBJ** | Tcl\_Obj\* *name* | The value itself (NULL if not supplied) | | **BOOL** | bool *name* | Tcl\_GetBooleanFromObj | | **INT** | int *name* | Tcl\_GetIntFromObj | | **WIDEINT** | Tcl\_WideInt *name* | Tcl\_GetWideIntFromObj | | **DOUBLE** | double *name* | Tcl\_GetDoubleFromObj | | **STRING** | const char\* *name* | Tcl\_GetString | | **BYTES** | const unsigned char\* *name*, Tcl\_Size *name*\_len | Tcl\_GetBytesFromObj | | **LIST** | Tcl\_Size *name*c, Tcl\_Obj\*\* *name*v | Tcl\_ListObjGetElements (for **-args** *n* and **args**) | | **INDEX** | int *name* | Index of the value in the entry's **-enum** choices | | **SKIP** | (none) | Not stored | Further types can be added by defining **PARSEARGS\_OUTTYPE\_**_type_(*name*) (the member declaration) and **PARSEARGS\_SLOTFOR\_**_type_(*out*, *name*) (the **struct ParseArgs\_Slot** initializer, using **PARSEARGS\_SLOT\_CUSTOM** and a converter function). Members for entries that are not supplied and have no **-default** are left zeroed. Values are held until the struct goes out of scope, so pointer members stay valid until then. The release is done with **defer**, so the code including **parseargs_bind.def** must be compiled as C23 with **defer** support (as **jitc** cdefs are). These macros may be defined before the include to override the defaults, and are all undefined afterwards: **PARSEARGS\_OUT** : The name of the struct local, default **args**. **PARSEARGS\_INTERP**, **PARSEARGS\_OBJC**, **PARSEARGS\_OBJV** : Defaults **interp**, **objc-1** and **objv+1**. **PARSEARGS\_CACHE** : A **Tcl\_Obj\*\*** in which to cache the compiled *argspec* across calls, or NULL to build it for each call. The default, **((Tcl\_Obj\*\*)cdata)**, is the per-binding slot that **jitc::bind** provides as the ClientData of a jitc **OBJCMD** (and jitc releases it when the command is deleted). Under **jitc::capply** cdata is NULL, so the *argspec* is built for each call. Other code must supply its own slot, and release it. **PARSEARGS\_ON\_ERROR** : The statement to run when binding fails, default **return TCL_ERROR**. # EXAMPLES Mimic the argument handling of the core `glob` command: ~~~tcl proc glob args { parse_args::parse_args $args { -directory {} -join {-boolean} -nocomplain {-boolean} -path {} -tails {-boolean} -types {-default {}} args {-name patterns} } if {$join} { set patterns [list [file join {*}$patterns]] } if {[llength $patterns] == 0 && $nocomplain} return foreach pattern $patterns { if {[info exists directory]} { ... } } ... } ~~~ Mimic `regex`: ~~~tcl proc regexp args { parse_args::parse_args $args { -about {-boolean} -expanded {-boolean} -indices {-boolean} -line {-boolean} -linestop {-boolean} -lineanchor {-boolean} -nocase {-boolean} -all {-boolean} -inline {-boolean} -start {-default 0} exp {-required} string {-required} matchvar {} args {-name submatchvars} } ... } ~~~ `lsort`: ~~~tcl proc lsort args { parse_args::parse_args $args { -ascii {-name compare_as -multi -default ascii} -dictionary {-name compare_as -multi} -integer {-name compare_as -multi} -real {-name compare_as -multi} -command {} -increasing {-name order -multi -default increasing} -decreasing {-name order -multi} -indices {-boolean} -index {} -stride {-default 1} -nocase {-boolean} -unique {-boolean} list {-required} } if {![info exists command]} { switch -- $compare_as { ascii { set command {string compare} if {$nocase} { lappend command -nocase } } dictionary { ... } integer - real { set command tcl::mathop::- } } } } ~~~ `lsearch`: ~~~tcl proc lsearch args { parse_args::parse_args $args { -exact {-name matchtype -multi} -glob {-name matchtype -multi -default glob} -regexp {-name matchtype -multi} -sorted {-boolean} -all {-boolean} -inline {-boolean} -not {-boolean} -start {-default 0} -ascii {-name compare_as -multi -default ascii} -dictionary {-name compare_as -multi} -integer {-name compare_as -multi} -real {-name compare_as -multi} -nocase {-boolean} -decreasing {-name order -multi} -increasing {-name order -multi -default increasing} -bisect {-boolean} -index {} -subindices {-boolean} } if {$sorted && $matchtype in {glob regexp}} { error "-sorted is mutually exclusive with -glob and -regexp" } } ~~~ A Tk widget - `entry`: ~~~tcl proc entry {widget args} { parse_args::parse_args $args { -disabledbackground {-default {}} -disabledforeground {-default {}} -invalidcommand {-default {}} -readonlybackground {-default {}} -show {} -state {-default normal -enum { normal disabled readonly }} -validate {-default none -enum { none focus focusin focusout key all }} -validatecommand {-default {}} -width {-default 0} -textvariable {} } } ~~~ # SEE ALSO The paper presented at the 2016 Tcl Conference which discusses the approach and design choices made in this package in much greater depth: https://www.tcl-lang.org/community/tcl2016/assets/talk33/parse_args-paper.pdf # BUGS Please open an issue on the github tracker for the project if you encounter any problems: https://github.com/RubyLane/parse_args/issues # LICENSE This package is Copyright 2015-2026 Cyan Ogilvie, and is made available under the same license terms as the Tcl Core RubyLane-parse_args-b4f953b/meson.build000066400000000000000000000076611526416560500201650ustar00rootroot00000000000000project('parse_args', 'c', version: '0.7.2', # A single c_std, not a fallback list ('gnu2y,gnu23,gnu2x'): meson (1.9.1) # doesn't resolve the list when this is built as a subproject, and passes it # to the compiler verbatim, failing every configure check. gnu2x is C23 on # current gcc / clang; defer support is detected separately (teabase). default_options: ['c_std=gnu2x', 'warning_level=3', 'werror=true'], meson_version: '>=1.3.0', ) cc = meson.get_compiler('c') fs = import('fs') add_project_arguments('-D_DEFAULT_SOURCE', language: 'c') add_project_arguments('-Wno-missing-field-initializers', language: 'c') add_project_arguments('-DHAVE_CONFIG_H', '-DBUILD_parse_args', language: 'c') # Only the stubs API (EXTERN / DLLEXPORT) and Parse_args_Init are exported: keep # the internal helpers from interposing with other packages' symbols when loaded # RTLD_GLOBAL (as jitc does for package dependencies) add_project_arguments(cc.get_supported_arguments('-fvisibility=hidden'), language: 'c') if get_option('debug') add_project_arguments(cc.get_supported_arguments(['-ggdb3']), language: 'c') endif conf = configuration_data() conf.set10('TESTMODE', get_option('testmode')) deps = [] inc = [include_directories('.')] pkg_sources = files('parse_args.c', 'teabase/instance_tracking.c', 'teabase/register_config.c') # parseargs_bind.def goes through teaconf_files (with nothing to substitute) so # that it lands in the build dir next to parse_args.h (includedir,runtime, for # jitc cdefs and meson devenv) and is installed with it teaconf_files = files('parse_args.h.in', 'parseargs_bind.def') tea_genstubs = files('parse_args.decls', 'parse_argsStubLib.c') tea_want_shims = ['tip445'] tea_want_defer = true subdir('teabase') # pkg-config metadata so downstream meson / shell consumers can locate # this install uniformly via `pkg-config --variable=tcl_pkg_path parse_args` # or `dependency('parse_args').get_variable('tcl_pkg_path')`. # tcl_dep is set by teabase/init. pc_conf = configuration_data() pc_conf.set('PACKAGE_NAME', meson.project_name()) pc_conf.set('PACKAGE_VERSION', meson.project_version()) pc_conf.set('PKG_DIR_BASENAME', meson.project_name() + '-' + meson.project_version()) pc_conf.set('STUBLIB', tea_pkg_stub_name) configure_file( input: meson.project_name() + '.pc.in', output: meson.project_name() + '.pc', configuration: pc_conf, install: true, install_dir: tcl_dep.get_variable('libdir') / 'pkgconfig', install_tag: meson.is_subproject() ? 'deps' : 'runtime', ) # Override-dependency for meson subproject consumers. Mirrors the # tcl_pkg_path variable in the .pc file so downstream # `dependency('parse_args', fallback: ['parse_args', 'parse_args_dep']).get_variable('tcl_pkg_path')` # returns the right directory regardless of resolution path. parse_args_dep = declare_dependency( link_with: stubs_lib, sources: genstubs[1], include_directories: include_directories('teabase'), compile_args: '-DUSE_PARSE_ARGS_STUBS=1', variables: { 'tcl_pkg_path': fs.parent(pkg_so.full_path()), 'version': meson.project_version(), }, ) meson.override_dependency(meson.project_name(), parse_args_dep) # Test-only extension consuming the stubs API the way a downstream meson # extension would (tests/stubs.test) _tclstub = tcl_dep.type_name() == 'internal' ? disabler() : cc.find_library('tclstub', dirs: [tcl_dep.get_variable('libdir')], required: false) if _tclstub.found() shared_module('parse_argsstubsconsumer', 'tests/stubs_consumer.c', dependencies: [tcl_hdr_dep, _tclstub, parse_args_dep], # parseargs_bind.def needs defer: use teabase's defer.h, configured as detected for this build c_args: [ '-DHAVE_NATIVE_DEFER=@0@'.format(conf.get('HAVE_NATIVE_DEFER', 0)), '-DHAVE_DEFER_POLYFILL=@0@'.format(conf.get('HAVE_DEFER_POLYFILL', 0)), ], install: false, ) endif subdir('doc') RubyLane-parse_args-b4f953b/meson.options000066400000000000000000000002441526416560500205470ustar00rootroot00000000000000option('testmode', type: 'boolean', value: false, description: 'Build with whitebox testing hooks exposed (none yet: accepted for the standard build dir setup)') RubyLane-parse_args-b4f953b/parse_args.c000066400000000000000000001375131526416560500203150ustar00rootroot00000000000000/* TODO: * - Better error messages */ #include #define NS "::" PACKAGE_NAME static struct tracked_instances g_tracked_instances; // Process-global so that a spec_id identifies a spec even for Tcl_Objs shared // between interps (option lookups are cached on the arg objs keyed by it) static atomic_ulong g_spec_id_seq; struct option_info { Tcl_Obj* param; // What this param is called in the spec Tcl_Obj* name; // The name that will store this params value Tcl_Obj* default_val; // NULL if no default Tcl_Obj* validator; // NULL if no validator Tcl_Obj* enum_choices; // NULL if not an enum, also stores multi_choices for a multi Tcl_Obj* comment; // NULL if no comment int arg_count; // -1: store the option name in -name if present; -2: comsume all remaining args int all_idx; // >= 0 - collect all instances of this option as a list, accumulated in a list at this index int multi_idx; // If this option is part of a multi select int decl_idx; // Index of this entry in the argspec (options and positionals), -1 for spec->multi entries bool is_args; // args style processing - consume all remaining arguments bool required; bool alias; // boolean bool end_options; // Treat seeing this option as if -- followed immediately after it }; struct parse_spec { struct tracked_instance inst; // Must be first (so that parse_spec can be cast to tracked_instance) int refcount; // Held by the intrep, and by each bind in progress (a validator could shimmer the spec obj) unsigned long spec_id; // unique, monotonic (until overflow), assigned from g_spec_id_seq struct option_info* option; // Ordered for spec_find_option (currently: sorted in strcmp(param) collation order, for bsearch) int option_count; int decl_count; // Number of entries in the argspec (options + positionals) bool has_alias; Tcl_Obj* usage_msg; struct option_info* positional; int positional_arg_count; struct option_info* multi; int multi_count; int all_count; // Number of -all accumulators a bind needs int min_required_positional; // sum over -required positionals of max(1, arg_count); is_args contributes 0 }; // Micro Tcl_ObjType - enum_choices <<< static void free_enum_choices_intrep(Tcl_Obj* obj); static void dup_drop_intrep(Tcl_Obj* src, Tcl_Obj* dst); static Tcl_ObjType enum_choices_type = { .name = "parse_spec_enum_choices", .freeIntRepProc = free_enum_choices_intrep, .dupIntRepProc = dup_drop_intrep, }; /* Duplicates of our objtypes whose intreps own resources don't get the intrep: * they are regenerated on demand from the string rep, which these objtypes * ensure exists before storing their intreps */ static void dup_drop_intrep(Tcl_Obj* src, Tcl_Obj* dst) { (void)src; (void)dst; } static void free_enum_choices_intrep(Tcl_Obj* obj) { Tcl_ObjInternalRep* ir = Tcl_FetchInternalRep(obj, &enum_choices_type); if (ir->otherValuePtr) { ckfree(ir->otherValuePtr); ir->otherValuePtr = NULL; } forget_instance(&g_tracked_instances, obj, NULL); } static int GetEnumChoicesFromObj(Tcl_Interp* interp, Tcl_Obj* obj, char*** res) { Tcl_ObjInternalRep* ir = Tcl_FetchInternalRep(obj, &enum_choices_type); if (!ir) { const char** table; Tcl_Size len; TEST_OK(Tcl_SplitList(interp, Tcl_GetString(obj), &len, &table)); Tcl_StoreInternalRep(obj, &enum_choices_type, &(Tcl_ObjInternalRep){ .otherValuePtr = table }); register_instance(&g_tracked_instances, obj, NULL); ir = Tcl_FetchInternalRep(obj, &enum_choices_type); } *res = ir->otherValuePtr; return TCL_OK; } // Micro Tcl_ObjType - enum_choices >>> // Micro Tcl_ObjType - option <<< /* Using Tcl_GetIndexFromObj to look up arguments against the option name list (and cache those lookups) has a flaw: the objects are converted to a type that caches the found index for the table whose cache validity is based on the address of the table, but our tables are dynamic: they live as long as the parse spec obj, but Tcl (especially in optimized builds) will eagerly recycle Tcl_Objs and under heavy churn a new parse spec can re-use the address of a previous one, and so indicies looked up against the old spec (which doesn't match the new one) are returned without consulting the new which can lead to `-foo` resolving to `-bar` in the old map because it is in the same slot, or an out-of-bounds reference if `-foo` was at an index beyond the last element in the new spec. Our performance requirements cannot afford to prevent this caching (using flag TCL_INDEX_TEMP_TABLE for Tcl_GetIndexFromObj), so we have to implement our own index caching lookup that is robust for our use case (include a unique global parse_spec monotonic id in the cache key) */ static void dup_option_intrep(Tcl_Obj* src, Tcl_Obj* dst); static void free_option_intrep(Tcl_Obj* obj); static Tcl_ObjType option_type = { .name = "parse_spec_option", .freeIntRepProc = free_option_intrep, .dupIntRepProc = dup_option_intrep, }; static void free_option_intrep(Tcl_Obj* obj) { forget_instance(&g_tracked_instances, obj, NULL); } static void dup_option_intrep(Tcl_Obj* src, Tcl_Obj* dst) { Tcl_StoreInternalRep(dst, &option_type, Tcl_FetchInternalRep(src, &option_type)); register_instance(&g_tracked_instances, dst, NULL); } /* Option name lookup <<< * spec_index_options arranges spec->option at spec compile time, and * spec_find_option looks up an option by name in it. These are the only places * that know how options are indexed (currently: sorted, with bsearch), so that * the strategy can be swapped out (a radish trie, for instance). The order of * spec->option is otherwise irrelevant: everything that depends on the * declaration order uses option_info.decl_idx. */ static int cmp_opt(const void* a, const void* b) { const struct option_info* opt_a = a; const struct option_info* opt_b = b; return strcmp(Tcl_GetString(opt_a->param), Tcl_GetString(opt_b->param)); } static int cmp_opt_key(const void* key, const void* elem) { const struct option_info* opt = elem; return strcmp(key, Tcl_GetString(opt->param)); } static void spec_index_options(struct parse_spec* spec) { qsort(spec->option, spec->option_count, sizeof(spec->option[0]), cmp_opt); } static struct option_info* spec_find_option(struct parse_spec* spec, const char* str, Tcl_Size len) { (void)len; return bsearch(str, spec->option, spec->option_count, sizeof(spec->option[0]), cmp_opt_key); } // Option name lookup >>> static void spec_decl_order(const struct parse_spec* spec, const struct option_info* out[]) //<<< { // out must have room for spec->decl_count entries for (int i=0; ioption_count; i++) out[spec->option[i].decl_idx] = &spec->option[i]; for (int i=0; ipositional_arg_count; i++) out[spec->positional[i].decl_idx] = &spec->positional[i]; } //>>> static int bad_option(Tcl_Interp* interp, const struct parse_spec* spec, const char* str) //<<< { // Same message and errorcode as the Tcl_GetIndexFromObj lookup this replaced if (!interp) return TCL_ERROR; const struct option_info* decl[spec->decl_count ? spec->decl_count : 1]; spec_decl_order(spec, decl); Tcl_Obj* msg = Tcl_ObjPrintf("bad option \"%s\": ", str); if (spec->option_count == 0) { Tcl_AppendToObj(msg, "no valid options", -1); } else { Tcl_AppendToObj(msg, "must be ", -1); int listed = 0; for (int d=0; ddecl_count; d++) { if (Tcl_GetString(decl[d]->param)[0] != '-') continue; if (listed++) Tcl_AppendToObj(msg, listed < spec->option_count ? ", " : spec->option_count > 2 ? ", or " : " or ", -1); Tcl_AppendObjToObj(msg, decl[d]->param); } } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", str, NULL); return TCL_ERROR; } //>>> static int GetOptionFromObj(Tcl_Interp* interp, struct parse_spec* spec, Tcl_Obj* opt, struct option_info** option) { Tcl_ObjInternalRep* ir = Tcl_FetchInternalRep(opt, &option_type); for (;;) { if (!ir) { Tcl_Size len; const char* str = Tcl_GetStringFromObj(opt, &len); struct option_info* o = spec_find_option(spec, str, len); if (!o) return bad_option(interp, spec, str); Tcl_StoreInternalRep(opt, &option_type, &(Tcl_ObjInternalRep){ .ptrAndLongRep = { .ptr = o, .value = spec->spec_id } }); register_instance(&g_tracked_instances, opt, NULL); ir = Tcl_FetchInternalRep(opt, &option_type); } if (ir->ptrAndLongRep.value != spec->spec_id) { // Cached value is stale, force a new lookup ir = NULL; continue; } *option = ir->ptrAndLongRep.ptr; break; } return TCL_OK; } // Micro Tcl_ObjType - option >>> static void free_internal_rep(Tcl_Obj* obj); static Tcl_ObjType parse_spec_type = { .name = "parse_spec", .freeIntRepProc = free_internal_rep, .dupIntRepProc = dup_drop_intrep, }; /* Allocate static Tcl_Objs for these strings for each interp */ static const char* static_str[] = { "0", "1", "idx", "required", "default", "validate", "choices", "all", NULL }; enum static_objs { L_FALSE=0, L_TRUE, L_IDX, L_REQUIRED, L_DEFAULT, L_VALIDATE, L_CHOICES, L_ALL, L_end }; struct interp_cx { Tcl_Obj* obj[L_end]; Tcl_Obj* enums; }; // Fast unsigned int to string conversion from the talk by Alexandrescu: "Three Optimization Tips for C++" <<< static uint32_t digits10(uint64_t v) //<<< { #define P01 10 #define P02 100 #define P03 1000 #define P04 10000 #define P05 100000 #define P06 1000000 #define P07 10000000 #define P08 100000000 #define P09 1000000000 #define P10 10000000000 #define P11 100000000000 #define P12 1000000000000 if (v < P01) return 1; if (v < P02) return 2; if (v < P03) return 3; if (v < P12) { if (v < P08) { if (v < P06) { if (v < P04) return 4; return 5 + (v >= P05); } return 7 + (v >= P07); } if (v < P10) { return 9 + (v >= P09); } return 11 + (v >= P11); } return 12 + digits10(v / P12); } //>>> static int u64toa(uint64_t value, char* restrict dst) //<<< { // TODO: benchmark this against TclFormatInt and replace the latter with this if it's faster static const char digits[201] = "0001020304050607080910111213141516171819" "2021222324252627282930313233343536373839" "4041424344454647484950515253545556575859" "6061626364656667686970717273747576777879" "8081828384858687888990919293949596979899"; const uint32_t length = digits10(value); uint32_t next = length-1; while (value >= 100) { const int i = (value % 100) * 2; value /= 100; memcpy(dst+next-1, digits+i, 2); //dst[next] = digits[i+1]; //dst[next-1] = digits[i]; next -= 2; } if (value < 10) { dst[next] = '0' + (uint32_t)value; } else { const int i = (uint32_t)value * 2; memcpy(dst+next-1, digits+i, 2); //dst[next] = digits[i + 1]; //dst[next-1] = digits[i]; } return length; } //>>> //>>> static const char* static_numstr(uint64_t v) //<<< { static char staticbuf[21]; // 21 - max length of decimal representation of uint64_t + null terminator staticbuf[u64toa(v, staticbuf)] = 0; return staticbuf; } //>>> static void free_option_info(struct option_info* option) //<<< { if (option) { replace_tclobj(&option->param, NULL); replace_tclobj(&option->name, NULL); replace_tclobj(&option->default_val, NULL); replace_tclobj(&option->validator, NULL); replace_tclobj(&option->enum_choices, NULL); replace_tclobj(&option->comment, NULL); } } //>>> static void free_parse_spec(struct parse_spec** specPtr) //<<< { struct parse_spec* spec = *specPtr; if (spec) { // If NULL then we haven't registered the instance yet (or the intrep has been freed) if (spec->inst.self) forget_instance(&g_tracked_instances, spec->inst.self, &spec->inst); if (spec->option != NULL) { for (int i=0; i < spec->option_count; i++) free_option_info(&spec->option[i]); ckfree(spec->option); spec->option = NULL; } replace_tclobj(&spec->usage_msg, NULL); if (spec->positional) { for (int i=0; i < spec->positional_arg_count; i++) free_option_info(&spec->positional[i]); ckfree(spec->positional); spec->positional = NULL; } if (spec->multi) { for (int i=0; i < spec->multi_count; i++) free_option_info(&spec->multi[i]); ckfree(spec->multi); spec->multi = NULL; } ckfree(spec); *specPtr = NULL; } } //>>> static inline void spec_incref(struct parse_spec* spec) //<<< { spec->refcount++; } //>>> static void spec_decref(struct parse_spec* spec) //<<< { if (--spec->refcount <= 0) free_parse_spec(&spec); } //>>> static void free_internal_rep(Tcl_Obj* obj) //<<< { Tcl_ObjInternalRep* ir = Tcl_FetchInternalRep(obj, &parse_spec_type); struct parse_spec* spec = ir->otherValuePtr; // The spec can outlive the intrep (if this happens during a bind) forget_instance(&g_tracked_instances, obj, &spec->inst); spec_decref(spec); ir->otherValuePtr = NULL; } //>>> static Tcl_Obj* build_usage_msg(const struct parse_spec* spec) //<<< { // Like a proc's usage: options in argspec order, then the positionals const struct option_info* decl[spec->decl_count ? spec->decl_count : 1]; spec_decl_order(spec, decl); Tcl_Obj* msg = Tcl_NewObj(); #define APPEND(...) Tcl_AppendStringsToObj(msg, __VA_ARGS__, (char*)NULL) for (int pass=0; pass<2; pass++) { for (int d=0; ddecl_count; d++) { const struct option_info* o = decl[d]; const char* param = Tcl_GetString(o->param); const bool is_option = param[0] == '-'; if (is_option != (pass == 0)) continue; if (Tcl_GetCharLength(msg)) APPEND(" "); if (is_option) { // A value placeholder: the -enum choices, else the output name Tcl_Obj* ph = NULL; defer { replace_tclobj(&ph, NULL); } if (o->enum_choices) { Tcl_Size ec; Tcl_Obj** ev; if (Tcl_ListObjGetElements(NULL, o->enum_choices, &ec, &ev) == TCL_OK && ec > 0) { replace_tclobj(&ph, Tcl_NewObj()); for (Tcl_Size e=0; ename); const char* phs = Tcl_GetString(ph); if (!o->required) APPEND("?"); APPEND(param); switch (o->arg_count) { case -2: APPEND(" ", phs, " ..."); break; // -args all case -1: break; // -multi flag case 0: break; // -boolean default: for (int n=0; narg_count; n++) APPEND(" ", phs); } if (!o->required) APPEND("?"); } else if (o->is_args || o->arg_count == -2) { APPEND("?", param, " ...?"); } else { const bool optional = !o->required || o->default_val; const int n = o->arg_count > 0 ? o->arg_count : 1; if (optional) APPEND("?"); for (int i=0; i>> static int compile_parse_spec(Tcl_Interp* interp, Tcl_Obj* obj, struct parse_spec** res) //<<< { struct interp_cx* l = (struct interp_cx*)Tcl_GetAssocData(interp, "parse_args", NULL); Tcl_Obj* multis = NULL; defer { replace_tclobj(&multis, NULL); } replace_tclobj(&multis, Tcl_NewDictObj()); Tcl_Size oc; Tcl_Obj** ov; TEST_OK(Tcl_ListObjGetElements(interp, obj, &oc, &ov)); if (oc % 2 != 0) THROW_ERROR("argspec must be a dictionary"); struct parse_spec* spec = ckalloc(sizeof(struct parse_spec)); *spec = (struct parse_spec){ .refcount = 1, .spec_id = atomic_fetch_add(&g_spec_id_seq, 1) + 1, .decl_count = oc / 2, }; defer { if (spec) free_parse_spec(&spec); } { /* A repeated key would leave the earlier definition unreachable but * still enforced (-required, -default), so reject it */ Tcl_HashTable seen; Tcl_InitHashTable(&seen, TCL_STRING_KEYS); defer { Tcl_DeleteHashTable(&seen); } for (int i=0; ioption_count++; else spec->positional_arg_count++; } } spec->option = ckalloc(sizeof(struct option_info) * spec->option_count); spec->positional = ckalloc(sizeof(struct option_info) * spec->positional_arg_count); memset(spec->option, 0, sizeof(struct option_info) * spec->option_count); memset(spec->positional, 0, sizeof(struct option_info) * spec->positional_arg_count); int o_i = 0; // Number of options int p_i = 0; // Number of positional params for (int i=0; ioption[o_i++] : &spec->positional[p_i++]; *option = (struct option_info){ .arg_count = 1, .multi_idx = -1, .all_idx = -1, .decl_idx = i / 2, }; replace_tclobj(&option->param, ov[i]); Tcl_Size settingc; Tcl_Obj** settingv; TEST_OK(Tcl_ListObjGetElements(interp, ov[i+1], &settingc, &settingv)); bool all_specified = false; for (int j=0; j= settingc) THROW_ERROR(Tcl_GetString(settingv[j-1]), " needs a value"); break; } #pragma GCC diagnostic pop switch (setting) { case SETTING_DEFAULT: replace_tclobj(&option->default_val, settingv[j++]); break; case SETTING_REQUIRED: option->required = true; break; case SETTING_NAME: replace_tclobj(&option->name, settingv[j++]); break; case SETTING_COMMENT: replace_tclobj(&option->comment, settingv[j++]); break; case SETTING_ALIAS: option->alias = spec->has_alias = true; break; case SETTING_ALL: all_specified = true; break; // Just raise a flag here to prevent multiple -all specs from excessively incrementing all_count case SETTING_END: option->end_options = true; break; case SETTING_VALIDATE: //<<< { Tcl_Obj* validatorobj = settingv[j++]; Tcl_Obj** vv; Tcl_Size vc; TEST_OK(Tcl_ListObjGetElements(interp, validatorobj, &vc, &vv)); if (vc) replace_tclobj(&option->validator, validatorobj); } break; //>>> case SETTING_BOOLEAN: //<<< if (str[0] != '-') THROW_ERROR("Cannot use -boolean on positional argument \"", Tcl_GetString(option->param), "\""); option->arg_count = 0; break; //>>> case SETTING_ARGS: //<<< if (strcmp("all", Tcl_GetString(settingv[j])) == 0) { option->arg_count = -2; } else { TEST_OK(Tcl_GetIntFromObj(interp, settingv[j], &option->arg_count)); if (option->arg_count < 0) THROW_ERROR("-args cannot be negative"); if (option->arg_count == 0 && str[0] != '-') THROW_ERROR("Cannot use -args 0 on positional argument \"", Tcl_GetString(option->param), "\""); } j++; break; //>>> case SETTING_ENUM: //<<< { /* enums are validated using Tcl_GetIndexFromObj, which * shimmers its input obj to record the table and index * info, so make an effort to unify enums across parse_specs */ if (!l->enums) return TCL_ERROR; Tcl_Obj* enum_choices = settingv[j++]; Tcl_Obj* shared_enum_choices = NULL; TEST_OK(Tcl_DictObjGet(interp, l->enums, enum_choices, &shared_enum_choices)); if (!shared_enum_choices) { if (Tcl_IsShared(l->enums)) replace_tclobj(&l->enums, Tcl_DuplicateObj(l->enums)); TEST_OK(Tcl_DictObjPut(interp, l->enums, enum_choices, shared_enum_choices = enum_choices)); } Tcl_Size size; TEST_OK(Tcl_DictObjSize(interp, l->enums, &size)); // Paranoia - prevent the speculative enum cache from growing too large if (size > 1000) replace_tclobj(&l->enums, Tcl_NewDictObj()); replace_tclobj(&option->enum_choices, shared_enum_choices); } break; //>>> case SETTING_MULTI: //<<< if (str[0] != '-') THROW_ERROR("Cannot use -multi on positional argument \"", Tcl_GetString(option->param), "\""); option->arg_count = -1; break; //>>> default: THROW_PRINTF("Invalid setting: %d", setting); } } if (!option->name) { replace_tclobj(&option->name, str[0] == '-' ? Tcl_NewStringObj(str+1, str_len-1) : option->param ); } if (option->arg_count == -1) { int multi_idx; Tcl_Obj* multi_choices; const char* multi_val; Tcl_Size multi_val_len; Tcl_Obj* multi_config_loan = NULL; Tcl_Obj* multi_all = NULL; TEST_OK(Tcl_DictObjGet(interp, multis, option->name, &multi_config_loan)); if (!multi_config_loan) { multi_idx = spec->multi_count++; multi_config_loan = Tcl_NewDictObj(); TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_IDX], Tcl_NewIntObj(multi_idx))); TEST_OK(Tcl_DictObjPut(interp, multis, option->name, multi_config_loan)); multi_choices = Tcl_NewListObj(0, NULL); } else { Tcl_Obj* idx_obj = NULL; TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_IDX], &idx_obj)); TEST_OK(Tcl_GetIntFromObj(interp, idx_obj, &multi_idx)); TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_CHOICES], &multi_choices)); } TEST_OK(Tcl_ListObjAppendElement(interp, multi_choices, option->param)); TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_CHOICES], multi_choices)); option->multi_idx = multi_idx; // TODO: throw errors if -boolean or -args are mixed with -multi if (option->enum_choices) THROW_ERROR("Cannot use -multi and -enum together"); if (option->required) TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_REQUIRED], l->obj[L_TRUE])); if (option->default_val) TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_DEFAULT], option->default_val)); if (option->validator) TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_VALIDATE], option->validator)); TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_ALL], &multi_all)); if (all_specified || multi_all) { int all_idx; if (multi_all) { TEST_OK(Tcl_GetIntFromObj(interp, multi_all, &all_idx)); } else { all_idx = spec->all_count++; } option->all_idx = all_idx; if (!multi_all) TEST_OK(Tcl_DictObjPut(interp, multi_config_loan, l->obj[L_ALL], Tcl_NewIntObj(all_idx))); } // Repurpose option->default_val to store the value this option will set in the multi output multi_val = Tcl_GetStringFromObj(option->param, &multi_val_len); replace_tclobj(&option->default_val, Tcl_NewStringObj(multi_val+1, multi_val_len-1)); } else if (all_specified) { option->all_idx = spec->all_count++; } } spec_index_options(spec); // This is only known after parsing the options if (spec->multi_count > 0) { spec->multi = ckalloc(sizeof(struct option_info) * spec->multi_count); memset(spec->multi, 0, sizeof(struct option_info) * spec->multi_count); Tcl_DictSearch search; int done; Tcl_Obj* multi_config_loan = NULL; Tcl_Obj* name; TEST_OK(Tcl_DictObjFirst(interp, multis, &search, &name, &multi_config_loan, &done)); defer { Tcl_DictObjDone(&search); } for (; !done; Tcl_DictObjNext(&search, &name, &multi_config_loan, &done)) { struct option_info* multi; Tcl_Obj* idx_obj; TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_IDX], &idx_obj)); int idx; TEST_OK(Tcl_GetIntFromObj(interp, idx_obj, &idx)); if (idx < 0 || idx >= spec->multi_count) { THROW_ERROR("Got out of bounds multi_count ", Tcl_GetString(idx_obj), " for option \"", Tcl_GetString(name)); } multi = &spec->multi[idx]; replace_tclobj(&multi->name, name); multi->arg_count = -1; multi->decl_idx = -1; Tcl_Obj* val; // set -required TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_REQUIRED], &val)); if (val) multi->required = true; // set -default TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_DEFAULT], &val)); replace_tclobj(&multi->default_val, val); // set -validate TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_VALIDATE], &val)); replace_tclobj(&multi->validator, val); // set multi choices (for error message if required and not set) TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_CHOICES], &val)); replace_tclobj(&multi->enum_choices, val); TEST_OK(Tcl_DictObjGet(interp, multi_config_loan, l->obj[L_ALL], &val)); if (val) { TEST_OK(Tcl_GetIntFromObj(interp, val, &multi->all_idx)); } else { multi->all_idx = -1; } } } // Create special "args" behaviour for any positional param named "args". // Earlier this was restricted to the last positional, but now permitting // it at any position lets callers write specs like {args ... last_arg {-required}}. // strcmp is safe because Tcl_GetString always gives us a properly // \0 terminated string for (int i=0; i < spec->positional_arg_count; i++) { struct option_info* p = &spec->positional[i]; if (strcmp("args", Tcl_GetString(p->param)) == 0) { p->is_args = true; if (!p->default_val) replace_tclobj(&p->default_val, Tcl_NewObj()); } } // Validate positional layout: only one is_args/-args all consumer, and any // positional that follows it must be -required (otherwise it could never // be reached, since the consumer is left-greedy modulo the suffix reservation). // Also compute min_required_positional = sum over positionals that need // args from the caller to succeed. A positional "needs args" iff it is // -required AND has no -default AND is not is_args/-args all. { bool saw_args_consumer = false; spec->min_required_positional = 0; for (int i=0; i < spec->positional_arg_count; i++) { struct option_info* p = &spec->positional[i]; int is_args_like = p->is_args || p->arg_count == -2; if (saw_args_consumer) { if (is_args_like) THROW_ERROR("Cannot have more than one args/-args all positional consumer (\"", Tcl_GetString(p->param), "\")"); if (!p->required || p->default_val) THROW_ERROR("Positional \"", Tcl_GetString(p->param), "\" cannot follow an args/-args all consumer unless it is -required without a default"); } if (is_args_like) saw_args_consumer = true; if (p->required && !is_args_like && !p->default_val) spec->min_required_positional += (p->arg_count > 0) ? p->arg_count : 1; } } replace_tclobj(&spec->usage_msg, build_usage_msg(spec)); *res = spec; spec = NULL; // Hand ownership to caller return TCL_OK; } //>>> static int GetParseSpecFromObj(Tcl_Interp* interp, Tcl_Obj* spec, struct parse_spec** res) //<<< { Tcl_ObjInternalRep* ir = Tcl_FetchInternalRep(spec, &parse_spec_type); if (!ir) { // Ensure the string rep exists before the intrep replaces whatever it // could be generated from (a spec built as a pure list, for instance) Tcl_GetString(spec); struct parse_spec* compiled_spec = NULL; TEST_OK(compile_parse_spec(interp, spec, &compiled_spec)); Tcl_StoreInternalRep(spec, &parse_spec_type, &(Tcl_ObjInternalRep){ .otherValuePtr = compiled_spec }); ir = Tcl_FetchInternalRep(spec, &parse_spec_type); register_instance(&g_tracked_instances, spec, compiled_spec); } if (res) *res = ir->otherValuePtr; return TCL_OK; } //>>> static int validate(Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val) //<<< { if (option->enum_choices) { int dummy; char** enum_table; TEST_OK(GetEnumChoicesFromObj(interp, option->enum_choices, &enum_table)); TEST_OK(Tcl_GetIndexFromObj(interp, val, enum_table, Tcl_GetString(option->param), TCL_EXACT, &dummy)); } if (option->validator) { Tcl_Size dontcare; TEST_OK(Tcl_ListObjLength(interp, option->validator, &dontcare)); // Force to list before we dup (cache command lookup) Tcl_Obj* valcmd = NULL; defer { replace_tclobj(&valcmd, NULL); } replace_tclobj(&valcmd, Tcl_DuplicateObj(option->validator)); TEST_OK(Tcl_ListObjAppendElement(interp, valcmd, val)); const int res = Tcl_EvalObjEx(interp, valcmd, TCL_EVAL_DIRECT); Tcl_Obj* verdict = NULL; defer { replace_tclobj(&verdict, NULL); } replace_tclobj(&verdict, Tcl_GetObjResult(interp)); int passed; if (res == TCL_OK) { Tcl_ResetResult(interp); if (Tcl_GetCharLength(verdict) == 0) { // Accept a blank string as a pass passed = 1; } else { if (Tcl_GetBooleanFromObj(interp, verdict, &passed) != TCL_OK) { Tcl_ResetResult(interp); passed = 0; } } } else { passed = 0; Tcl_ResetResult(interp); } if (!passed) { Tcl_SetErrorCode(interp, "PARSE_ARGS", "VALIDATION", Tcl_GetString(option->param), NULL); THROW_PRINTF("Validation failed for \"%s\": %s", Tcl_GetString(option->param), Tcl_GetString(verdict) ); } } return TCL_OK; } //>>> /* Binding <<< * bind_args matches the args against a compiled spec and hands each resulting * value to a sink (bind_put), which stores it: as variables (the parse_args * command), into a dict (parse_args with a dict var, ParseArgs_BindDict), to a * C callback (ParseArgs_Bind), or converted into C slots (ParseArgs_BindSlots). * alias is true when the value is the name of a variable in the caller to alias * (an -alias option or positional that was supplied). */ typedef int (bind_put)(void* cx, Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val, bool alias); static int wrong_args(Tcl_Interp* interp, const struct parse_spec* spec) //<<< { /* No command name: parse_args can't know which one is right (a proc's args, * the values resumed into a coroutine, a script's argv, ...), callers can * add that context if they want it */ Tcl_WrongNumArgs(interp, 0, NULL, Tcl_GetString(spec->usage_msg)); return TCL_ERROR; } static int bind_args(Tcl_Interp* interp, struct interp_cx* l, struct parse_spec* spec, Tcl_Size ac, Tcl_Obj*const av[], bind_put* put, void* cx) //<<< { Tcl_Size i; // Held, since a validator would otherwise free a fresh (refcount 0) list value Tcl_Obj* val = NULL; defer { replace_tclobj(&val, NULL); } // The spec must survive this bind, even if a validator shimmers the spec obj spec_incref(spec); defer { spec_decref(spec); } /* Per-bind state (kept off the spec so that a validator can re-enter a * command that uses the same spec): which options and multis were supplied, * and the -all accumulators */ const size_t all_bytes = sizeof(Tcl_Obj*) * spec->all_count; const size_t state_bytes = all_bytes + spec->option_count + spec->multi_count; alignas(Tcl_Obj*) char stackbuf[256]; char* state = state_bytes <= sizeof(stackbuf) ? stackbuf : ckalloc(state_bytes); memset(state, 0, state_bytes); Tcl_Obj** all = (Tcl_Obj**)state; bool* supplied = (bool*)(state + all_bytes); bool* multi_supplied = supplied + spec->option_count; defer { for (int a=0; aall_count; a++) replace_tclobj(&all[a], NULL); if (state != stackbuf) ckfree(state); } #define OUTPUT_DIRECT(option, val) \ TEST_OK(put(cx, interp, (option), (val), false)) #define OUTPUT(option, val) \ do { \ if ((option)->all_idx >= 0) { \ Tcl_Obj** _acc = &all[(option)->all_idx]; \ if (*_acc == NULL) replace_tclobj(_acc, Tcl_NewListObj(1, NULL)); \ TEST_OK(Tcl_ListObjAppendElement(interp, *_acc, (val))); \ } else { \ OUTPUT_DIRECT((option), (val)); \ } \ } while(0) #define OUTPUT_ALIASABLE(option, val) \ do { \ if ((option)->alias) { \ TEST_OK(put(cx, interp, (option), (val), true)); \ } else { \ OUTPUT((option), (val)); \ } \ } while(0) #define VALIDATE(option, val) \ if ((option)->validator != NULL || (option)->enum_choices != NULL) { \ TEST_OK(validate(interp, (option), (val))); \ } // Option phase: scan av[0..k) for options. Stop when: // - we run out of args // - the spec has no options at all // - we reach a slot guaranteed-positional by the min-required-positional reservation // - we hit "--", an arg not starting with '-', or an option marked -end // The reservation skips the Tcl_GetStringFromObj() for shimmer-hostile args // (e.g. large pure bytearrays) that must end up in a positional anyway. i = 0; bool check_options = (spec->option_count > 0); while (check_options && i < ac) { const char* str; Tcl_Size str_len; struct option_info* option; struct option_info* src_option; if (i >= ac - spec->min_required_positional) { check_options = false; break; } str = Tcl_GetStringFromObj(av[i], &str_len); if (str_len == 0 || str[0] != '-') { check_options = false; break; } if (str_len == 2 && str[1] == '-') { check_options = false; i++; break; } TEST_OK(GetOptionFromObj(interp, spec, av[i], &option)); src_option = option; if (option->multi_idx >= 0) { option = &spec->multi[src_option->multi_idx]; multi_supplied[src_option->multi_idx] = true; } else { supplied[option - spec->option] = true; } if (option->arg_count > 0 && ac - i - 1 < option->arg_count) { return wrong_args(interp, spec); } switch (option->arg_count) { case -2: // -args all i++; replace_tclobj(&val, Tcl_NewListObj(ac-i, av+i)); VALIDATE(option, val); OUTPUT(option, val); i = ac; break; case -1: // -multi OUTPUT(option, src_option->default_val); i++; break; case 0: // -boolean OUTPUT(option, l->obj[L_TRUE]); i++; break; case 1: replace_tclobj(&val, av[i+1]); VALIDATE(option, val); OUTPUT_ALIASABLE(option, val); i += 2; break; default: // -args N, N > 1 replace_tclobj(&val, Tcl_NewListObj(option->arg_count, av+i+1)); VALIDATE(option, val); OUTPUT(option, val); i += option->arg_count + 1; break; } if (option->end_options) { check_options = false; break; } } // Positional phase: lookahead consumer. For each positional p: // - is_args / -args all: consume remaining - sum_later_req args; // if 0 consumed and no default, leave unset. // - -required, no default: consume max(1, arg_count); error if short. // - optional or -required+default: consume arg_count if remaining >= arg_count + sum_later_req; // otherwise apply -default (or leave unset). // sum_later_req only counts positionals that *need* args from the caller // (-required AND no -default AND not is_args_like) — matching the // min_required_positional formula computed at spec-compile time. { Tcl_Size remaining = ac - i; Tcl_Size sum_remaining_req = spec->min_required_positional; for (int positional_arg = 0; positional_arg < spec->positional_arg_count; positional_arg++) { struct option_info* p = &spec->positional[positional_arg]; const int is_args_like = p->is_args || p->arg_count == -2; const int has_default = p->default_val != NULL; const int needs_args = p->required && !is_args_like && !has_default; const int p_contrib = needs_args ? ((p->arg_count > 0) ? p->arg_count : 1) : 0; const Tcl_Size sum_later_req = sum_remaining_req - p_contrib; if (is_args_like) { Tcl_Size take_n = remaining - sum_later_req; if (take_n < 0) take_n = 0; // later -required will report the shortage if (take_n > 0) { replace_tclobj(&val, Tcl_NewListObj(take_n, av+i)); VALIDATE(p, val); OUTPUT_DIRECT(p, val); i += take_n; remaining -= take_n; } else if (has_default) { OUTPUT_DIRECT(p, p->default_val); } // else: leave unset (matches old behaviour for explicit -args all without a default) } else if (needs_args) { const int take_n = (p->arg_count > 0) ? p->arg_count : 1; if (remaining < take_n) { if (remaining == 0) { Tcl_SetErrorCode(interp, "PARSE_ARGS", "REQUIRED", Tcl_GetString(p->param), NULL); THROW_ERROR("argument ", Tcl_GetString(p->name), " is required"); } else { Tcl_SetErrorCode(interp, "PARSE_ARGS", "WRONGARGS", Tcl_GetString(p->name), NULL); THROW_ERROR("Expecting ", static_numstr(take_n), " arguments for ", Tcl_GetString(p->name)); } } if (take_n == 1) { VALIDATE(p, av[i]); if (p->alias) { TEST_OK(put(cx, interp, p, av[i], true)); } else { OUTPUT_DIRECT(p, av[i]); } } else { replace_tclobj(&val, Tcl_NewListObj(take_n, av+i)); VALIDATE(p, val); OUTPUT_DIRECT(p, val); } i += take_n; remaining -= take_n; } else { // optional (incl. -required with -default) const int take_n = (p->arg_count > 0) ? p->arg_count : 1; if (p->arg_count > 0 && remaining >= take_n + sum_later_req) { if (take_n == 1) { VALIDATE(p, av[i]); if (p->alias) { TEST_OK(put(cx, interp, p, av[i], true)); } else { OUTPUT_DIRECT(p, av[i]); } } else { replace_tclobj(&val, Tcl_NewListObj(take_n, av+i)); VALIDATE(p, val); OUTPUT_DIRECT(p, val); } i += take_n; remaining -= take_n; } else if (has_default) { // Defaults baked in at spec compile time aren't // re-validated — they may intentionally be outside // the validator's domain. OUTPUT_DIRECT(p, p->default_val); } // else: leave unset } sum_remaining_req = sum_later_req; } if (remaining > 0) { return wrong_args(interp, spec); } } // Check -required, set -default for options that weren't specified, and set the -all lists for (int o=0; o < spec->option_count; o++) { struct option_info* option = &spec->option[o]; if (option->all_idx >= 0) { const int all_idx = option->all_idx; if (all[all_idx]) { OUTPUT_DIRECT(option, all[all_idx]); replace_tclobj(&all[all_idx], NULL); } } if (supplied[o]) continue; if (option->multi_idx >= 0) continue; if (option->default_val != NULL) { OUTPUT_DIRECT(option, option->default_val); } else if (option->arg_count == 0) { OUTPUT_DIRECT(option, l->obj[L_FALSE]); } else { if (option->required) { Tcl_SetErrorCode(interp, "PARSE_ARGS", "REQUIRED", Tcl_GetString(option->param), NULL); THROW_ERROR("option ", Tcl_GetString(option->param), " is required"); } } } // Check -required and set -default for multi options that weren't specified for (int m=0; m < spec->multi_count; m++) { struct option_info* option = &spec->multi[m]; if (multi_supplied[m]) continue; if (option->default_val) { // Direct: the -all accumulators have already been flushed, and // the default is used as given (as for an -all option's default) OUTPUT_DIRECT(option, option->default_val); } else if (option->required) { Tcl_SetErrorCode(interp, "PARSE_ARGS", "REQUIRED_ONE_OF", Tcl_GetString(option->enum_choices), NULL); THROW_ERROR("one of ", Tcl_GetString(option->enum_choices), " are required"); } } #undef OUTPUT_DIRECT #undef OUTPUT #undef OUTPUT_ALIASABLE #undef VALIDATE return TCL_OK; } //>>> static int put_var(void* cx, Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val, bool alias) //<<< { (void)cx; if (alias) return Tcl_UpVar(interp, "1", Tcl_GetString(val), Tcl_GetString(option->name), 0); if (Tcl_ObjSetVar2(interp, option->name, NULL, val, TCL_LEAVE_ERR_MSG) == NULL) return TCL_ERROR; return TCL_OK; } //>>> static int put_dict(void* cx, Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val, bool alias) //<<< { Tcl_Obj* dict = cx; // TODO: fetch the value from the variable called option->name in the parent callframe if (alias) THROW_ERROR("-alias is not yet supported in dictionary mode"); return Tcl_DictObjPut(interp, dict, option->name, val); } //>>> static int parse_args(ClientData cdata, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]) //<<< { struct interp_cx* l = (struct interp_cx*)cdata; Tcl_Obj** av; Tcl_Size ac; enum {A_cmd, A_ARGS, A_SPEC, A_args, A_DICT=A_args, A_objc}; CHECK_RANGE_ARGS("args args_spec ?dict?"); TEST_OK(Tcl_ListObjGetElements(interp, objv[A_ARGS], &ac, &av)); struct parse_spec* spec = NULL; TEST_OK(GetParseSpecFromObj(interp, objv[A_SPEC], &spec)); if (objc > A_DICT) { Tcl_Obj* res = NULL; defer { replace_tclobj(&res, NULL); } replace_tclobj(&res, Tcl_NewDictObj()); TEST_OK(bind_args(interp, l, spec, ac, av, put_dict, res)); if (Tcl_ObjSetVar2(interp, objv[A_DICT], NULL, res, TCL_LEAVE_ERR_MSG) == NULL) return TCL_ERROR; } else { TEST_OK(bind_args(interp, l, spec, ac, av, put_var, NULL)); } return TCL_OK; } //>>> // Binding >>> static void free_interp_cx(ClientData cdata, Tcl_Interp* interp) //<<< { struct interp_cx* l = cdata; (void)interp; if (l) { for (int i=0; iobj[i], NULL); replace_tclobj(&l->enums, NULL); ckfree(l); l = NULL; } } //>>> // Stubs API <<< static int get_interp_cx(Tcl_Interp* interp, struct interp_cx** l) //<<< { *l = Tcl_GetAssocData(interp, PACKAGE_NAME, NULL); if (!*l) THROW_ERROR(PACKAGE_NAME " is not loaded in this interp"); return TCL_OK; } //>>> struct callback_cx { ParseArgs_BindCallback* cb; void* cdata; }; static int put_callback(void* cx, Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val, bool alias) //<<< { struct callback_cx* c = cx; if (alias) THROW_ERROR("-alias is not supported by ParseArgs_Bind"); return c->cb(c->cdata, interp, option->decl_idx, option->name, val); } //>>> int ParseArgs_Bind(Tcl_Interp* interp, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], ParseArgs_BindCallback* cb, void* cdata) //<<< { struct interp_cx* l = NULL; struct parse_spec* spec = NULL; TEST_OK(get_interp_cx(interp, &l)); TEST_OK(GetParseSpecFromObj(interp, argspec, &spec)); return bind_args(interp, l, spec, objc, objv, put_callback, &(struct callback_cx){ .cb = cb, .cdata = cdata, }); } //>>> int ParseArgs_BindDict(Tcl_Interp* interp, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Obj** dict) //<<< { struct interp_cx* l = NULL; struct parse_spec* spec = NULL; Tcl_Obj* res = NULL; defer { replace_tclobj(&res, NULL); } TEST_OK(get_interp_cx(interp, &l)); TEST_OK(GetParseSpecFromObj(interp, argspec, &spec)); replace_tclobj(&res, Tcl_NewDictObj()); TEST_OK(bind_args(interp, l, spec, objc, objv, put_dict, res)); replace_tclobj(dict, res); return TCL_OK; } //>>> struct slots_cx { Tcl_Size slotc; struct ParseArgs_Slot* slots; }; static int put_slot(void* cx, Tcl_Interp* interp, struct option_info* option, Tcl_Obj* val, bool alias) //<<< { struct slots_cx* c = cx; (void)alias; // Rejected by ParseArgs_BindSlots before binding if (option->decl_idx < 0 || option->decl_idx >= c->slotc) THROW_PRINTF("No slot for \"%s\"", Tcl_GetString(option->name)); struct ParseArgs_Slot* slot = &c->slots[option->decl_idx]; if (slot->type == PARSEARGS_SLOT_SKIP) return TCL_OK; // Hold a reference to the value so that the pointers we store into it stay valid replace_tclobj(&slot->hold, val); switch (slot->type) { case PARSEARGS_SLOT_SKIP: break; case PARSEARGS_SLOT_OBJ: *(Tcl_Obj**)slot->addr = val; break; case PARSEARGS_SLOT_INT: TEST_OK(Tcl_GetIntFromObj(interp, val, (int*)slot->addr)); break; case PARSEARGS_SLOT_WIDEINT: TEST_OK(Tcl_GetWideIntFromObj(interp, val, (Tcl_WideInt*)slot->addr)); break; case PARSEARGS_SLOT_DOUBLE: TEST_OK(Tcl_GetDoubleFromObj(interp, val, (double*)slot->addr)); break; case PARSEARGS_SLOT_STRING: *(const char**)slot->addr = Tcl_GetStringFromObj(val, slot->lenaddr); break; case PARSEARGS_SLOT_LIST: TEST_OK(Tcl_ListObjGetElements(interp, val, slot->lenaddr, (Tcl_Obj***)slot->addr)); break; case PARSEARGS_SLOT_BOOL: //<<< { int b; TEST_OK(Tcl_GetBooleanFromObj(interp, val, &b)); *(bool*)slot->addr = b; } break; //>>> case PARSEARGS_SLOT_BYTES: //<<< { const unsigned char* bytes = Tcl_GetBytesFromObj(interp, val, slot->lenaddr); if (!bytes) return TCL_ERROR; *(const unsigned char**)slot->addr = bytes; } break; //>>> case PARSEARGS_SLOT_INDEX: //<<< { if (!option->enum_choices) THROW_ERROR("INDEX output for \"", Tcl_GetString(option->param), "\" needs -enum"); char** enum_table; TEST_OK(GetEnumChoicesFromObj(interp, option->enum_choices, &enum_table)); TEST_OK(Tcl_GetIndexFromObj(interp, val, (const char**)enum_table, Tcl_GetString(option->param), TCL_EXACT, (int*)slot->addr)); } break; //>>> case PARSEARGS_SLOT_CUSTOM: //<<< if (!slot->convert) THROW_ERROR("No converter for \"", Tcl_GetString(option->param), "\""); TEST_OK(slot->convert(slot->convert_cdata, interp, val, slot->addr)); break; //>>> default: THROW_PRINTF("Invalid slot type %d for \"%s\"", (int)slot->type, Tcl_GetString(option->param)); } return TCL_OK; } //>>> int ParseArgs_BindSlots(Tcl_Interp* interp, Tcl_Obj** cache, const char* specstr, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Size slotc, struct ParseArgs_Slot slots[]) //<<< { struct interp_cx* l = NULL; struct parse_spec* spec = NULL; Tcl_Obj* tmp = NULL; defer { replace_tclobj(&tmp, NULL); } TEST_OK(get_interp_cx(interp, &l)); if (!cache) cache = &tmp; // No cache: build the spec just for this call if (!*cache) replace_tclobj(cache, Tcl_NewStringObj(specstr, -1)); TEST_OK(GetParseSpecFromObj(interp, *cache, &spec)); if (slotc != spec->decl_count) THROW_PRINTF("Got %" TCL_SIZE_MODIFIER "d slots for an argspec with %d entries", slotc, spec->decl_count); if (spec->multi_count) THROW_ERROR("-multi is not supported by ParseArgs_BindSlots"); if (spec->has_alias) THROW_ERROR("-alias is not supported by ParseArgs_BindSlots"); return bind_args(interp, l, spec, objc, objv, put_slot, &(struct slots_cx){ .slotc = slotc, .slots = slots, }); } //>>> // Stubs API >>> extern const Parse_argsStubs* const parse_argsConstStubsPtr; DLLEXPORT int Parse_args_Init(Tcl_Interp* interp) //<<< { /* Require 8.6 or later (9.0 also ok) */ #ifdef USE_TCL_STUBS if (!Tcl_InitStubs(interp, TCL_VERSION, 0)) return TCL_ERROR; #else if (!Tcl_PkgRequire(interp, "Tcl", "8.6-", 0)) return TCL_ERROR; #endif // Have to create the namespace before register_config() (or it will create it for us and ours will fail) Tcl_Namespace* ns = Tcl_CreateNamespace(interp, NS, NULL, NULL); if (!ns) return TCL_ERROR; // Register the pkgconfig (TIP 59) for jitc and other C consumers, when // loaded by pkgIndex.tcl (which runs Init in a frame where $dir is set) const char* dir = Tcl_GetVar(interp, "dir", 0); if (dir) register_config(interp, dir); init_instance_tracking(&g_tracked_instances); struct interp_cx* l = ckalloc(sizeof(struct interp_cx)); *l = (struct interp_cx){}; defer { if (l) free_interp_cx(l, interp); } for (int i=0; iobj[i], Tcl_NewStringObj(static_str[i], -1)); replace_tclobj(&l->enums, Tcl_NewDictObj()); Tcl_SetAssocData(interp, PACKAGE_NAME, free_interp_cx, l); Tcl_CreateObjCommand(interp, NS "::parse_args", parse_args, l, NULL); TEST_OK(Tcl_Export(interp, ns, "parse_args", 0)); l = NULL; TEST_OK(Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION, parse_argsConstStubsPtr)); return TCL_OK; } //>>> DLLEXPORT int Parse_args_SafeInit(Tcl_Interp* interp) //<<< { // No unsafe features return Parse_args_Init(interp); } //>>> DLLEXPORT int Parse_args_Unload(Tcl_Interp* interp, int flags) //<<< { Tcl_DeleteAssocData(interp, PACKAGE_NAME); Tcl_Namespace* ns = Tcl_FindNamespace(interp, NS, NULL, TCL_GLOBAL_ONLY); if (ns) Tcl_DeleteNamespace(ns); // Also has the effect of reversing `register_config` (pkgconfig command is deleted) if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) finalize_instance_tracking(&g_tracked_instances); return TCL_OK; } //>>> DLLEXPORT int Parse_args_SafeUnload(Tcl_Interp* interp, int flags) //<<< { return Parse_args_Unload(interp, flags); } //>>> // vim: foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 noexpandtab RubyLane-parse_args-b4f953b/parse_args.decls000066400000000000000000000015701526416560500211560ustar00rootroot00000000000000library parse_args interface parse_args # Bind objc/objv against argspec, calling cb for each bound value declare 0 generic { int ParseArgs_Bind(Tcl_Interp* interp, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], ParseArgs_BindCallback* cb, void* cdata) } # Bind objc/objv against argspec, leaving the result in *dict (replace_tclobj semantics) declare 1 generic { int ParseArgs_BindDict(Tcl_Interp* interp, Tcl_Obj* argspec, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Obj** dict) } # Bind objc/objv against the argspec cached in *cache (built from specstr if # NULL, or a temporary if cache is NULL), converting each value into # slots[decl_idx]. Used by parseargs_bind.def declare 2 generic { int ParseArgs_BindSlots(Tcl_Interp* interp, Tcl_Obj** cache, const char* specstr, Tcl_Size objc, Tcl_Obj*const objv[], Tcl_Size slotc, struct ParseArgs_Slot slots[]) } # vim: ft=tcl RubyLane-parse_args-b4f953b/parse_args.h.in000066400000000000000000000125611526416560500207220ustar00rootroot00000000000000#ifndef PARSE_ARGS_H #define PARSE_ARGS_H #include #include /* Tcl 8.6 has no Tcl_Size (TIP 660): provide it as Tcl 8.7's tcl.h does. The * guards let this coexist with a consumer's own polyfill (such as teabase's * config.h #define Tcl_Size int), whichever comes first. */ #if TCL_MAJOR_VERSION < 9 && !defined(TCL_SIZE_MAX) # ifndef Tcl_Size typedef int Tcl_Size; # endif # define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1)) # ifndef TCL_SIZE_MODIFIER # define TCL_SIZE_MODIFIER "" # endif #endif #ifdef __cplusplus extern "C" { #endif #ifdef BUILD_parse_args #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT #endif /* ParseArgs_Bind callback: called once for each value bound. decl_idx is the * index of the argspec entry (counting options and positionals, in the order * they appear in the argspec) that produced the value, or -1 for the value of * a -multi group. name is the output name (the -name setting, or the entry's * name without the leading "-" for options). val is only guaranteed to live * until the callback returns: take a reference to keep it. */ typedef int (ParseArgs_BindCallback)(void* cdata, Tcl_Interp* interp, Tcl_Size decl_idx, Tcl_Obj* name, Tcl_Obj* val); /* Slot types for ParseArgs_BindSlots: how a bound value is converted and * stored at a ParseArgs_Slot's addr */ enum ParseArgs_SlotType { PARSEARGS_SLOT_SKIP, /* Don't store this value */ PARSEARGS_SLOT_OBJ, /* Tcl_Obj*: the value (borrowed: kept alive by the slot's hold) */ PARSEARGS_SLOT_BOOL, /* bool */ PARSEARGS_SLOT_INT, /* int */ PARSEARGS_SLOT_WIDEINT, /* Tcl_WideInt */ PARSEARGS_SLOT_DOUBLE, /* double */ PARSEARGS_SLOT_STRING, /* const char*, length to lenaddr if not NULL */ PARSEARGS_SLOT_BYTES, /* const unsigned char*, length to lenaddr if not NULL */ PARSEARGS_SLOT_LIST, /* Tcl_Obj**: the list elements, count to lenaddr */ PARSEARGS_SLOT_INDEX, /* int: the index of the value in the entry's -enum choices */ PARSEARGS_SLOT_CUSTOM, /* convert(convert_cdata, interp, val, addr) */ }; typedef int (ParseArgs_SlotConverter)(void* cdata, Tcl_Interp* interp, Tcl_Obj* val, void* addr); struct ParseArgs_Slot { enum ParseArgs_SlotType type; void* addr; Tcl_Size* lenaddr; ParseArgs_SlotConverter* convert; void* convert_cdata; /* Set by ParseArgs_BindSlots: a reference to the bound value, which keeps * the pointers stored at addr valid. Must start as NULL, and be released * by the caller (ParseArgs_ReleaseSlots) once it is done with the values */ Tcl_Obj* hold; }; static inline void ParseArgs_ReleaseSlots(Tcl_Size slotc, struct ParseArgs_Slot slots[]) { for (Tcl_Size i=0; i(name) to declare its member(s) in the * output struct, and a PARSEARGS_SLOTFOR_(out, name) giving the * initializer of its struct ParseArgs_Slot. Consumers can add their own (with * PARSEARGS_SLOT_CUSTOM and a converter). */ #define PARSEARGS_OUTTYPE_SKIP(name) #define PARSEARGS_OUTTYPE_OBJ(name) Tcl_Obj* name; #define PARSEARGS_OUTTYPE_BOOL(name) bool name; #define PARSEARGS_OUTTYPE_INT(name) int name; #define PARSEARGS_OUTTYPE_WIDEINT(name) Tcl_WideInt name; #define PARSEARGS_OUTTYPE_DOUBLE(name) double name; #define PARSEARGS_OUTTYPE_STRING(name) const char* name; #define PARSEARGS_OUTTYPE_BYTES(name) const unsigned char* name; Tcl_Size name##_len; #define PARSEARGS_OUTTYPE_LIST(name) Tcl_Size name##c; Tcl_Obj** name##v; #define PARSEARGS_OUTTYPE_INDEX(name) int name; #define PARSEARGS_SLOTFOR_SKIP(out, name) {PARSEARGS_SLOT_SKIP} #define PARSEARGS_SLOTFOR_OBJ(out, name) {PARSEARGS_SLOT_OBJ, &(out).name} #define PARSEARGS_SLOTFOR_BOOL(out, name) {PARSEARGS_SLOT_BOOL, &(out).name} #define PARSEARGS_SLOTFOR_INT(out, name) {PARSEARGS_SLOT_INT, &(out).name} #define PARSEARGS_SLOTFOR_WIDEINT(out, name) {PARSEARGS_SLOT_WIDEINT, &(out).name} #define PARSEARGS_SLOTFOR_DOUBLE(out, name) {PARSEARGS_SLOT_DOUBLE, &(out).name} #define PARSEARGS_SLOTFOR_STRING(out, name) {PARSEARGS_SLOT_STRING, &(out).name} #define PARSEARGS_SLOTFOR_BYTES(out, name) {PARSEARGS_SLOT_BYTES, &(out).name, &(out).name##_len} #define PARSEARGS_SLOTFOR_LIST(out, name) {PARSEARGS_SLOT_LIST, &(out).name##v, &(out).name##c} #define PARSEARGS_SLOTFOR_INDEX(out, name) {PARSEARGS_SLOT_INDEX, &(out).name} /* Internal helpers for parseargs_bind.def */ #define PARSEARGS__CAT_(a, b) a##b #define PARSEARGS__CAT(a, b) PARSEARGS__CAT_(a, b) #define PARSEARGS__MEMBER(name, settings, conv) PARSEARGS_OUTTYPE_##conv(name) #define PARSEARGS__SLOT(name, settings, conv) PARSEARGS_SLOTFOR_##conv(PARSEARGS_OUT, name), #define PARSEARGS__OPT_STR(name, settings, conv) "-" #name " {" settings "}\n" #define PARSEARGS__ARG_STR(name, settings, conv) #name " {" settings "}\n" #ifdef USE_PARSE_ARGS_STUBS extern const char* Parse_argsInitializeStubs(Tcl_Interp* interp); #define ParseArgs_InitStubs(interp) Parse_argsInitializeStubs((interp)) #else #define ParseArgs_InitStubs(interp) Tcl_PkgRequire((interp), "@PACKAGE_NAME@", "@PACKAGE_VERSION@", 0) #endif #include "parse_argsDecls.h" EXTERN int Parse_args_Init(Tcl_Interp* interp); EXTERN int Parse_args_SafeInit(Tcl_Interp* interp); #ifdef __cplusplus } #endif #endif RubyLane-parse_args-b4f953b/parse_args.pc.in000066400000000000000000000005651526416560500210760ustar00rootroot00000000000000pkg_dir=${pcfiledir}/../@PKG_DIR_BASENAME@ # tcl_pkg_path: directory a Tcl interpreter should add to auto_path # for `package require @PACKAGE_NAME@` to resolve to this install. tcl_pkg_path=${pkg_dir} Name: @PACKAGE_NAME@ Description: Argument parser for Tcl scripts Version: @PACKAGE_VERSION@ Cflags: -I${pkg_dir} -DUSE_PARSE_ARGS_STUBS=1 Libs: -L${pkg_dir} -l@STUBLIB@ RubyLane-parse_args-b4f953b/parse_argsInt.h000066400000000000000000000005401526416560500207620ustar00rootroot00000000000000#ifndef _PARSE_ARGS_MAIN_H #define _PARSE_ARGS_MAIN_H #include #include #include #include #include #include #include #include #include #include #include #include #include #endif RubyLane-parse_args-b4f953b/parse_argsStubLib.c000066400000000000000000000013271526416560500215730ustar00rootroot00000000000000#if HAVE_CONFIG_H # include #endif #undef USE_TCL_STUBS #undef USE_PARSE_ARGS_STUBS #define USE_TCL_STUBS 1 #define USE_PARSE_ARGS_STUBS 1 #include MODULE_SCOPE const Parse_argsStubs* parse_argsStubsPtr; const Parse_argsStubs* parse_argsStubsPtr = NULL; #undef Parse_argsInitializeStubs MODULE_SCOPE const char* Parse_argsInitializeStubs(Tcl_Interp* interp) { const char* got = Tcl_PkgRequireEx(interp, PACKAGE_NAME, PACKAGE_VERSION, 0, &parse_argsStubsPtr); if (got && !parse_argsStubsPtr) { // Something provided the package without a stubs table Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s %s was provided without a stubs table", PACKAGE_NAME, got)); return NULL; } return got; } RubyLane-parse_args-b4f953b/parseargs_bind.def000066400000000000000000000064141526416560500214610ustar00rootroot00000000000000/* Bind a Tcl_ObjCmdProc's arguments into a struct local, declared with an * X-macro. Include inside the function body after defining PARSEARGS_SPEC: * * OBJCMD(foo) { * #define PARSEARGS_SPEC(OPT, ARG) \ * OPT( verbose, "-boolean", BOOL ) \ * ARG( name, "-required", STRING ) \ * ARG( count, "-default 1", INT ) \ * // line intentionally left blank * #include * * // args.verbose, args.name, args.count * } * * Each entry is (name, settings, out-type): name is the C member name (and the * argspec name: OPT entries get a leading "-"), settings are the parse_args * settings for the entry, as a string literal, and the out-type is one of the * PARSEARGS_OUTTYPE_* from parse_args.h (SKIP OBJ BOOL INT WIDEINT DOUBLE STRING * BYTES LIST INDEX), or one defined by the consumer. Entries not supplied and * with no -default are left zeroed. * * Optional settings (each is #undef'd at the end, ready for the next use): * PARSEARGS_OUT name of the struct local (args) * PARSEARGS_INTERP (interp) * PARSEARGS_OBJC (objc-1) * PARSEARGS_OBJV (objv+1) * PARSEARGS_CACHE Tcl_Obj** slot where the argspec Tcl_Obj is cached across * calls, or NULL to build it for each call. The default * is the per-binding slot a jitc OBJCMD gets as its cdata * ((Tcl_Obj**)cdata, NULL under jitc::capply). Override * this if cdata is something else. * PARSEARGS_ON_ERROR statement run if binding fails, with the error in the * interp result (return TCL_ERROR) * * Values are converted from Tcl_Objs that the struct holds references to: * pointers (STRING, BYTES, LIST, OBJ) stay valid until it goes out of scope, * when they are released (by defer, so C23 + defer is required). */ #ifndef PARSEARGS_SPEC # error "PARSEARGS_SPEC must be defined before including parseargs_bind.def" #endif #ifndef PARSEARGS_OUT # define PARSEARGS_OUT args #endif #ifndef PARSEARGS_INTERP # define PARSEARGS_INTERP interp #endif #ifndef PARSEARGS_OBJC # define PARSEARGS_OBJC objc-1 #endif #ifndef PARSEARGS_OBJV # define PARSEARGS_OBJV objv+1 #endif #ifndef PARSEARGS_CACHE # define PARSEARGS_CACHE ((Tcl_Obj**)cdata) #endif #ifndef PARSEARGS_ON_ERROR # define PARSEARGS_ON_ERROR return TCL_ERROR #endif struct { PARSEARGS_SPEC(PARSEARGS__MEMBER, PARSEARGS__MEMBER) } PARSEARGS_OUT = {}; /* One slot per argspec entry, in declaration order (ParseArgs_BindSlots * addresses them by the entry's index) */ struct ParseArgs_Slot PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)[] = { PARSEARGS_SPEC(PARSEARGS__SLOT, PARSEARGS__SLOT) }; defer { ParseArgs_ReleaseSlots( sizeof(PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)) / sizeof(PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)[0]), PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)); } if (ParseArgs_BindSlots(PARSEARGS_INTERP, PARSEARGS_CACHE, PARSEARGS_SPEC(PARSEARGS__OPT_STR, PARSEARGS__ARG_STR), PARSEARGS_OBJC, PARSEARGS_OBJV, sizeof(PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)) / sizeof(PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)[0]), PARSEARGS__CAT(PARSEARGS_OUT, _parseargs_slots)) != TCL_OK) PARSEARGS_ON_ERROR; #undef PARSEARGS_SPEC #undef PARSEARGS_OUT #undef PARSEARGS_INTERP #undef PARSEARGS_OBJC #undef PARSEARGS_OBJV #undef PARSEARGS_CACHE #undef PARSEARGS_ON_ERROR // vim: ft=c RubyLane-parse_args-b4f953b/pkgIndex.tcl.in000066400000000000000000000002641526416560500206750ustar00rootroot00000000000000# # Tcl package index file # package ifneeded @PACKAGE_NAME@ @PACKAGE_VERSION@ [list apply {dir { load [file join $dir @PKG_LIB_FILE@] [string totitle @PACKAGE_NAME@] }} $dir] RubyLane-parse_args-b4f953b/subprojects/000077500000000000000000000000001526416560500203545ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/subprojects/libtommath.wrap000077700000000000000000000000001526416560500326172../teabase/subprojects/libtommath.wrapustar00rootroot00000000000000RubyLane-parse_args-b4f953b/subprojects/packagefiles/000077500000000000000000000000001526416560500227725ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/subprojects/packagefiles/libtommath000077700000000000000000000000001526416560500361462../../teabase/subprojects/packagefiles/libtommathustar00rootroot00000000000000RubyLane-parse_args-b4f953b/subprojects/packagefiles/tcl000077700000000000000000000000001526416560500332122../../teabase/subprojects/packagefiles/tclustar00rootroot00000000000000RubyLane-parse_args-b4f953b/subprojects/tcl.wrap000077700000000000000000000000001526416560500276632../teabase/subprojects/tcl.wrapustar00rootroot00000000000000RubyLane-parse_args-b4f953b/suppressions000066400000000000000000000006451526416560500205160ustar00rootroot00000000000000{ Tcl Memcheck:Leak ... fun:TclInitByteCode ... } { Tcl Memcheck:Leak ... fun:Tcl_ObjPrintf fun:Tcl_MainEx fun:main } { Tcl Memcheck:Leak ... fun:Tcl_CreateLiteral ... } { Tcl Memcheck:Leak ... fun:TclCreateLiteral ... } { Tcl Memcheck:Leak ... fun:Tcl_CompileCmdLiteral ... } { Tcl Memcheck:Leak ... fun:CompileCmdLiteral ... } { Tcl Memcheck:Leak ... fun:Tcl_CreateInterp fun:main } RubyLane-parse_args-b4f953b/teabase/000077500000000000000000000000001526416560500174155ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/tests/000077500000000000000000000000001526416560500171535ustar00rootroot00000000000000RubyLane-parse_args-b4f953b/tests/alias.test000066400000000000000000000157431526416560500211570ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands # Options test alias-1.1 {alias scalar, option, exists} -setup { #<<< set target alias-1.1-testval } -body { list {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } set existed [info exists aliased] set was $aliased append aliased -updated list $existed $was }} -aliased target] $target } -cleanup { unset -nocomplain target } -result {1 alias-1.1-testval alias-1.1-testval-updated} #>>> test alias-1.2 {alias scalar, option, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target] {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } list [info exists aliased] [set aliased alias-1.2-testval] }} -aliased target] $target } -cleanup { unset -nocomplain target } -result {0 0 alias-1.2-testval alias-1.2-testval} #>>> test alias-2.1 {alias array, option, exists} -setup { #<<< array set target {foo alias-2.1-testval} } -body { list {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } set existed [info exists aliased(foo)] set was $aliased(foo) append aliased(foo) -updated list $existed $was }} -aliased target] $target(foo) } -cleanup { unset -nocomplain target } -result {1 alias-2.1-testval alias-2.1-testval-updated} #>>> test alias-2.2 {alias array, option, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target] {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } list [info exists aliased] [set aliased(foo) alias-2.2-testval] }} -aliased target] $target(foo) } -cleanup { unset -nocomplain target } -result {0 0 alias-2.2-testval alias-2.2-testval} #>>> test alias-3.1 {alias array element, option, exists} -setup { #<<< array set target {foo alias-3.1-testval} } -body { list {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } set existed [info exists aliased] set was $aliased append aliased -updated list $existed $was }} -aliased target(foo)] $target(foo) } -cleanup { unset -nocomplain target } -result {1 alias-3.1-testval alias-3.1-testval-updated} #>>> test alias-3.2 {alias array element, option, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target(foo)] {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -required} } list [info exists aliased] [set aliased alias-3.2-testval] }} -aliased target(foo)] $target(foo) } -cleanup { unset -nocomplain target } -result {0 0 alias-3.2-testval alias-3.2-testval} #>>> test alias-4.1 {default handling, option, supplied, exists} -setup { #<<< set target alias-4.1-testval } -body { list {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -default alias-4.1-default} } set was $aliased append aliased -updated list [info exists aliased] $was }} -aliased target] $target } -cleanup { unset -nocomplain target } -result {1 alias-4.1-testval alias-4.1-testval-updated} #>>> test alias-4.2 {default handling, option, not supplied, exists} -setup { #<<< set target alias-4.2-testval } -body { list {*}[apply {args { parse_args::parse_args $args { -aliased {-alias -default alias-4.2-default} } set was $aliased append aliased -updated list [info exists aliased] $was }}] $target } -cleanup { unset -nocomplain target } -result {1 alias-4.2-default alias-4.2-testval} #>>> # Positional params test alias-11.1 {alias scalar, positional, exists} -setup { #<<< set target alias-11.1-testval } -body { list {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } set existed [info exists aliased] set was $aliased append aliased -updated list $existed $was }} target] $target } -cleanup { unset -nocomplain target } -result {1 alias-11.1-testval alias-11.1-testval-updated} #>>> test alias-11.2 {alias scalar, positional, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target] {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } list [info exists aliased] [set aliased alias-11.2-testval] }} target] $target } -cleanup { unset -nocomplain target } -result {0 0 alias-11.2-testval alias-11.2-testval} #>>> test alias-12.1 {alias array, positional, exists} -setup { #<<< array set target {foo alias-12.1-testval} } -body { list {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } set existed [info exists aliased(foo)] set was $aliased(foo) append aliased(foo) -updated list $existed $was }} target] $target(foo) } -cleanup { unset -nocomplain target } -result {1 alias-12.1-testval alias-12.1-testval-updated} #>>> test alias-12.2 {alias array, positional, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target] {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } list [info exists aliased] [set aliased(foo) alias-12.2-testval] }} target] $target(foo) } -cleanup { unset -nocomplain target } -result {0 0 alias-12.2-testval alias-12.2-testval} #>>> test alias-13.1 {alias array element, positional, exists} -setup { #<<< array set target {foo alias-13.1-testval} } -body { list {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } set existed [info exists aliased] set was $aliased append aliased -updated list $existed $was }} target(foo)] $target(foo) } -cleanup { unset -nocomplain target } -result {1 alias-13.1-testval alias-13.1-testval-updated} #>>> test alias-13.2 {alias array element, positional, doesn't exist} -setup { #<<< unset -nocomplain target } -body { list [info exists target(foo)] {*}[apply {args { parse_args::parse_args $args { aliased {-alias -required} } list [info exists aliased] [set aliased alias-13.2-testval] }} target(foo)] $target(foo) } -cleanup { unset -nocomplain target } -result {0 0 alias-13.2-testval alias-13.2-testval} #>>> test alias-14.1 {default handling, positional, supplied, exists} -setup { #<<< set target alias-14.1-testval } -body { list {*}[apply {args { parse_args::parse_args $args { aliased {-alias -default alias-14.1-default} } set was $aliased append aliased -updated list [info exists aliased] $was }} target] $target } -cleanup { unset -nocomplain target } -result {1 alias-14.1-testval alias-14.1-testval-updated} #>>> test alias-14.2 {default handling, option, not supplied, exists} -setup { #<<< set target alias-14.2-testval } -body { list {*}[apply {args { parse_args::parse_args $args { aliased {-alias -default alias-14.2-default} } set was $aliased append aliased -updated list [info exists aliased] $was }}] $target } -cleanup { unset -nocomplain target } -result {1 alias-14.2-default alias-14.2-testval} #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/all.tcl000066400000000000000000000005261526416560500204320ustar00rootroot00000000000000package require tcltest namespace import ::tcltest::* ::tcltest::configure -singleproc 1 {*}$argv -testdir [file dirname [info script]] set failed [::tcltest::runAllTests] ::tcltest::cleanupTests 0 if {$failed} { puts $::tcltest::outputChannel "[file tail [info script]]: $failed test(s) failed" close stderr error "test run failed" } RubyLane-parse_args-b4f953b/tests/comment.test000066400000000000000000000013531526416560500215200ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands # Options test comment-1.1 {basic usage} -body { #<<< parse_args::parse_args {-state disabled} { -state {-enum {normal disabled readonly} -# {This is a comment}} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> # Positional params test comment-2.1 {basic usage} -body { #<<< parse_args::parse_args disabled { state {-enum {normal disabled readonly} -# {This is a comment}} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/enum.test000066400000000000000000000140031526416560500210160ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands # Options test enum-1.1 {basic usage} -body { #<<< parse_args::parse_args {-state disabled} { -state {-enum {normal disabled readonly}} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> test enum-2.1 {invalid value} -body { #<<< set code [catch { parse_args::parse_args {-state new} { -state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad -state "new": must be normal, disabled, or readonly} {TCL LOOKUP INDEX -state new}} #>>> test enum-3.1 {valid value, with default} -body { #<<< parse_args::parse_args {-state disabled} { -state {-enum {normal disabled readonly} -default normal} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> test enum-3.2 {no value, with default} -body { #<<< parse_args::parse_args {} { -state {-enum {normal disabled readonly} -default normal} } set state } -cleanup { unset -nocomplain state } -result normal #>>> test enum-3.3 {no value, with invalid default} -body { #<<< parse_args::parse_args {} { -state {-enum {normal disabled readonly} -default new} } set state } -cleanup { unset -nocomplain state } -result new #>>> test enum-4.3 {no value, required, with default} -body { #<<< parse_args::parse_args {} { -state {-enum {normal disabled readonly} -default normal -required} } set state } -cleanup { unset -nocomplain state } -result normal #>>> test enum-4.4 {no value, required, no default} -body { #<<< set code [catch { parse_args::parse_args {} { -state {-enum {normal disabled readonly} -required} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain state } -result {1 {option -state is required} {PARSE_ARGS REQUIRED -state}} #>>> test enum-5.1 {specified twice, both valid} -body { #<<< parse_args::parse_args {-state disabled -state readonly} { -state {-enum {normal disabled readonly}} } set state } -cleanup { unset -nocomplain state } -result readonly #>>> test enum-5.2 {specified twice, first invalid} -body { #<<< set code [catch { parse_args::parse_args {-state new -state readonly} { -state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad -state "new": must be normal, disabled, or readonly} {TCL LOOKUP INDEX -state new}} #>>> test enum-5.3 {specified twice, second invalid} -body { #<<< set code [catch { parse_args::parse_args {-state readonly -state new} { -state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad -state "new": must be normal, disabled, or readonly} {TCL LOOKUP INDEX -state new}} #>>> test enum-6.1 {two enums} -body { #<<< parse_args::parse_args {-state disabled -validate focusout} { -state {-enum {normal disabled readonly}} -validate {-enum {none focus focusin focusout key all}} } list $state $validate } -cleanup { unset -nocomplain state validate } -result {disabled focusout} #>>> test enum-6.2 {prefix values} -body { #<<< set code [catch { parse_args::parse_args {-state d} { -state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad -state "d": must be normal, disabled, or readonly} {TCL LOOKUP INDEX -state d}} #>>> # Positional params test enum-11.1 {basic usage} -body { #<<< parse_args::parse_args disabled { state {-enum {normal disabled readonly}} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> test enum-12.1 {invalid value} -body { #<<< set code [catch { parse_args::parse_args new { state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad state "new": must be normal, disabled, or readonly} {TCL LOOKUP INDEX state new}} #>>> test enum-13.1 {valid value, with default} -body { #<<< parse_args::parse_args disabled { state {-enum {normal disabled readonly} -default normal} } set state } -cleanup { unset -nocomplain state } -result disabled #>>> test enum-13.2 {no value, with default} -body { #<<< parse_args::parse_args {} { state {-enum {normal disabled readonly} -default normal} } set state } -cleanup { unset -nocomplain state } -result normal #>>> test enum-13.3 {no value, with invalid default} -body { #<<< parse_args::parse_args {} { state {-enum {normal disabled readonly} -default new} } set state } -cleanup { unset -nocomplain state } -result new #>>> test enum-14.3 {no value, required, with default} -body { #<<< parse_args::parse_args {} { state {-enum {normal disabled readonly} -default normal -required} } set state } -cleanup { unset -nocomplain state } -result normal #>>> test enum-14.4 {no value, required, no default} -body { #<<< set code [catch { parse_args::parse_args {} { state {-enum {normal disabled readonly} -required} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain state } -result {1 {argument state is required} {PARSE_ARGS REQUIRED state}} #>>> test enum-16.1 {two enums} -body { #<<< parse_args::parse_args {disabled focusout} { state {-enum {normal disabled readonly}} validate {-enum {none focus focusin focusout key all}} } list $state $validate } -cleanup { unset -nocomplain state validate } -result {disabled focusout} #>>> test enum-16.2 {prefix values} -body { #<<< set code [catch { parse_args::parse_args d { state {-enum {normal disabled readonly}} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {bad state "d": must be normal, disabled, or readonly} {TCL LOOKUP INDEX state d}} #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/multi.test000066400000000000000000000167371526416560500212240ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands test multi-1.1 {basic usage} -body { #<<< parse_args::parse_args {-dictionary} { -ascii {-multi -name compare_as} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } set compare_as } -cleanup { unset -nocomplain compare_as } -result dictionary #>>> test multi-1.2 {no value, default on first} -body { #<<< parse_args::parse_args {} { -ascii {-multi -name compare_as -default foo} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } set compare_as } -cleanup { unset -nocomplain compare_as } -result foo #>>> test multi-1.3 {no value, default on second} -body { #<<< parse_args::parse_args {} { -ascii {-multi -name compare_as} -dictionary {-multi -name compare_as -default foo} -integer {-multi -name compare_as} } set compare_as } -cleanup { unset -nocomplain compare_as } -result foo #>>> test multi-1.4 {no value, no default} -body { #<<< parse_args::parse_args {} { -ascii {-multi -name compare_as} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } info exists compare_as } -cleanup { unset -nocomplain compare_as } -result 0 #>>> test multi-1.5 {no value, required on first} -body { #<<< set code [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as -required} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {one of -ascii -dictionary -integer are required} {PARSE_ARGS REQUIRED_ONE_OF {-ascii -dictionary -integer}}} #>>> test multi-1.6 {no value, required on last} -body { #<<< set code [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as -required} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {one of -ascii -dictionary -integer are required} {PARSE_ARGS REQUIRED_ONE_OF {-ascii -dictionary -integer}}} #>>> test multi-1.7 {supplied value, default on first} -body { #<<< parse_args::parse_args {-dictionary} { -ascii {-multi -name compare_as -default foo} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } set compare_as } -cleanup { unset -nocomplain compare_as } -result dictionary #>>> test multi-2.1 {throw error for -multi and -enum} -body { #<<< set code [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as -enum {foo bar}} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as -required} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {Cannot use -multi and -enum together} NONE} #>>> test multi-2.2 {throw error for -multi and -boolean} -constraints knownBug -body { #<<< set code [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as -boolean} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {Cannot use -multi and -boolean together} NONE} #>>> test multi-2.3 {throw error for -multi and -args} -constraints knownBug -body { #<<< set code [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as -args 2} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} } } r o] list $code $r [dict get $o -errorcode] } -cleanup { unset -nocomplain code state r o } -result {1 {Cannot use -multi and -args together} NONE} #>>> test multi-3.1 {two -multis, both default} -body { #<<< parse_args::parse_args {} { -ascii {-multi -name compare_as -default ascii} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order} -decreasing {-multi -name order -default increasing} } list $compare_as $order } -cleanup { unset -nocomplain compare_as order } -result {ascii increasing} #>>> test multi-3.2 {two -multis, first set, second default} -body { #<<< parse_args::parse_args {-dictionary} { -ascii {-multi -name compare_as -default ascii} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order} -decreasing {-multi -name order -default increasing} } list $compare_as $order } -cleanup { unset -nocomplain compare_as order } -result {dictionary increasing} #>>> test multi-3.3 {two -multis, first default, second set} -body { #<<< parse_args::parse_args {-decreasing} { -ascii {-multi -name compare_as -default ascii} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order} -decreasing {-multi -name order -default increasing} } list $compare_as $order } -cleanup { unset -nocomplain compare_as order } -result {ascii decreasing} #>>> test multi-4.1 {two -multis, both required, neither set} -body { #<<< list [catch { parse_args::parse_args {} { -ascii {-multi -name compare_as -required} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order -required} -decreasing {-multi -name order} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o compare_as order } -result [list 1 "one of -ascii -dictionary -integer are required" {PARSE_ARGS REQUIRED_ONE_OF {-ascii -dictionary -integer}}] #>>> test multi-4.2 {two -multis, first set, second missing} -body { #<<< list [catch { parse_args::parse_args {-dictionary} { -ascii {-multi -name compare_as -required} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order -required} -decreasing {-multi -name order} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o compare_as order } -result [list 1 "one of -increasing -decreasing are required" {PARSE_ARGS REQUIRED_ONE_OF {-increasing -decreasing}}] #>>> test multi-4.3 {two -multis, first missing, second set} -body { #<<< list [catch { parse_args::parse_args {-decreasing} { -ascii {-multi -name compare_as -required} -dictionary {-multi -name compare_as} -integer {-multi -name compare_as} -increasing {-multi -name order -required} -decreasing {-multi -name order} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o compare_as order } -result [list 1 "one of -ascii -dictionary -integer are required" {PARSE_ARGS REQUIRED_ONE_OF {-ascii -dictionary -integer}}] #>>> test multi-5.1 {throw error for -multi on positional param} -body { #<<< list [catch { parse_args::parse_args {} { foo {-multi -name compare_as} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o compare_as order } -result [list 1 {Cannot use -multi on positional argument "foo"} NONE] #>>> test multi-6.1 {-multi -all group default applies when no flag is given} -body { #<<< list \ [parse_args::parse_args {} {-a {-name m -multi -all -default x} -b {-name m -multi}}; set m] \ [parse_args::parse_args {} {-a {-name m -multi -all} -b {-name m -multi -default {x y}}}; set m] \ [parse_args::parse_args {-b -a} {-a {-name m -multi -all -default x} -b {-name m -multi}}; set m] } -cleanup { unset -nocomplain m } -result {x {x y} {b a}} #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/parse_args.test000066400000000000000000000445121526416560500222100ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands test parse_args-1.1 {no args, dict mode} -body { #<<< parse_args::parse_args {} {} d set d } -cleanup { unset -nocomplain d } -result {} #>>> test parse_args-1.2 {no args, vars mode} -body { #<<< parse_args::parse_args {} {} } -result {} #>>> test parse_args-2.1 {basic option, dict mode} -body { #<<< parse_args::parse_args {-foo bar} {-foo {}} d set d } -cleanup { unset -nocomplain d } -result {foo bar} #>>> test parse_args-2.2 {basic option, vars mode} -body { #<<< parse_args::parse_args {-foo bar} {-foo {}} set foo } -cleanup { unset -nocomplain foo } -result bar #>>> test parse_args-3.2 {option escape} -body { #<<< parse_args::parse_args {-foo bar -- -baz quux} { -foo {} -bar {} -baz {-default def} a {} b {} } list $foo [info exists bar] $baz $a $b } -cleanup { unset -nocomplain foo bar baz a b } -result {bar 0 def -baz quux} #>>> test parse_args-3.3 {default positional arg} -body { #<<< parse_args::parse_args {a b} { -foo {} first {} second {-default default_second} third {-default default_third} } list $first $second $third } -cleanup { unset -nocomplain foo first second third } -result {a b default_third} #>>> test parse_args-4.1 {-all} -body { #<<< parse_args::parse_args {-ex first -foo a -iex First -ex second -iex Second -ex third -foo b} { -ex {-all} -iex {-all} -foo {} } list $ex $iex $foo } -cleanup { unset -nocomplain ex iex foo } -result {{first second third} {First Second} b} #>>> test parse_args-4.2 {-all -multi} -body { #<<< parse_args::parse_args {-ascii -dictionary -ascii -increasing -decreasing} { -ascii {-multi -name mode -all} -dictionary {-multi -name mode} -increasing {-multi -name order} -decreasing {-multi -name order -all} } list $mode $order } -cleanup { unset -nocomplain mode order } -result {{ascii dictionary ascii} {increasing decreasing}} #>>> test parse_args-4.3 {-all} -body { #<<< parse_args::parse_args {-foo "hello, multi"} { -foo {-all} } set foo } -cleanup { unset -nocomplain foo } -result {{hello, multi}} #>>> test parse_args-4.4 {-all, omitted, default} -body { #<<< parse_args::parse_args {} { -foo {-all -default {}} } set foo } -cleanup { unset -nocomplain foo } -result {} #>>> test parse_args-10.1 {reject negative -args} -body { #<<< parse_args::parse_args {-foo bar} { -foo {-args -1} } set foo } -cleanup { unset -nocomplain foo } -returnCodes error -result {-args cannot be negative} #>>> test parse_args-10.2 {-args 0, supplied} -body { #<<< parse_args::parse_args {-foo} { -foo {-args 0} } set foo } -cleanup { unset -nocomplain foo } -result 1 #>>> test parse_args-10.3 {-args 0, omitted} -body { #<<< parse_args::parse_args {-bar ""} { -foo {-args 0} -bar {} } set foo } -cleanup { unset -nocomplain foo bar } -result 0 #>>> test parse_args-10.4 {-args 3, enough} -body { #<<< parse_args::parse_args {-foo a "b c" d e f g h i j} { -foo {-args 3} -bar {} p1 {} p2 {} args {} } list $foo $p1 $p2 $args } -cleanup { unset -nocomplain foo bar args } -result [list [list a "b c" d] e f {g h i j}] #>>> test parse_args-10.5 {-args 3, too few} -body { #<<< parse_args::parse_args {-foo a "b c"} { -foo {-args 3} -bar {} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -match glob -result * #>>> test parse_args-10.6 {-args all, omitted, no default} -body { #<<< parse_args::parse_args {-bar ""} { -foo {-args all} -bar {} } info exists foo } -cleanup { unset -nocomplain foo bar } -result 0 #>>> test parse_args-10.7 {-args all, omitted, default} -body { #<<< parse_args::parse_args {-bar ""} { -foo {-args all -default {foo bar}} -bar {} } set foo } -cleanup { unset -nocomplain foo bar } -result {foo bar} #>>> test parse_args-10.8 {-args all, omitted, required} -body { #<<< parse_args::parse_args {-bar ""} { -foo {-args all -required} -bar {} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -errorCode {PARSE_ARGS REQUIRED -foo} -result {option -foo is required} #>>> test parse_args-10.9 {-args all, 0 supplied, default} -body { #<<< parse_args::parse_args {-bar "" -foo} { -foo {-args all -default {foo bar}} -bar {} } set foo } -cleanup { unset -nocomplain foo bar } -result {} #>>> test parse_args-10.10 {-args all, 1 supplied, default} -body { #<<< parse_args::parse_args {-bar "" -foo "hello, world"} { -foo {-args all -default {foo bar}} -bar {} } set foo } -cleanup { unset -nocomplain foo bar } -result {{hello, world}} #>>> test parse_args-10.11 {-args all, 4 supplied, required} -body { #<<< parse_args::parse_args {-bar "" -foo "hello, world" x y z} { -foo {-args all -required} -bar {} } set foo } -cleanup { unset -nocomplain foo bar } -result {{hello, world} x y z} #>>> test parse_args-10.12 {-args all, 4 supplied, looks like option} -body { #<<< parse_args::parse_args {-foo "hello, world" -bar "" z} { -foo {-args all} -bar {} } list [info exists bar] $foo } -cleanup { unset -nocomplain foo bar } -result {0 {{hello, world} -bar {} z}} #>>> test parse_args-10.13 {-args 3, positional, supplied} -body { #<<< parse_args::parse_args {a b c d e} { foo {-required} bar {-args 3 -required} baz {-required} } list $foo $bar $baz } -cleanup { unset -nocomplain foo bar baz } -result {a {b c d} e} #>>> test parse_args-10.14 {-args 3, positional, omitted, required} -body { #<<< parse_args::parse_args {a} { foo {-required} bar {-args 3 -required} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -errorCode {PARSE_ARGS REQUIRED bar} -result {argument bar is required} #>>> test parse_args-10.15 {-args 3, positional, omitted, optional} -body { #<<< parse_args::parse_args {a} { foo {-required} bar {-args 3} } list [info exists foo] [info exists bar] } -cleanup { unset -nocomplain foo bar } -result {1 0} #>>> test parse_args-10.16 {-args 3, positional, omitted, default} -body { #<<< parse_args::parse_args {a} { foo {-required} bar {-args 3 -default {x y z}} } list $foo $bar } -cleanup { unset -nocomplain foo bar } -result {a {x y z}} #>>> test parse_args-10.17 {-args 3, positional, insufficient, required} -body { #<<< parse_args::parse_args {a b c} { foo {-required} bar {-args 3 -required} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -errorCode {PARSE_ARGS WRONGARGS bar} -result {Expecting 3 arguments for bar} #>>> test parse_args-10.18 {-args 3, positional, insufficient, optional} -body { #<<< # Under the lookahead consumer, the optional multi-arg positional is # skipped because `remaining (2) < arg_count (3) + sum_later_req (0)`, # so the trailing args are leftover and reported as "too many". parse_args::parse_args {a b c} { foo {-required} bar {-args 3} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -match glob -result {wrong # args*} #>>> test parse_args-10.19 {-args 3, positional, insufficient, default} -body { #<<< # Same shape but bar has -default; bar still gets skipped (default # applied), and the trailing args are leftover. parse_args::parse_args {a b c} { foo {-required} bar {-args 3 -default {x y z}} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -match glob -result {wrong # args*} #>>> test parse_args-11.1 {invalid setting} -body { #<<< parse_args::parse_args {} { -foo {-foo 3} -bar {} } } -cleanup { unset -nocomplain foo bar } -returnCodes error -result {bad setting "-foo": must be -default, -required, -validate, -name, -boolean, -args, -enum, -#, -multi, -alias, -all, or -end} #>>> test parse_args-12.1 {-end, -boolean, supplied} -body { #<<< parse_args::parse_args {-ex a --args -ex e c d} { -ex {-all -default {}} --args {-name se_args -boolean -end} first {} second {} rest {-args all} } list $ex $se_args $first $second $rest } -cleanup { unset -nocomplain ex se_args first second rest } -result {a 1 -ex e {c d}} #>>> test parse_args-12.2 {-end, -boolean, omitted} -body { #<<< parse_args::parse_args {-ex a -ex e c d} { -ex {-all -default {}} --args {-name se_args -boolean -end} first {} second {} rest {-args all} } list $ex $se_args $first $second [info exists rest] } -cleanup { unset -nocomplain ex se_args first second rest } -result {{a e} 0 c d 0} #>>> test parse_args-20.1 {no args} -body { #<<< parse_args::parse_args } -returnCodes error -result {wrong # args: should be "parse_args::parse_args args args_spec ?dict?"} #>>> test parse_args-30.1 {Doesn't generate string rep when spec has no options} -body { #<<< set i [expr {2-1}] parse_args::parse_args [list $i] { foo {} } tcl::unsupported::representation $i } -cleanup { unset -nocomplain i foo } -match glob -result {value is a int * no string representation} #>>> test parse_args-30.2 {String rep avoided when trailing positionals are -required} -body { #<<< # n=1 reserves the last slot as positional so the option scan never touches it. set i [expr {2-1}] parse_args::parse_args [list $i] { -mode {-default x} data {-required} } tcl::unsupported::representation $i } -cleanup { unset -nocomplain i data mode } -match glob -result {value is a int * no string representation} #>>> test parse_args-30.3 {String rep avoided when spec has no options} -body { #<<< # option_count == 0 → option phase is skipped entirely. set i [expr {2-1}] parse_args::parse_args [list $i] { foo {} } tcl::unsupported::representation $i } -cleanup { unset -nocomplain i foo } -match glob -result {value is a int * no string representation} #>>> test parse_args-30.4 {Looks-like-option arg in reserved positional slot} -body { #<<< # `-mode` would otherwise match the option, but n=1 forces the trailing slot # to be positional regardless of leading '-'. parse_args::parse_args {-mode} { -mode {-default x} data {-required} } set data } -cleanup { unset -nocomplain data mode } -result -mode #>>> test parse_args-40.1 {namespace import} -body { #<<< set interp [interp create] $interp eval { load {} Parse_args namespace import ::parse_args::* parse_args {-foo foo-parse_args-40.1} { -foo {-default x} } set foo } } -cleanup { interp delete $interp unset -nocomplain interp } -result foo-parse_args-40.1 #>>> test parse_args-50.1 {-boolean rejected on positional} -body { #<<< parse_args::parse_args {} { flag {-boolean} } } -cleanup { unset -nocomplain flag } -returnCodes error -result {Cannot use -boolean on positional argument "flag"} #>>> test parse_args-50.2 {-args 0 rejected on positional} -body { #<<< parse_args::parse_args {} { zero {-args 0} } } -cleanup { unset -nocomplain zero } -returnCodes error -result {Cannot use -args 0 on positional argument "zero"} #>>> test parse_args-50.3 {Optional positional cannot follow args consumer} -body { #<<< parse_args::parse_args {a} { args {} trailing {} } } -returnCodes error -match glob -result {Positional "trailing" cannot follow*} #>>> test parse_args-50.4 {Optional positional cannot follow -args all consumer} -body { #<<< parse_args::parse_args {a} { middle {-args all} trailing {} } } -returnCodes error -match glob -result {Positional "trailing" cannot follow*} #>>> test parse_args-50.5 {Two args/-args all consumers rejected} -body { #<<< parse_args::parse_args {a} { first {-args all -required} args {} } } -returnCodes error -match glob -result {Cannot have more than one args/-args all*} #>>> test parse_args-51.1 {Lookahead skips optional to reach trailing required (no default)} -body { #<<< # arg0 ?arg1? arg2 — `dothing2` from the design discussion parse_args::parse_args {a b} { arg0 {-required} arg1 {} arg2 {-required} } list $arg0 [info exists arg1] $arg2 } -cleanup { unset -nocomplain arg0 arg1 arg2 } -result {a 0 b} #>>> test parse_args-51.2 {Lookahead applies default for skipped optional} -body { #<<< parse_args::parse_args {a b} { arg0 {-required} arg1 {-default x} arg2 {-required} } list $arg0 $arg1 $arg2 } -cleanup { unset -nocomplain arg0 arg1 arg2 } -result {a x b} #>>> test parse_args-51.3 {Lookahead consumes optional when room allows} -body { #<<< parse_args::parse_args {a b c} { arg0 {-required} arg1 {-default x} arg2 {-required} } list $arg0 $arg1 $arg2 } -cleanup { unset -nocomplain arg0 arg1 arg2 } -result {a b c} #>>> test parse_args-51.4 {Lookahead with multi-arg required positional} -body { #<<< # ?arg1? arg2.1 arg2.2 — `dothing3` parse_args::parse_args {a b} { arg1 {} arg2 {-required -args 2} } list [info exists arg1] $arg2 } -cleanup { unset -nocomplain arg1 arg2 } -result {0 {a b}} #>>> test parse_args-51.5 {args magic with trailing required positional} -body { #<<< # args last_arg{-required} — args reserves space for trailing required. parse_args::parse_args {a b c d} { args {-name leading} last {-required} } list $leading $last } -cleanup { unset -nocomplain leading last } -result {{a b c} d} #>>> test parse_args-51.6 {args magic with empty leading and trailing required} -body { #<<< parse_args::parse_args {only} { args {-name leading} last {-required} } list $leading $last } -cleanup { unset -nocomplain leading last } -result {{} only} #>>> test parse_args-51.7 {-args all positional reserves space for trailing required} -body { #<<< parse_args::parse_args {a b c} { middle {-args all} tail {-required} } list $middle $tail } -cleanup { unset -nocomplain middle tail } -result {{a b} c} #>>> test parse_args-51.8 {dothing4: leading required + optional + trailing required + args tail} -body { #<<< parse_args::parse_args {a b} { arg0 {-required} arg1 {} arg2 {-required} args {-name tailargs} } list $arg0 [info exists arg1] $arg2 $tailargs } -cleanup { unset -nocomplain arg0 arg1 arg2 tailargs } -result {a 0 b {}} #>>> test parse_args-51.9 {dothing4: extra args spill into args} -body { #<<< parse_args::parse_args {a b c d e} { arg0 {-required} arg1 {} arg2 {-required} args {-name tailargs} } list $arg0 $arg1 $arg2 $tailargs } -cleanup { unset -nocomplain arg0 arg1 arg2 tailargs } -result {a b c {d e}} #>>> test parse_args-51.10 {-required + -default treated as optional with default} -body { #<<< parse_args::parse_args {} { state {-default normal -required} } set state } -cleanup { unset -nocomplain state } -result normal #>>> test parse_args-52.1 {Validator re-entering a command using the same spec} -setup { #<<< proc reenter args { parse_args::parse_args $args { -a {-default adef} -b {-validate {apply {v {if {$v eq "outer"} {reenter -b inner}; return 1}}}} } list $a $b } } -body { # The inner call must not clobber the outer's record of which options were # supplied (-a was, so it must keep its value, not get the default) reenter -a x -b outer } -cleanup { rename reenter {} } -result {x outer} #>>> test parse_args-52.2 {Validator shimmering the spec obj mid-bind} -setup { #<<< set ::spec_52_2 { -a {-validate {apply {v {llength [dict keys $::spec_52_2]; return 1}}}} -b {-default bdef} c {} } # Make the dict / list shimmer replace the parse_spec intrep: the bind in # progress must keep the compiled spec alive proc shimmer args { parse_args::parse_args $args $::spec_52_2 list $a $b $c } } -body { list [shimmer -a x y] [shimmer -a z w] } -cleanup { rename shimmer {} unset -nocomplain ::spec_52_2 } -result {{x bdef y} {z bdef w}} #>>> test parse_args-52.3 {Pure list spec (no string rep)} -body { #<<< set spec [list] lappend spec -a {-default 1} b {} parse_args::parse_args {x} $spec list $a $b [string length $spec] } -cleanup { unset -nocomplain spec a b } -result {1 x 20} #>>> test parse_args-52.4 {Load into an interp without $dir (no pkgconfig)} -setup { #<<< set child [interp create] } -body { load {} Parse_args $child interp eval $child { parse_args::parse_args {x} {a {}} list $a [llength [info commands ::parse_args::pkgconfig]] } } -cleanup { interp delete $child unset -nocomplain child } -result {x 0} #>>> test parse_args-52.5 {Unknown option: message lists the options, errorcode as Tcl_GetIndexFromObj} -body { #<<< list \ [catch {parse_args::parse_args {-y 1} {-x {}}} r o] $r [dict get $o -errorcode] \ [catch {parse_args::parse_args {-y 1} {-x {} a {} -b {-boolean}}} r] $r \ [catch {parse_args::parse_args {-y 1} {-x {} -c {-multi -name m} a {} -b {-boolean}}} r] $r } -cleanup { unset -nocomplain r o } -result [list \ 1 {bad option "-y": must be -x} {TCL LOOKUP INDEX option -y} \ 1 {bad option "-y": must be -x or -b} \ 1 {bad option "-y": must be -x, -c, or -b} \ ] #>>> test parse_args-52.6 {wrong # args usage is generated from the argspec, without a command name} -setup { #<<< set spec { -x {} -flag {-boolean} -state {-enum {normal disabled} -required} -pair {-args 2} -a {-multi -name m} -c {-args all} a {-required} b {} p2 {-args 2 -default {}} } proc foo args {parse_args::parse_args $args $::spec} } -body { list \ [catch {foo -state normal 1 2 3 4 5} r o] $r [dict get $o -errorcode] \ [catch {parse_args::parse_args {1 2} {a {}}} r] $r } -cleanup { rename foo {} unset -nocomplain spec r o } -result [list \ 1 {wrong # args: should be "?-x x? ?-flag? -state normal|disabled ?-pair pair pair? ?-a? ?-c c ...? a ?b? ?p2 p2?"} {TCL WRONGARGS} \ 1 {wrong # args: should be "?a?"} \ ] #>>> test parse_args-52.7 {Duplicate argspec entries are rejected} -body { #<<< list \ [catch {parse_args::parse_args {-x 1} {-x {} -x {-required}}} r] $r \ [catch {parse_args::parse_args {1 2} {a {} -y {} a {}}} r] $r \ [catch {parse_args::parse_args {-a} {-a {-multi -name m} -b {-multi -name m}}} r] $r $m } -cleanup { unset -nocomplain r m } -result [list \ 1 {Duplicate argspec entry "-x"} \ 1 {Duplicate argspec entry "a"} \ 0 {} a \ ] #>>> test parse_args-52.8 {With no options in the spec, leading - args (and --) are positional values} -body { #<<< list \ [parse_args::parse_args {-foo} {name {-required}}; set name] \ [parse_args::parse_args {--} {name {-required}}; set name] \ [parse_args::parse_args {-foo} {name {-default x}}; set name] \ [parse_args::parse_args {-- -foo} {a {} b {}}; list $a $b] \ [parse_args::parse_args {-foo -bar} {a {} rest {-args all}}; list $a $rest] \ [catch {parse_args::parse_args {-- -foo} {name {-required}}} r] $r } -cleanup { unset -nocomplain name a b rest r } -result [list \ -foo \ -- \ -foo \ {-- -foo} \ {-foo -bar} \ 1 {wrong # args: should be "name"} \ ] #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/safeinterp.test000066400000000000000000000020651526416560500222170ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands test safeinterp-1.1 {Loading into safe interp} -setup { #<<< set slave [interp create -safe] } -body { $slave invokehidden load {} Parse_args $slave eval { parse_args::parse_args {-test foo-1.1} { -test {-required} } set test } } -cleanup { if {[info exists slave]} { interp delete $slave unset slave } } -result foo-1.1 #>>> test safeinterp-1.2 {Loading into safe interp using package require} -setup { #<<< set slave [safe::interpCreate] } -body { $slave eval [list set ::auto_path [list [file normalize [file join [info script] .. ..]] {*}$::auto_path]] $slave eval { package require parse_args parse_args::parse_args {-test foo-1.2} { -test {-required} } set test } } -cleanup { if {[info exists slave]} { safe::interpDelete $slave unset slave } } -result foo-1.2 #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/stubs.test000066400000000000000000000241551526416560500212230ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } ::tcltest::loadTestedCommands testConstraint haveJitc [expr {![catch {package require jitc 0.8}]}] # The commands in stubs_api.c exercise the C API from a separately compiled # consumer: ::parse_args_direct::* are compiled by jitc and linked directly # against the package library (jitc's "package" part, driven by # parse_args::pkgconfig), and ::parse_args_stubs::* are in a meson-built # extension that goes through the stubs table (libparse_argsstub.a). jitc # can't link static libraries, so it can't test the stubs path itself. variable direct_cdef [list \ options {-Wall -Werror} \ package [list parse_args [package present parse_args]] \ include_path [file dirname [file normalize [info script]]] \ code { #include "stubs_api.c" INIT { return stubs_api_register(interp, "::parse_args_direct"); } RELEASE { Tcl_Namespace* ns = Tcl_FindNamespace(interp, "::parse_args_direct", NULL, 0); if (ns) Tcl_DeleteNamespace(ns); } OBJCMD(compile) { return TCL_OK; } } \ ] if {[testConstraint haveJitc]} { jitc::capply $direct_cdef compile } set consumer [file join [file dirname [parse_args::pkgconfig get libdir,runtime]] libparse_argsstubsconsumer[info sharedlibextension]] testConstraint haveStubsConsumer [file exists $consumer] if {[testConstraint haveStubsConsumer]} { load $consumer Parse_argsstubsconsumer } set spec { -special {-boolean} a1 {-required} a2 {} a3 {-required} } # pkgconfig (TIP 59) <<< test stubs-1.1 {pkgconfig keys} -body { #<<< lsort [parse_args::pkgconfig list] } -result {header includedir,runtime libdir,runtime library packagedir,runtime stublib} #>>> test stubs-1.2 {pkgconfig header, decls and bind.def are present in includedir} -body { #<<< set dir [parse_args::pkgconfig get includedir,runtime] list \ [file exists [file join $dir [parse_args::pkgconfig get header]]] \ [file exists [file join $dir parse_argsDecls.h]] \ [file exists [file join $dir parseargs_bind.def]] } -cleanup { unset -nocomplain dir } -result {1 1 1} #>>> test stubs-1.3 {pkgconfig library and stublib are present in libdir} -body { #<<< set dir [parse_args::pkgconfig get libdir,runtime] list \ [llength [glob -nocomplain -directory $dir lib[parse_args::pkgconfig get library][info sharedlibextension]]] \ [llength [glob -nocomplain -directory $dir lib[parse_args::pkgconfig get stublib].a]] } -cleanup { unset -nocomplain dir } -result {1 1} #>>> # pkgconfig >>> foreach {mode n ns constraint} { direct 2 ::parse_args_direct haveJitc stubs 3 ::parse_args_stubs haveStubsConsumer } { # ParseArgs_BindDict <<< test stubs-$n.1 "$mode: ParseArgs_BindDict" -constraints $constraint -body { ${ns}::bind_dict $spec -special a b } -result {special 1 a1 a a3 b} test stubs-$n.2 "$mode: ParseArgs_BindDict, error" -constraints $constraint -body { list [catch {${ns}::bind_dict $spec} r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {argument a1 is required} {PARSE_ARGS REQUIRED a1}} test stubs-$n.3 "$mode: ParseArgs_BindDict, -alias" -constraints $constraint -body { list [catch {${ns}::bind_dict {-v {-alias}} -v x} r] $r } -cleanup { unset -nocomplain r } -result {1 {-alias is not yet supported in dictionary mode}} # ParseArgs_BindDict >>> # ParseArgs_Bind <<< test stubs-$n.10 "$mode: ParseArgs_Bind: decl_idx in argspec order" -constraints $constraint -body { ${ns}::bind_cb { -zz {-default z} a {} -aa {-boolean} -mm {} b {-required} } -mm m x y } -result {{3 mm m} {1 a x} {4 b y} {2 aa 0} {0 zz z}} test stubs-$n.11 "$mode: ParseArgs_Bind: -multi values have decl_idx -1" -constraints $constraint -body { ${ns}::bind_cb { -x {-multi -name m -default x} -y {-multi -name m} } -y } -result {{-1 m y}} test stubs-$n.12 "$mode: ParseArgs_Bind: -all, -name, args" -constraints $constraint -body { ${ns}::bind_cb { -i {-all -name inc} args {} } -i a -i b c d } -result {{1 args {c d}} {0 inc {a b}}} test stubs-$n.13 "$mode: ParseArgs_Bind: wrong # args" -constraints $constraint -body { list [catch {${ns}::bind_cb {a {}} x y} r] $r } -cleanup { unset -nocomplain r } -result {1 {wrong # args: should be "?a?"}} # ParseArgs_Bind >>> # parseargs_bind.def <<< test stubs-$n.20 "$mode: parseargs_bind.def" -constraints $constraint -body { ${ns}::foo 1 2 } -result {0 1 42 2} test stubs-$n.21 "$mode: parseargs_bind.def, cached argspec reused" -constraints $constraint -body { list [${ns}::foo -special x 7 9] [${ns}::foo y 3] } -result {{1 x 7 9} {0 y 42 3}} test stubs-$n.22 "$mode: parseargs_bind.def, required" -constraints $constraint -body { list [catch {${ns}::foo x} r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {argument a3 is required} {PARSE_ARGS REQUIRED a3}} test stubs-$n.23 "$mode: parseargs_bind.def, conversion error" -constraints $constraint -body { list [catch {${ns}::foo x notanint} r] $r } -cleanup { unset -nocomplain r } -result {1 {expected integer but got "notanint"}} test stubs-$n.24 "$mode: parseargs_bind.def, all out-types, defaults" -constraints $constraint -body { ${ns}::types hello } -result {obj= wide=5000000000 dbl=1.5 bytes=0 mode=1 pair=0 str=hello/5 args=0} test stubs-$n.25 "$mode: parseargs_bind.def, all out-types, supplied" -constraints $constraint -body { ${ns}::types -obj X -wide 7 -dbl 2.25 -bytes abc -mode blue -ignored zz -pair p q hello a b c } -result {obj=X wide=7 dbl=2.25 bytes=3 mode=2 pair=2 pair1=q str=hello/5 args=3} test stubs-$n.26 "$mode: parseargs_bind.def, -enum" -constraints $constraint -body { list [catch {${ns}::types -mode purple hello} r] $r } -cleanup { unset -nocomplain r } -result {1 {bad -mode "purple": must be red, green, or blue}} test stubs-$n.27 "$mode: parseargs_bind.def, BYTES" -constraints $constraint -body { list [catch {${ns}::types -bytes Ā hello} r o] [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {TCL VALUE BYTES}} test stubs-$n.28 "$mode: parseargs_bind.def, PARSEARGS_ON_ERROR" -constraints $constraint -body { list [${ns}::custom_error 21] [catch {${ns}::custom_error abc} r] $r } -cleanup { unset -nocomplain r } -result {42 1 {expected integer but got "abc" (custom)}} test stubs-$n.29 "$mode: parseargs_bind.def, held values outlive the arg objs" -constraints $constraint -body { # The STRING and LIST values point into Tcl_Objs that only the slots hold ${ns}::types [string repeat x 3] {*}[lmap e {a b c d} {string cat $e $e}] } -result {obj= wide=5000000000 dbl=1.5 bytes=0 mode=1 pair=0 str=xxx/3 args=4} # parseargs_bind.def >>> } # jitc OBJCMD cdata as the argspec cache <<< variable foo_cdef [list \ options {-Wall -Werror} \ package [list parse_args [package present parse_args]] \ code { OBJCMD(foo) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( special, "-boolean", BOOL ) \ ARG( a1, "-required", STRING ) \ ARG( a2, "-default 42", INT ) \ ARG( a3, "-required", WIDEINT ) \ /* line intentionally left blank */ /* These are the defaults: #define PARSEARGS_OUT args #define PARSEARGS_INTERP interp #define PARSEARGS_OBJC objc-1 #define PARSEARGS_OBJV objv+1 #define PARSEARGS_CACHE ((Tcl_Obj**)cdata) */ #include Tcl_SetObjResult(interp, Tcl_NewListObj(4, (Tcl_Obj*[]){ Tcl_NewBooleanObj(args.special), Tcl_NewStringObj(args.a1, -1), Tcl_NewIntObj(args.a2), Tcl_NewWideIntObj(args.a3), })); return TCL_OK; } OBJCMD(cached) { // The argspec cached in this binding's slot Tcl_Obj* cache = cdata ? *(Tcl_Obj**)cdata : NULL; Tcl_SetObjResult(interp, cache ? cache : Tcl_NewStringObj("", -1)); return TCL_OK; } OBJCMD(spec_cached) { // Bind, then return the argspec cached in this binding's slot #define PARSEARGS_SPEC(OPT, ARG) \ OPT( special, "-boolean", BOOL ) \ ARG( a1, "-required", STRING ) \ ARG( a2, "-default 42", INT ) \ ARG( a3, "", WIDEINT ) \ /* line intentionally left blank */ #include Tcl_SetObjResult(interp, *(Tcl_Obj**)cdata); return TCL_OK; } OBJCMD(multi) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( x, "-multi -name m", OBJ ) \ /* line intentionally left blank */ #include return TCL_OK; } OBJCMD(alias) { #define PARSEARGS_SPEC(OPT, ARG) \ OPT( v, "-alias", OBJ ) \ /* line intentionally left blank */ #include return TCL_OK; } } \ ] test stubs-4.1 {PARSE_ARGS, jitc::capply (no cache slot)} -constraints haveJitc -body { #<<< list \ [jitc::capply $foo_cdef foo 1 2] \ [jitc::capply $foo_cdef cached] } -result {{0 1 42 2} } #>>> test stubs-4.2 {PARSE_ARGS, jitc::bind caches the argspec in the binding's slot} -constraints haveJitc -setup { #<<< jitc::bind foo $foo_cdef foo jitc::bind cached $foo_cdef cached } -body { list \ [foo 1 2] \ [foo -special a 3 4] \ [catch {foo} r] $r } -cleanup { rename foo {} rename cached {} unset -nocomplain r } -result {{0 1 42 2} {1 a 3 4} 1 {argument a1 is required}} #>>> test stubs-4.3 {PARSE_ARGS, the cached argspec} -constraints haveJitc -setup { #<<< jitc::bind spec_cached $foo_cdef spec_cached } -body { set first [spec_cached 1] list [dict keys $first] [dict get $first a2] [expr {[spec_cached 2] eq $first}] } -cleanup { rename spec_cached {} unset -nocomplain first } -result {{-special a1 a2 a3} {-default 42} 1} #>>> test stubs-4.4 {PARSE_ARGS, -multi is rejected} -constraints haveJitc -body { #<<< list [catch {jitc::capply $foo_cdef multi -x} r] $r } -cleanup { unset -nocomplain r } -result {1 {-multi is not supported by ParseArgs_BindSlots}} #>>> test stubs-4.5 {PARSE_ARGS, -alias is rejected} -constraints haveJitc -body { #<<< list [catch {jitc::capply $foo_cdef alias -v x} r] $r } -cleanup { unset -nocomplain r } -result {1 {-alias is not supported by ParseArgs_BindSlots}} #>>> # jitc OBJCMD cdata as the argspec cache >>> unset -nocomplain spec consumer direct_cdef foo_cdef n mode ns constraint # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 RubyLane-parse_args-b4f953b/tests/stubs_api.c000066400000000000000000000125361526416560500213170ustar00rootroot00000000000000// Commands exercising the parse_args C API from a separately compiled consumer. // Included by the jitc cdef in stubs.test (linked directly against the package // library) and by stubs_consumer.c (a meson-built extension linked through the // stubs table), so it uses only plain Tcl and parse_args API calls (plus // defer, which parseargs_bind.def needs). #include #include static void api_replace(Tcl_Obj** target, Tcl_Obj* replacement) //<<< { if (*target == replacement) return; if (replacement) Tcl_IncrRefCount(replacement); if (*target) Tcl_DecrRefCount(*target); *target = replacement; } //>>> static int api_bind_dict(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) //<<< { // bind_dict argspec ?arg ...? (void)cdata; if (objc < 2) {Tcl_WrongNumArgs(interp, 1, objv, "argspec ?arg ...?"); return TCL_ERROR;} Tcl_Obj* dict = NULL; const int code = ParseArgs_BindDict(interp, objv[1], objc-2, objv+2, &dict); if (code == TCL_OK) Tcl_SetObjResult(interp, dict); api_replace(&dict, NULL); return code; } //>>> static int collect(void* cdata, Tcl_Interp* interp, Tcl_Size decl_idx, Tcl_Obj* name, Tcl_Obj* val) //<<< { Tcl_Obj* res = cdata; return Tcl_ListObjAppendElement(interp, res, Tcl_NewListObj(3, (Tcl_Obj*[]){ Tcl_NewWideIntObj(decl_idx), name, val, })); } //>>> static int api_bind_cb(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) //<<< { // bind_cb argspec ?arg ...? -> list of {decl_idx name val} for each callback (void)cdata; if (objc < 2) {Tcl_WrongNumArgs(interp, 1, objv, "argspec ?arg ...?"); return TCL_ERROR;} Tcl_Obj* res = NULL; api_replace(&res, Tcl_NewListObj(0, NULL)); const int code = ParseArgs_Bind(interp, objv[1], objc-2, objv+2, collect, res); if (code == TCL_OK) Tcl_SetObjResult(interp, res); api_replace(&res, NULL); return code; } //>>> static int api_foo(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) //<<< { // cdata is a Tcl_Obj** slot (the same shape as a jitc binding's cdata) #define PARSEARGS_SPEC(OPT, ARG) \ OPT( special, "-boolean", BOOL ) \ ARG( a1, "-required", STRING ) \ ARG( a2, "-default 42", INT ) \ ARG( a3, "-required", WIDEINT ) \ /* line intentionally left blank */ #include Tcl_SetObjResult(interp, Tcl_NewListObj(4, (Tcl_Obj*[]){ Tcl_NewBooleanObj(args.special), Tcl_NewStringObj(args.a1, -1), Tcl_NewIntObj(args.a2), Tcl_NewWideIntObj(args.a3), })); return TCL_OK; } //>>> static int api_types(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) //<<< { // Every out-type, with the argspec built for each call (no cache) (void)cdata; #define PARSEARGS_SPEC(OPT, ARG) \ OPT( obj, "", OBJ ) \ OPT( wide, "-default 5000000000", WIDEINT ) \ OPT( dbl, "-default 1.5", DOUBLE ) \ OPT( bytes, "", BYTES ) \ OPT( mode, "-enum {red green blue} -default green", INDEX ) \ OPT( ignored, "", SKIP ) \ OPT( pair, "-args 2", LIST ) \ ARG( str, "-required", STRING ) \ ARG( args, "", LIST ) \ /* line intentionally left blank */ #define PARSEARGS_OUT a #define PARSEARGS_CACHE NULL #include Tcl_Obj* res = Tcl_NewListObj(0, NULL); #define ADD(...) Tcl_ListObjAppendElement(NULL, res, Tcl_ObjPrintf(__VA_ARGS__)) ADD("obj=%s", a.obj ? Tcl_GetString(a.obj) : ""); ADD("wide=%" TCL_LL_MODIFIER "d", a.wide); ADD("dbl=%g", a.dbl); ADD("bytes=%d", (int)a.bytes_len); ADD("mode=%d", a.mode); ADD("pair=%d", (int)a.pairc); if (a.pairc == 2) ADD("pair1=%s", Tcl_GetString(a.pairv[1])); ADD("str=%s/%d", a.str, (int)strlen(a.str)); ADD("args=%d", (int)a.argsc); #undef ADD Tcl_SetObjResult(interp, res); return TCL_OK; } //>>> static int api_custom_error(void* cdata, Tcl_Interp* interp, int objc, Tcl_Obj*const objv[]) //<<< { // PARSEARGS_ON_ERROR, and errors from parse_args itself (void)cdata; #define PARSEARGS_SPEC(OPT, ARG) \ ARG( n, "-required", INT ) \ /* line intentionally left blank */ #define PARSEARGS_CACHE NULL #define PARSEARGS_ON_ERROR { Tcl_AppendResult(interp, " (custom)", NULL); return TCL_ERROR; } #include Tcl_SetObjResult(interp, Tcl_NewIntObj(args.n * 2)); return TCL_OK; } //>>> static void free_cache_slot(void* cdata) //<<< { Tcl_Obj** slot = cdata; api_replace(slot, NULL); Tcl_Free((char*)slot); } //>>> static int stubs_api_register(Tcl_Interp* interp, const char* ns) //<<< { static const struct { const char* name; Tcl_ObjCmdProc* proc; bool cache_slot; } cmds[] = { {"bind_dict", api_bind_dict}, {"bind_cb", api_bind_cb}, {"foo", api_foo, true}, {"types", api_types}, {"custom_error", api_custom_error}, {NULL} }; if (Tcl_CreateNamespace(interp, ns, NULL, NULL) == NULL) return TCL_ERROR; for (int i=0; cmds[i].name; i++) { Tcl_Obj* cmdname = Tcl_ObjPrintf("%s::%s", ns, cmds[i].name); Tcl_IncrRefCount(cmdname); if (cmds[i].cache_slot) { // Outside of jitc the consumer arranges its own argspec cache slot Tcl_Obj** slot = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*)); *slot = NULL; Tcl_CreateObjCommand(interp, Tcl_GetString(cmdname), cmds[i].proc, slot, free_cache_slot); } else { Tcl_CreateObjCommand(interp, Tcl_GetString(cmdname), cmds[i].proc, NULL, NULL); } Tcl_DecrRefCount(cmdname); } return TCL_OK; } //>>> // vim: ft=c foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 noexpandtab RubyLane-parse_args-b4f953b/tests/stubs_consumer.c000066400000000000000000000013401526416560500223700ustar00rootroot00000000000000// A minimal extension consuming parse_args through its stubs table, built the // way a downstream meson extension would (dependency('parse_args') -> stub lib + // -DUSE_PARSE_ARGS_STUBS=1). Not installed: only loaded by tests/stubs.test. #include #include #include // parseargs_bind.def needs defer #include "stubs_api.c" #ifndef USE_PARSE_ARGS_STUBS # error "Expected to be built against the parse_args stubs (USE_PARSE_ARGS_STUBS)" #endif DLLEXPORT int Parse_argsstubsconsumer_Init(Tcl_Interp* interp) { if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) return TCL_ERROR; if (ParseArgs_InitStubs(interp) == NULL) return TCL_ERROR; return stubs_api_register(interp, "::parse_args_stubs"); } RubyLane-parse_args-b4f953b/tests/validate.test000066400000000000000000000105241526416560500216470ustar00rootroot00000000000000if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::test } ::tcltest::loadTestedCommands # Options test validate-1.1 {basic usage, valid} -body { #<<< parse_args::parse_args {-rating 1.2} { -rating {-validate {string is double -strict}} } set rating } -cleanup { unset -nocomplain rating } -result 1.2 #>>> test validate-1.2 {basic usage, invalid} -body { #<<< list [catch { parse_args::parse_args {-rating x1.2} { -rating {-validate {string is double -strict}} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {Validation failed for "-rating": 0} {PARSE_ARGS VALIDATION -rating}} #>>> test validate-1.3 {basic usage, blank} -body { #<<< list [catch { parse_args::parse_args {-rating ""} { -rating {-validate {string is double -strict}} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {Validation failed for "-rating": 0} {PARSE_ARGS VALIDATION -rating}} #>>> test validate-1.4 {basic usage, missing} -body { #<<< parse_args::parse_args {} { -rating {-validate {string is double -strict}} } info exists rating } -cleanup { unset -nocomplain rating } -result 0 #>>> test validate-2.1 {validator throws error} -body { #<<< parse_args::parse_args {-rating 0} { -rating {-validate {tcl::mathop::+ 1}} } set rating } -cleanup { unset -nocomplain rating } -result 0 #>>> test validate-2.2 {validator throws error} -body { #<<< parse_args::parse_args {-rating ""} { -rating {-validate {tcl::mathop::+ 1}} } } -returnCodes error -errorCode {PARSE_ARGS VALIDATION -rating} -match regexp -result {^Validation failed for "-rating": (cannot|can't) use (non-numeric|empty) string( "")? as (right )?operand of "\+"$} #>>> test validate-3.1 {validator with apply, throws error} -body { #<<< list [catch { parse_args::parse_args {-rating ""} { -rating {-validate {apply { val { if {[string length $val] < 3} { error "Must be at least 3 characters long" } return 1 } } }} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {Validation failed for "-rating": Must be at least 3 characters long} {PARSE_ARGS VALIDATION -rating}} #>>> test validate-3.2 {validator with apply, returns blank} -body { #<<< parse_args::parse_args {-rating foo} { -rating {-validate {apply { val { if {[string length $val] < 3} { error "Must be at least 3 characters long" } return "" } } }} } set rating } -cleanup { unset -nocomplain rating } -result foo #>>> test validate-3.3 {validator with apply, throws error} -body { #<<< list [catch { parse_args::parse_args {-rating ""} { -rating {-validate {apply { val { if {[string length $val] < 3} { return "Must be at least 3 characters long" } } } }} } } r o] $r [dict get $o -errorcode] } -cleanup { unset -nocomplain r o } -result {1 {Validation failed for "-rating": Must be at least 3 characters long} {PARSE_ARGS VALIDATION -rating}} #>>> test validate-3.4 {blank validator} -body { #<<< parse_args::parse_args {-rating foo} { -rating {-validate {}} } set rating } -cleanup { unset -nocomplain rating } -result foo #>>> test validate-3.5 {local vars} -body { #<<< set ref foo parse_args::parse_args {-rating foo} { -rating {-validate {apply { val { upvar 1 ref ref expr {$val eq $ref} } }}} } set rating } -cleanup { unset -nocomplain rating } -result foo #>>> # Positional params test validate-4.1 {validator on multi-word values (-args n, -args all, args)} -body { #<<< # The validator must not retain the value: a fresh list value used to be # freed by the validator's command and then used list \ [parse_args::parse_args {-p 1 2} {-p {-args 2 -validate {string is list}}}; set p] \ [parse_args::parse_args {-r 3 4} {-r {-args all -validate {string is list}}}; set r] \ [parse_args::parse_args {5 6} {args {-validate {string is list}}}; set args] \ [parse_args::parse_args {7 8 9} {a {-args 2 -validate {string is list}} b {}}; list $a $b] \ [parse_args::parse_args {-x 0 a b} {-x {} rest {-args all -validate {string is list}}}; set rest] } -cleanup { unset -nocomplain p r args a b x rest } -result {{1 2} {3 4} {5 6} {{7 8} 9} {a b}} #>>> # cleanup ::tcltest::cleanupTests return # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4