From 6bb2277306e9e55f0a4188b5987c56104d9f5d2e Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Fri, 3 Nov 2023 22:02:06 +0000 Subject: [PATCH] Add std/cli, move std/getopt there Import a bunch of CLI utilities from gerbil-utils into std/cli; tweak them, document them, test them: - multicall to support multiple subcommands in a more modular way - getopt translation to Scheme calling convention - print-exit to print results of Scheme computation at the CLI - shell to support escaping strings for the shell Add a few corresponding utilities to std/error. Move std/getopt to std/cli/getopt with its brothers; leave a compatibility shim at std/getopt. Use std/cli/getopt everywhere instead of std/getopt. Update documentation. --- doc/.vuepress/config.js | 11 + doc/guide/getting-started.md | 8 +- doc/reference/dev/build.md | 4 +- doc/reference/gerbil/expander/README.md | 2 +- doc/reference/gerbil/runtime/MOP.md | 4 +- doc/reference/gerbil/runtime/hash-tables.md | 16 +- .../gerbil/runtime/misc-procedures.md | 4 +- doc/reference/gerbil/runtime/strings.md | 6 +- doc/reference/gerbil/runtime/symbols.md | 4 +- doc/reference/std/cli/README.md | 7 + doc/reference/std/cli/getopt.md | 269 +++++++++++ doc/reference/std/cli/multicall.md | 129 +++++ doc/reference/std/cli/print-exit.md | 101 ++++ doc/reference/std/cli/shell.md | 94 ++++ doc/reference/std/errors.md | 35 ++ doc/reference/std/getopt.md | 191 +------- doc/reference/std/misc/alist.md | 2 +- doc/reference/std/misc/list.md | 4 +- doc/reference/std/misc/plist.md | 2 +- doc/reference/std/text/base64.md | 8 +- doc/tutorials/kvstore.md | 2 +- src/misc/http-perf/baseline.ss | 4 +- src/misc/http-perf/hellod.ss | 10 +- src/misc/rpc-perf/baseline-buffer.ss | 4 +- src/misc/rpc-perf/baseline-io.ss | 4 +- src/misc/rpc-perf/baseline-port.ss | 4 +- src/misc/rpc-perf/nullproto.ss | 2 +- src/std/build-spec.ss | 5 + src/std/cli/getopt.ss | 454 ++++++++++++++++++ src/std/cli/multicall.ss | 99 ++++ src/std/cli/print-exit.ss | 48 ++ src/std/cli/shell-test.ss | 36 ++ src/std/cli/shell.ss | 42 ++ src/std/error.ss | 36 +- src/std/getopt.ss | 407 +--------------- src/tools/gxensemble.ss | 10 +- src/tools/gxpkg.ss | 16 +- src/tools/gxprof.ss | 6 +- src/tools/gxtags.ss | 10 +- src/tools/gxtest.ss | 16 +- src/tutorial/ensemble/httpd-prod-exe.ss | 4 +- src/tutorial/ensemble/registry-prod-exe.ss | 4 +- src/tutorial/httpd/simpled.ss | 8 +- src/tutorial/kvstore/kvstorec.ss | 4 +- src/tutorial/proxy/tcp-proxy1.ss | 8 +- src/tutorial/proxy/tcp-proxy2.ss | 6 +- src/tutorial/proxy/tcp-proxy3.ss | 8 +- 47 files changed, 1474 insertions(+), 684 deletions(-) create mode 100644 doc/reference/std/cli/README.md create mode 100644 doc/reference/std/cli/getopt.md create mode 100644 doc/reference/std/cli/multicall.md create mode 100644 doc/reference/std/cli/print-exit.md create mode 100644 doc/reference/std/cli/shell.md create mode 100644 src/std/cli/getopt.ss create mode 100644 src/std/cli/multicall.ss create mode 100644 src/std/cli/print-exit.ss create mode 100644 src/std/cli/shell-test.ss create mode 100644 src/std/cli/shell.ss diff --git a/doc/.vuepress/config.js b/doc/.vuepress/config.js index bdf93e115b..ea9ebc1a3e 100644 --- a/doc/.vuepress/config.js +++ b/doc/.vuepress/config.js @@ -121,6 +121,17 @@ module.exports = { ] }, + { title: "Unix Command Line Interface", + path: "/reference/std/cli/", + children: [ + "cli/", + "cli/getopt", + "cli/shell", + "cli/print-exit", + "cli/multicall", + ] + }, + { title: "Databases and Key-Value Stores", path: "/reference/std/db/", children: [ diff --git a/doc/guide/getting-started.md b/doc/guide/getting-started.md index 1a82d20237..64d8857bed 100644 --- a/doc/guide/getting-started.md +++ b/doc/guide/getting-started.md @@ -180,7 +180,7 @@ $ cat hello/lib.ss $ cat hello/main.ss ;;; -*- Gerbil -*- (import :std/sugar - :std/getopt + :std/cli/getopt ./lib) (export main) @@ -192,7 +192,7 @@ $ cat hello/main.ss (call-with-getopt hello-main args program: "hello" help: "A one line description of your program" - ;; commands/options/flags for your program; see :std/getopt + ;; commands/options/flags for your program; see :std/cli/getopt ;; ... )) @@ -268,12 +268,12 @@ $ cat hello/lib.ss (displayln greeting ", " who)) ``` -And in the generated `hello/main.ss` file, we add a [getopt](/reference/std/getopt.md) option for a single argument and implement `hello-main/options` to greet: +And in the generated `hello/main.ss` file, we add a [getopt](/reference/std/cli/getopt.md) option for a single argument and implement `hello-main/options` to greet: ```scheme $ cat hello/main.ss ;;; -*- Gerbil -*- (import :std/sugar - :std/getopt + :std/cli/getopt ./lib) (export main) diff --git a/doc/reference/dev/build.md b/doc/reference/dev/build.md index ec5e16ae64..f06461771a 100644 --- a/doc/reference/dev/build.md +++ b/doc/reference/dev/build.md @@ -212,7 +212,7 @@ $ cat scraper/main.ss ;;; -*- Gerbil -*- (import :std/error :std/sugar - :std/getopt + :std/cli/getopt :gerbil/gambit ./lib) (export main) @@ -494,7 +494,7 @@ $ cat scraper/main.ss ;;; -*- Gerbil -*- (import :std/error :std/sugar - :std/getopt + :std/cli/getopt :gerbil/gambit ./lib) (export main) diff --git a/doc/reference/gerbil/expander/README.md b/doc/reference/gerbil/expander/README.md index 4140926597..f6717bea68 100644 --- a/doc/reference/gerbil/expander/README.md +++ b/doc/reference/gerbil/expander/README.md @@ -681,7 +681,7 @@ Please document me! Please document me! -### core-module-export->import +### core-module-export->import ``` (core-module-export->import ...) ``` diff --git a/doc/reference/gerbil/runtime/MOP.md b/doc/reference/gerbil/runtime/MOP.md index d4494885df..4ea4381d4a 100644 --- a/doc/reference/gerbil/runtime/MOP.md +++ b/doc/reference/gerbil/runtime/MOP.md @@ -294,7 +294,7 @@ Accesses *obj*'s field with absolute offset *off*; there is no type check. Mutates *obj*'s field with absolute offset *off* to *val*; there is no type check. -## struct->list +## struct->list ``` scheme (struct->list obj) -> list @@ -482,7 +482,7 @@ Returns the value associated with slot *slot* in *obj*, without any checks. Sets the value associated with slot *slot* in *obj* to *val*, without any checks. -## class->list +## class->list ``` scheme (class->list obj) diff --git a/doc/reference/gerbil/runtime/hash-tables.md b/doc/reference/gerbil/runtime/hash-tables.md index 909a589ba5..da5cac8614 100644 --- a/doc/reference/gerbil/runtime/hash-tables.md +++ b/doc/reference/gerbil/runtime/hash-tables.md @@ -240,7 +240,7 @@ Merges *more* hash tables into *hash*. Entries in hash tables on the left take p ((a . 1) (z . 6) (b . 2) (c . 3)) ``` -## hash->list +## hash->list ``` scheme (hash->list hash) -> list @@ -249,7 +249,7 @@ Merges *more* hash tables into *hash*. Entries in hash tables on the left take p Returns the bindings of *hash* as an alist. -## list->hash-table +## list->hash-table ``` scheme (list->hash-table lst . options) -> hash table @@ -258,7 +258,7 @@ Returns the bindings of *hash* as an alist. Creates a hash table from an alist *lst*. -## list->hash-table-eq +## list->hash-table-eq ``` scheme (list->hash-table-eq lst . options) -> hash table @@ -267,7 +267,7 @@ Creates a hash table from an alist *lst*. Same as `list->hash-table`, but using `eq?` as the test function for the table. -## list->hash-table-eqv +## list->hash-table-eqv ``` scheme (list->hash-table-eqv lst . options) -> hash table @@ -276,7 +276,7 @@ Same as `list->hash-table`, but using `eq?` as the test function for the table. Same as `list->hash-table`, but using `eqv?` as the test function for the table. -## hash->plist +## hash->plist ``` scheme (hash->plist hash) -> list @@ -285,7 +285,7 @@ Same as `list->hash-table`, but using `eqv?` as the test function for the table. Returns the bindings of *hash* as a plist. -## plist->hash-table +## plist->hash-table ``` scheme (plist->hash-table lst) -> hash table @@ -294,7 +294,7 @@ Returns the bindings of *hash* as a plist. Creates a hash table from a plist *lst*. -## plist->hash-table-eq +## plist->hash-table-eq ``` scheme (plist->hash-table-eq lst) -> hash table @@ -303,7 +303,7 @@ Creates a hash table from a plist *lst*. Same as `plist->hash-table`, but using `eq?` as the test function for the table. -## plist->hash-table-eqv +## plist->hash-table-eqv ``` scheme (plist->hash-table-eqv lst) -> hash table diff --git a/doc/reference/gerbil/runtime/misc-procedures.md b/doc/reference/gerbil/runtime/misc-procedures.md index 09c015f8c0..247995f288 100644 --- a/doc/reference/gerbil/runtime/misc-procedures.md +++ b/doc/reference/gerbil/runtime/misc-procedures.md @@ -20,7 +20,7 @@ it is considered a single value. Returns the *n*th value in the object *obj*. If the object is not multiple `values`, it returns the object itself. -### values->list +### values->list ``` scheme (values->list obj) -> list @@ -30,7 +30,7 @@ it returns the object itself. Converts multiple `values` to a list. If the object *obj* is not multiple `values`, it returns a list containing the object. -### subvector->list +### subvector->list ``` scheme (subvector->list obj [start = 0]) -> list diff --git a/doc/reference/gerbil/runtime/strings.md b/doc/reference/gerbil/runtime/strings.md index 1b7881f6ab..5b20bc3c55 100644 --- a/doc/reference/gerbil/runtime/strings.md +++ b/doc/reference/gerbil/runtime/strings.md @@ -1,6 +1,6 @@ # Strings -## bytes->string +## bytes->string ``` (bytes->string bstr [encoding = 'UTF-8]) -> string @@ -12,7 +12,7 @@ Decodes a byte vector *bstr* to a string. Note: if you are decoding UTF-8, then you should consider using `string->utf8` from `:std/text/utf8` which is considerably faster. -## string->bytes +## string->bytes ``` scheme (string->bytes str [encoding = 'UTF-8]) -> u8vector @@ -25,7 +25,7 @@ Note: if you are encoding UTF-8, then you should consider using `utf8->string` from `:std/text/utf8` which is considerably faster. -## substring->bytes +## substring->bytes ``` scheme (substring->bytes str start end [encoding = 'UTF-8]) -> u8vector diff --git a/doc/reference/gerbil/runtime/symbols.md b/doc/reference/gerbil/runtime/symbols.md index ca94278fe0..a0fa5e2b07 100644 --- a/doc/reference/gerbil/runtime/symbols.md +++ b/doc/reference/gerbil/runtime/symbols.md @@ -32,7 +32,7 @@ Returns true if the object *obj* is an interned symbol. Returns true if the object *obj* is an interned keyword. -## symbol->keyword +## symbol->keyword ``` scheme (symbol->keyword sym) -> keyword @@ -41,7 +41,7 @@ Returns true if the object *obj* is an interned keyword. Converts a symbol *sym* to a keyword. -## keyword->symbol +## keyword->symbol ``` scheme (keyword->symbol kw) -> symbol diff --git a/doc/reference/std/cli/README.md b/doc/reference/std/cli/README.md new file mode 100644 index 0000000000..809a8d63dc --- /dev/null +++ b/doc/reference/std/cli/README.md @@ -0,0 +1,7 @@ +# Command Line Interface + +The following libraries are provided to support the Command Line Interface (CLI): +- [:std/cli/getopt](getopt.md) +- [:std/cli/shell](shell.md) +- [:std/cli/print-exit](print-exit.md) +- [:std/cli/multicall](multicall.md) diff --git a/doc/reference/std/cli/getopt.md b/doc/reference/std/cli/getopt.md new file mode 100644 index 0000000000..0036d1c2cb --- /dev/null +++ b/doc/reference/std/cli/getopt.md @@ -0,0 +1,269 @@ +# Command Line Argument Parsing + +The `:std/cli/getopt` library provides facilities for command line argument parsing. + +::: tip usage +```scheme +(import :std/cli/getopt) +``` +::: + +This library used to be available as `:std/getopt` up to Gerbil v0.18, +and is still available under that name for now, but its use is deprecated. + +## Interface + +### getopt +```scheme +(getopt ...) +=> + +specifier: + (command id [help: text] ) + ... + +cmd-specifier: + (flag id short [long]) + (option id short [long] [help: text] [value: proc] [default: value]) + (argument id [help: text] [value: proc]) + (optional-argument id [help: text] [value: proc] [default: value]) + (rest-arguments id [help: text] [value: proc]) +``` + +`getopt` creates a command line parser, which can be used to parse arguments +with `getopt-parse`. + +### getopt-parse +```scheme +(getopt-parse args) +=> (values cmd-id options) + options +``` + +`getopt-parse` accepts a parser and a list of string arguments and parses +according to the parser specification. If it is parsing a specification with +subcommands, it returns two values, the command id and a hash table with the +parsed options. Otherwise it just returns the hash table with the parsed options. +An exception is raised if parsing the arguments fails. + +### getopt-error? +```scheme +(getopt-error? obj) +=> boolean +``` + +If parsing fails, then a `getopt-error` is raised, which can be guarded with +`getopt-error?`. + +### getopt-display-help +```scheme +(getopt-display-help program-name [port = (current-output-port)]) + +tip: + + + +``` + +The procedure `getopt-display-help` can be used to display +a help message for a getopt error according to the argument specification. + +### getopt-display-help-topic +```scheme +(getopt-display-help-topic topic program-name [port = (current-output-port)]) +``` + +The procedure `getopt-display-help-topic` can be used to display a help page +for a subcommand. + +### getopt? +```scheme +(getopt? obj) +=> boolean +``` + +Returns true if the object is a getopt parser + +### getopt-object? +```scheme +(getopt-object? obj) +=> boolean +``` + +Returns true if the object is a getopt command or command specifier. + +### call-with-getopt +```scheme +(call-with-getopt proc args + program: program + help: (help #f) + exit-on-error: (exit-on-error? #t) + . gopts) +``` + +This shim around getopt parsing eliminates all the repetitive +boilerplate around argument parsing with getopt. + +It creates a getopt parser that parses with options `gopts`, automatically +including a help option or command accordingly. + +It then uses the parser to pare `args`, handling the exceptions and +displayin help accordingly; if `exit-on-error` is true (the default), +then parsing errors will exit the program. + +If the parse succeeds it invokes `proc` with the output of the parse. + +## Example + +For an example, here the a command line parser for the `gxpkg` program: +```scheme +(def (main . args) + (def install-cmd + (command 'install help: "install one or more packages" + (rest-arguments 'pkg help: "package to install"))) + (def uninstall-cmd + (command 'uninstall help: "uninstall one or more packages" + (flag 'force "-f" help: "force uninstall even if there are orphaned dependencies") + (rest-arguments 'pkg help: "package to uninstall"))) + (def update-cmd + (command 'update help: "update one or more packages" + (rest-arguments 'pkg help: "package to update; all for all packages"))) + (def link-cmd + (command 'link help: "link a local development package" + (argument 'pkg help: "package to link") + (argument 'src help: "path to package source directory"))) + (def unlink-cmd + (command 'unlink help: "unlink one or more local development packages" + (flag 'force "-f" help: "force unlink even if there are orphaned dependencies") + (rest-arguments 'pkg help: "package to unlink"))) + (def build-cmd + (command 'build help: "rebuild one or more packages and their dependents" + (rest-arguments 'pkg help: "package to build; all for all packages"))) + (def clean-cmd + (command 'clean help: "clean compilation artefacts from one or more packages" + (rest-arguments 'pkg help: "package to clean"))) + (def list-cmd + (command 'list help: "list installed packages")) + (def retag-cmd + (command 'retag help: "retag installed packages")) + (def search-cmd + (command 'search help: "search the package directory" + (rest-arguments 'keywords help: "keywords to search for"))) + + (call-with-getopt gxpkg-main args + program: "gxpkg" + help: "The Gerbil Package Manager" + install-cmd + uninstall-cmd + update-cmd + link-cmd + unlink-cmd + build-cmd + clean-cmd + list-cmd + retag-cmd + search-cmd)) + +(def (gxpkg-main cmd opt) + (let-hash opt + (case cmd + ((install) + (install-pkgs .pkg)) + ((uninstall) + (uninstall-pkgs .pkg .?force)) + ((update) + (update-pkgs .pkg)) + ((link) + (link-pkg .pkg .src)) + ((unlink) + (unlink-pkgs .pkg .?force)) + ((build) + (build-pkgs .pkg)) + ((clean) + (clean-pkgs .pkg)) + ((list) + (list-pkgs)) + ((retag) + (retag-pkgs)) + ((search) + (search-pkgs .keywords))))) +``` + +### getopt-parse->function-arguments +```scheme +(getopt-parse->function-arguments getopt h) => list-of-arguments +``` + +This function takes a `getopt` specification and table `h` of arguments +resulting from calling `getopt-parse`, and returns a list of argument +with which to call a Scheme function that has an analogous call convention: + - supplied positional arguments are passed in order + - they are followed by all the rest arguments + - they are followed by the remaining specified keyword arguments. + +Omitted option arguments without default will be omitted. +Omitted option arguments with a default will be included with the default value; +the programmer must ensure that this default value is the same as +the default value from the Scheme function being called, or there will be +a semantic discrepancy between the CLI interface and the underlying Scheme function. + +NB: `h` will be modified in place, removing positional and rest arguments. +Make sure to use `hash-copy` if you want to preserve the original data. + +TODO: add examples + +### call-with-getopt-parse +```scheme +(call-with-getopt-parse gopt hash fun) => results-of-fun +``` + +Given a getopt specification `gopt`, the `hash` resulting from calling +`getopt-parse` on some provided command-line arguments, and a function `fun` +that has a calling convention analogous to that specified by `gopt`, +call the function with arguments that correspond to those provided by `hash`, +as per `getopt-parse->function-arguments`. + +TODO: add examples, discuss abort-on-error behavior, +lack of automatic help, etc. + +### call-with-processed-command-line +```scheme +(call-with-processed-command-line processor command-line function) => results-of-function +``` + +Generic function of three arguments: + - a `processor` that describes a `getopt` specification, + - a `command-line`, list of strings as provided by the invoking process, and + - a `function` to be called with the results of processing the command-line. + +The function is generic in the first argument. +The default method recognizes a `getopt` specification as first argument, +and appropriately calls `getopt-parse` and `call-with-getopt-parse` +to process the command-line. It also recognizes a list as being arguments +to which to apply `getopt` to obtain a specification, +with which to proceed as above. + +You may define more methods, to work with your own variant of `getopt`, +or with innovative ways to incrementally compose `getopt` specifications +e.g. with prototype objects like `gerbil-poo`. + +TODO: add examples, discuss abort-on-error behavior, +lack of automatic help, etc. + +### ->getopt-spec +```scheme +(->getopt-spec arg) => list-of-getopt-arguments +``` +Given an argument `arg`, return a list *lst* of getopt arguments +to which one can `(apply getopt lst)` to specify a getopt object to parse with. + +Default behavior: + - If `arg` is a list, `flatten` it. + - If `arg` is a natural integer *n*, + specify a list of *n* positional `argument`s. + - If `arg` is `#f`, specify a single `rest-argument` named `rest`, + i.e. let it be a passthrough to be processed by the function being called. + - Otherwise, raise an error. + +This function is useful for calls not just to `getopt` directly, +but also to `command` that itself calls `getopt`, etc. diff --git a/doc/reference/std/cli/multicall.md b/doc/reference/std/cli/multicall.md new file mode 100644 index 0000000000..26ccf07880 --- /dev/null +++ b/doc/reference/std/cli/multicall.md @@ -0,0 +1,129 @@ +# Multicall Binaries + +The `:std/cli/multicall` module provides facilities to define multicall binaries +the behavior of which differs depending on the name of the binary, +just like the gerbil binary itself, or famously like `busybox`. + +::: tip usage +```scheme +(import :std/cli/multicall) +``` +::: + +An earlier version of this library used to be available as `:clan/multicall` +in gerbil-utils. + +## Interface + +### current-program +```scheme +(def current-program (make-parameter [])) +``` +A parameter that contains the name of the current program or subprogram, +as a list in reverse of the successive subcommands used to invoke it. + +### current-program-string +```scheme +(def current-program (make-parameter [])) +``` +Return as a string of space-separated commands and subcommands in order +the name of the current program or subprogram. + +### entry-points +```scheme +entry-points => table +``` +A table, indexed by symbols, of `entry-point` structs, +describing the available shell entry points. + +### entry-point +```scheme +(defstruct entry-point (name function help getopt) transparent: #t) +``` +A struct type describing an available entry-point: + - `name` is a symbol, whose `symbol->string` is used as command or subcommand + to select the entry-point from the CLI. + - `function` is the Scheme function to call if the entry-point is selected. + - `help` is a short help string describing the purpose of the entry-point, + to be displayed to the user when help is requested. + - `getopt` is a `getopt-spec` + based on which the rest of the command-line will be parsed, and + based on which help about the available options is displayed. + +### entry-points-getopt-spec +```scheme +(entry-points-getopt-spec [table]) +``` +Given a `table` of entry-points which default to the variable `entry-points`, +return a getopt-spec (suitable to be passed to `(apply getopt ...)`) of +`command` specifiers, one for each registered entry-point, in asciibetical order. + +### register-entry-point +```scheme +(register-entry-point function + [id: #f] [name: #f] [help: #f] [getopt: #f]) +``` +Register the function as entry-point, +with given `name` (argument passed to `make-symbol`), +or if not specified, a symbol made of only the +[`easy-shell-characters?`](shell.md#easy-shell-characters) of `id`. +The entry-point will have the given `help` and `getopt` fields. + +### define-entry-point +```scheme +(define-entry-point (id . formals) (options ...) body ...) +``` +Syntax that expands to both + 1. defining in the current scope function with the given name `id` + and specified Scheme function formals, and the given `body`. + 2. register an entry-point for that function, + with given `id` and `options`. + +### multicall-default +```scheme +multicall-default +``` +A mutable variable that contains the default function to call +if the command doesn’t match any of the specified commands. + +### set-default-entry-point! +```scheme +(set-default-entry-point! symbol) +``` +Set the default entry-point in `multicall-default` as given `symbol`. + +### help +```scheme +(help [command]) +``` +Global entry-point to print a help message (about the command, if specified) +about the current overall command and subcommands. + +### meta +```scheme +(meta) +``` +Global entry-point to print the available completions for the command, +for use with CLI syntax autodetection. + +### version +```scheme +(version [all?: #f] [layer]) +``` +Global entry-point to print the current version. +If `all?` (flag `-a`) is passed, print all components from build manifest. +If `layer` (flag `-l`) is passed, print the thus-named component. + +### call-entry-point +```scheme +(call-entry-point . args) +``` +Call an entry point as specified by `args`, +or else the `multicall-default` entry point. + +### define-multicall-main +```scheme +define-multicall-main +``` +Define `call-entry-point` as a suitable `main` function +in the current scope. diff --git a/doc/reference/std/cli/print-exit.md b/doc/reference/std/cli/print-exit.md new file mode 100644 index 0000000000..6f9999d7ff --- /dev/null +++ b/doc/reference/std/cli/print-exit.md @@ -0,0 +1,101 @@ +# Print results and Exit + +The `:std/cli/print-exit` module helps you write functions that can be +invoked either from the Scheme REPL or the Unix CLI, and in either case +will print their computation results after their invocation. + +::: tip usage +```scheme +(import :std/cli/print-exit) +``` +::: + +The facilities are named in a way reminiscent of REPL (Read-Eval-Print-Loop), +except that instead of a form being Read and Eval'ed, +a function is called or a body is evaluated as in `begin`, +and after the Print part we Exit rather than Loop. + +## Interface + +### value-printer +```scheme +(define value-printer (make-parameter prn)) +``` +This parameter will return a function called on each value received +by `print-exit` or `print-values` +(unless there is a single value `(void)` that isn't printed). + +Defaults to `prn`. You could instead use `writeln` or `displayln`. + +### print-values +```scheme +(print-values . vs) => (void) +``` +Process a list of values `vs` from a previous computation +(as per `(call-with-values thunk print-values)`), and +print each of those values (as applicable) using `(value-printer)`, +unless there is a single value that is `(void)` +in which case don't print anything +(also don't print anything if provided no values as per `(values)`). + +Any values but `(void)` and `(values)` will thus cause the values to be printed, +one by one, using `(value-printer)`, similar to how the Scheme REPL works. +However, the Scheme REPL would use [`writeln`](../misc/ports.md#writeln) as its +value printer, but the default `(value-printer)` above is +[`prn`](../misc/repr.md#prn) which we found to be more useful in this situation. + +### print-exit +```scheme +(print-exit . vs) => [exit] +``` + +Process a list of values `vs` from a previous computation +(as per `(call-with-values thunk print-exit)`), and +(1) print those values using `print-values`, then +(2) exit with an according exit code. + +Any values but `#f` and `(values)` will cause the exit code 0 to be returned, +which the Unix shell will interpret as success or true. +The values `#f` and `(values)` will cause the exit code 1 to be returned, +which the Unix shell will interpret as failure or false. + +The value `(void)` will thus indicate a silent success, +wherein nothing is printed and success is assumed, as is customary in Scheme. +The value `(values)` meanwhile will thus indicate a silent failure, +wherein nothing is printed and failure is assumed, of which however +only the first part (nothing printed) is customary in Scheme, whereas the +failure assumed is not customary in Scheme (but a false value would be assumed in e.g. CL). + +### silent-exit +```scheme +(silent-exit success?) => void-or-values +``` + +Takes a boolean `success?` and returns a multiple values +that when passed to `print-exit` will not be printed, yet +will cause return an error code that the Unix shell will interpret +as success or true if the boolean is true, and +failure or false if the boolean is false. + +`(void)` is the silent true exit returned if `success?` is true, +and `(values)` is the silent false exit returned if it is false. + +### call-print-exit +```scheme +(call-print-exit fun) => [exit] +``` +Call a function, print the resulting values (if applicable), +and exit with an according exit code, as per `print-exit`. +If an error occurs during execution, +exit with an error code as per +[`with-exit-on-error`](../error.md#with-exit-on-error). + +### begin-print-exit +```scheme +(begin-print-exit body ...) => [exit] +``` +Evaluates the `body` as in an anonymous function called by `call-print-exit`. + +This macro is named in a way reminiscent of REPL (Read-Eval-Print-Loop), +except instead of a form being Read and Eval'ed, the body is evaluated +like `begin`, and after the Print part it Exits rather than Loops. diff --git a/doc/reference/std/cli/shell.md b/doc/reference/std/cli/shell.md new file mode 100644 index 0000000000..808c51f8e1 --- /dev/null +++ b/doc/reference/std/cli/shell.md @@ -0,0 +1,94 @@ +# Shell Command Support + +The `:std/cli/shell` library provides facilities for working with Unix shell code + +::: tip usage +```scheme +(import :std/cli/shell) +``` +::: + +An earlier version of this library used to be available as `:clan/shell` +in gerbil-utils. + +## Interface + +### easy-shell-character? +```scheme +(easy-shell-character? character) => bool +``` + +Returns true if the `character` if a string may contain the character in any position +without that this fact requiring the string to be quoted in any shell. +This include alphanumeric characters and those in `"@%-_=+:,./"` +(not including the double quotes). + +All other ASCII characters may require the string to be quoted. +For good measure we also quote strings containing non-ASCII characters. + +::: tip Examples: +```scheme +> (string-for-each (lambda (c) (or (easy-shell-character? c) (error "foo"))) + "abcdefghijklmnopqrstuvwxzABCDEFGHIJKLMNOPQRSTUVWXZ012345678@%-_=+:,./") ;; no error +> (string-for-each (lambda (c) (or (not (easy-shell-character? c)) (error "foo"))) + "!`~#$^&*()[{]}\\|;'\"<>? \r\n\t\v") ;; no error either +``` +::: + +### needs-shell-escape? +```scheme +(needs-shell-escape? string) => bool +``` +Returns true if the `string` is known not to require quoting in a Unix shell. + +The current implementation only trusts strings where every character +satisfies `easy-shell-character?` to not require quoting. + +::: tip Examples: +```scheme +> (map needs-shell-escape ["foo?" "~user" "$1" "*.*" "!1" "ab\\cd" "{}" "a;b" "&" "|" "a b c"]) +(#t #t #t #t #t #t #t #t #t #t #t) +> (map needs-shell-escape ["foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w"]) +(#f #f #f #f #f #f) +``` +::: + +### escape-shell-token +```scheme +(escape-shell-token string) => shell-escaped-string +``` +Given a `string`, returns a shell-escaped-string that, +when included in a Unix shell command, will expand into the input `string`. + +::: tip Examples: +```scheme +> (map escape-shell-token ["foo?" "~user" "$1" "*.*" "!1" "ab\\cd" "{}" "a;b" "&" "|" "a b c"]) +("\"foo?\"" "\"~user\"" "\"\\$1\"" "\"*.*\"" "\"!1\"" "\"ab\\\\cd\"" "\"{}\"" "\"a;b\"" "\"&\"" "\"|\"" "\"a b c\"") +> (let (l ["foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w"]) + (equal? l (map escape-shell-token l))) +#t +``` +::: + +### ->envvar +```scheme +(->envvar . str) => environment-variable-name +``` +Given a list of arguments `str`, return a string to be used as +a shell environment variable name following the convention of having +only upper-case ASCII letters and digits and underscores. + +The arguments are passed to `as-string` then uppercased, and +any non-empty sequence of characters other than letters and digits +are replaced by a single underscore. + +::: tip Examples: +``` scheme +> (->envvar "foo") +"FOO" +> (->envvar "bar baz") +"BAR_BAZ" +> (->envvar '("bar " "+!@#$") #(#\@ #\! "#") "baz") +"BAR_BAZ" +``` +::: diff --git a/doc/reference/std/errors.md b/doc/reference/std/errors.md index 9c5aee9a1a..eb1f8768c5 100644 --- a/doc/reference/std/errors.md +++ b/doc/reference/std/errors.md @@ -435,3 +435,38 @@ stack trace with `dump-stack-trace!`. Displays the exception `exn`, dumping the stack trace of continuation `cont` if there is no stack trace information in the exception itself. + +### exit-with-error +```scheme +(exit-with-error exception) => [exit] +``` +Display the `exception` to current error port and exit with error code 2. + +### exit-on-error? +```scheme +(def exit-on-error? (make-parameter #t)) +``` +This parameter controls whether `call-with-exit-on-error`, `with-exit-on-error`, +`call-with-getopt`, and any function that indirectly uses them, +will exit if an error is caught, rather than pass on the error +and return to the REPL (or let a more fundamental function exit). + +### call-with-exit-on-error +```scheme +(call-with-exit-on-error thunk) +``` +Calls the `thunk` in an environment wherein if an error is caught and +`(exit-on-error)` is true, `exit-with-error` will be called, +causing an error message to be printed and the process to exit with exit code 2. +If `(exit-on-error)` is false, the error will simply be raised again. + +This mechanism enables users to modify the parameter +(e.g. via a flag passed at the Unix CLI or a change made at the Scheme REPL) +and control whether to exit with an error (e.g. for end-users) +or enter a debugger REPL (e.g. for developers). + +### with-exit-on-error +```scheme +(with-exit-on-error body ...) +``` +Evaluates the `body` as in a `thunk` passed to `call-with-exit-on-error`. diff --git a/doc/reference/std/getopt.md b/doc/reference/std/getopt.md index 726ef89f15..01ba4c454b 100644 --- a/doc/reference/std/getopt.md +++ b/doc/reference/std/getopt.md @@ -1,188 +1,15 @@ # Command Line Argument Parsing -The `:std/getopt` library provides facilities for command line argument parsing. +This is the old name of the [`:std/cli/getopt`](cli/getopt.md) module, +that provides facilities for command line argument parsing. -::: tip usage -(import :std/getopt) -::: - -## Interface - -### getopt -```scheme -(getopt ...) -=> - -specifier: - (command id [help: text] ) - ... - -cmd-specifier: - (flag id short [long]) - (option id short [long] [help: text] [value: proc] [default: value]) - (argument id [help: text] [value: proc]) - (optional-argument id [help: text] [value: proc] [default: value]) - (rest-arguments id [help: text] [value: proc]) - -``` - -`getopt` creates a command line parser, which can be used to parse arguments -with `getopt-parse`. - -### getopt-parse -```scheme -(getopt-parse args) -=> (values cmd-id options) - options -``` +Up to Gerbil v0.18, `:std/getopt` was the only name for this module. +As of Gerbil v0.19, both names are supported. +However, we recommend you use the new name `:std/cli/getopt` from now on, +as we may remove the old name at some point in the future. -`getopt-parse` accepts a parser and a list of string arguments and parses -according to the parser specification. If it is parsing a specification with -subcommands, it returns two values, the command id and a hash table with the -parsed options. Otherwise it just returns the hash table with the parsed options. -An exception is raised if parsing the arguments fails. - -### getopt-error? -```scheme -(getopt-error? obj) -=> boolean -``` - -If parsing fails, then a `getopt-error` is raised, which can be guarded with -`getopt-error?`. - -### getopt-display-help -```scheme -(getopt-display-help program-name [port = (current-output-port)]) - - -tip: - - - -``` - -The procedure `getopt-display-help` can be used to display -a help message for a getopt error according to the argument specification. - -### getopt-display-help-topic -```scheme -(getopt-display-help-topic topic program-name [port = (current-output-port)]) -``` - -The procedure `getopt-display-help-topic` can be used to display a help page -for a subcommand. - -### getopt? -```scheme -(getopt? obj) -=> boolean -``` - -Returns true if the object is a getopt parser - -### getopt-object? -```scheme -(getopt-object? obj) -=> boolean -``` - -Returns true if the object is a getopt command or command specifier. - -### call-with-getopt -```scheme -(call-with-getopt proc args - program: program - help: (help #f) - exit-on-error: (exit-on-error? #t) - . gopts) -``` - -This shim around getopt parsing eliminates all the repetitive -boilerplate around argument parsing with getopt. - -It creates a getopt parser that parses with options `gopts`, automatically -including a help option or command accordingly. - -It then uses the parser to pare `args`, handling the exceptions and -displayin help accordingly; if `exit-on-error` is true (the default), -then parsing errors will exit the program. - -If the parse succeeds it invokes `proc` with the output of the parse. - -## Example - -For an example, here the a command line parser for the `gxpkg` program: +::: tip usage ```scheme -(def (main . args) - (def install-cmd - (command 'install help: "install one or more packages" - (rest-arguments 'pkg help: "package to install"))) - (def uninstall-cmd - (command 'uninstall help: "uninstall one or more packages" - (flag 'force "-f" help: "force uninstall even if there are orphaned dependencies") - (rest-arguments 'pkg help: "package to uninstall"))) - (def update-cmd - (command 'update help: "update one or more packages" - (rest-arguments 'pkg help: "package to update; all for all packages"))) - (def link-cmd - (command 'link help: "link a local development package" - (argument 'pkg help: "package to link") - (argument 'src help: "path to package source directory"))) - (def unlink-cmd - (command 'unlink help: "unlink one or more local development packages" - (flag 'force "-f" help: "force unlink even if there are orphaned dependencies") - (rest-arguments 'pkg help: "package to unlink"))) - (def build-cmd - (command 'build help: "rebuild one or more packages and their dependents" - (rest-arguments 'pkg help: "package to build; all for all packages"))) - (def clean-cmd - (command 'clean help: "clean compilation artefacts from one or more packages" - (rest-arguments 'pkg help: "package to clean"))) - (def list-cmd - (command 'list help: "list installed packages")) - (def retag-cmd - (command 'retag help: "retag installed packages")) - (def search-cmd - (command 'search help: "search the package directory" - (rest-arguments 'keywords help: "keywords to search for"))) - - (call-with-getopt gxpkg-main args - program: "gxpkg" - help: "The Gerbil Package Manager" - install-cmd - uninstall-cmd - update-cmd - link-cmd - unlink-cmd - build-cmd - clean-cmd - list-cmd - retag-cmd - search-cmd)) - -(def (gxpkg-main cmd opt) - (let-hash opt - (case cmd - ((install) - (install-pkgs .pkg)) - ((uninstall) - (uninstall-pkgs .pkg .?force)) - ((update) - (update-pkgs .pkg)) - ((link) - (link-pkg .pkg .src)) - ((unlink) - (unlink-pkgs .pkg .?force)) - ((build) - (build-pkgs .pkg)) - ((clean) - (clean-pkgs .pkg)) - ((list) - (list-pkgs)) - ((retag) - (retag-pkgs)) - ((search) - (search-pkgs .keywords))))) - +(import :std/cli/getopt) ``` +::: diff --git a/doc/reference/std/misc/alist.md b/doc/reference/std/misc/alist.md index 7c867a38dd..070d4d8c5e 100644 --- a/doc/reference/std/misc/alist.md +++ b/doc/reference/std/misc/alist.md @@ -40,7 +40,7 @@ A proper association list is a list of pairs and may be of the following forms: ``` ::: -## plist->alist +## plist->alist ``` scheme (plist->alist plist) -> alist | error diff --git a/doc/reference/std/misc/list.md b/doc/reference/std/misc/list.md index 355e3a76e9..afd3b509a8 100644 --- a/doc/reference/std/misc/list.md +++ b/doc/reference/std/misc/list.md @@ -6,7 +6,7 @@ ``` ::: -## length=?, length<? ... length>=? ## +## length=?, length=? ## ```scheme (length=? lst1 lst2) -> boolean @@ -53,7 +53,7 @@ Also, either of these two lists is allowed to be circular, but not both. ``` ::: -## length=n?, length<n? ... length>=n? ## +## length=n?, length=n? ## ```scheme (length=n? lst n) -> boolean | error diff --git a/doc/reference/std/misc/plist.md b/doc/reference/std/misc/plist.md index f6bf604829..19e1833d37 100644 --- a/doc/reference/std/misc/plist.md +++ b/doc/reference/std/misc/plist.md @@ -42,7 +42,7 @@ form: `((key1 value1 key2 value2 ...))` ``` ::: -## alist->plist +## alist->plist ``` scheme (alist->plist alist) -> plist | error diff --git a/doc/reference/std/text/base64.md b/doc/reference/std/text/base64.md index 83639790ce..25e33a8290 100644 --- a/doc/reference/std/text/base64.md +++ b/doc/reference/std/text/base64.md @@ -36,7 +36,7 @@ For some more references see: ``` ::: -## base64-string->u8vector +## base64-string->u8vector ``` scheme (base64-string->u8vector str [nopadding-ok?: #t] [urlsafe?: #f]) -> u8vector @@ -50,7 +50,7 @@ control how the conversion is done. If *nopadding-ok?* is #t (default) the value is converted. If *urlsafe?* is #t, the result is URL encoded as specified in RFC 4648. ... -## base64-substring->u8vector +## base64-substring->u8vector ``` scheme (base64-substring->u8vector str start end [nopadding-ok?: #t] [urlsafe?: #f]) -> u8vector @@ -65,7 +65,7 @@ u8vector Returns a newly allocated u8vector containing Base64 encoded value of *str* from *start* to *end* like `base64-string->u8vector`. -## u8vector->base64-string +## u8vector->base64-string ``` scheme (u8vector->base64-string u8vect [width: 0] [padding?: #t] [urlsafe?: #f]) -> string @@ -77,7 +77,7 @@ Returns a newly allocated u8vector containing Base64 encoded value of *str* from Returns a newly allocated Base64 string with bytes of *u8vect* in left-to-right order to Base64 encoded string. -## subu8vector->base64-string +## subu8vector->base64-string ``` scheme (subu8vector->base64-string u8vect start end [width: 0] [padding?: #t] [urlsafe?: #f]) -> string diff --git a/doc/tutorials/kvstore.md b/doc/tutorials/kvstore.md index 4867804769..64a3c39da1 100644 --- a/doc/tutorials/kvstore.md +++ b/doc/tutorials/kvstore.md @@ -266,7 +266,7 @@ Here is the code: (call-with-input-file input read))) ``` -The client uses [getopt](/reference/std/getopt.md) to parse the command line arguments, +The client uses [getopt](/reference/std/cli/getopt.md) to parse the command line arguments, and interacts with the kvstore server using the methods defined in [proto.ss](https://github.com/mighty-gerbils/gerbil/blob/master/src/tutorial/kvstore/proto.ss). ## Example interaction diff --git a/src/misc/http-perf/baseline.ss b/src/misc/http-perf/baseline.ss index 59ebc71694..0ba44a1b90 100644 --- a/src/misc/http-perf/baseline.ss +++ b/src/misc/http-perf/baseline.ss @@ -1,6 +1,6 @@ ;; -*- Gerbil -*- -(import :std/io - :std/getopt +(import :std/cli/getopt + :std/io :std/sugar :std/text/utf8) (export main) diff --git a/src/misc/http-perf/hellod.ss b/src/misc/http-perf/hellod.ss index dd24a803c9..46c09a8694 100644 --- a/src/misc/http-perf/hellod.ss +++ b/src/misc/http-perf/hellod.ss @@ -1,9 +1,9 @@ ;; -*- Gerbil -*- -(import :std/net/httpd - :std/getopt - :std/sugar - :gerbil/gambit - :std/misc/threads) +(import :gerbil/gambit + :std/cli/getopt + :std/misc/threads + :std/net/httpd + :std/sugar) (export main) (def (run-server address count) diff --git a/src/misc/rpc-perf/baseline-buffer.ss b/src/misc/rpc-perf/baseline-buffer.ss index e50ba33154..e9ae16af08 100644 --- a/src/misc/rpc-perf/baseline-buffer.ss +++ b/src/misc/rpc-perf/baseline-buffer.ss @@ -2,10 +2,10 @@ package: misc/rpc-perf (import :gerbil/gambit + :std/cli/getopt :std/net/socket :std/net/bio - :std/sugar - :std/getopt) + :std/sugar) (export main) (defstruct message () diff --git a/src/misc/rpc-perf/baseline-io.ss b/src/misc/rpc-perf/baseline-io.ss index dddaa3c64e..0cb270c398 100644 --- a/src/misc/rpc-perf/baseline-io.ss +++ b/src/misc/rpc-perf/baseline-io.ss @@ -2,9 +2,9 @@ package: misc/rpc-perf (import :gerbil/gambit + :std/cli/getopt :std/net/socket - :std/sugar - :std/getopt) + :std/sugar) (export main) (def (run-client address count) diff --git a/src/misc/rpc-perf/baseline-port.ss b/src/misc/rpc-perf/baseline-port.ss index d60a8add7a..9ac00258a9 100644 --- a/src/misc/rpc-perf/baseline-port.ss +++ b/src/misc/rpc-perf/baseline-port.ss @@ -2,8 +2,8 @@ package: misc/rpc-perf (import :gerbil/gambit - :std/sugar - :std/getopt) + :std/cli/getopt + :std/sugar) (export main) (defstruct message () diff --git a/src/misc/rpc-perf/nullproto.ss b/src/misc/rpc-perf/nullproto.ss index d28279e80d..1126234782 100644 --- a/src/misc/rpc-perf/nullproto.ss +++ b/src/misc/rpc-perf/nullproto.ss @@ -8,8 +8,8 @@ package: misc/rpc-perf (import :gerbil/gambit :std/actor + :std/cli/getopt :std/net/address - :std/getopt :std/sugar) (export main (proto-out null-proto)) diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index a4c01be6d7..c04f59c881 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -37,6 +37,11 @@ "amb" "contract" (gxc: "interface" ,@(include-gambit-sharp)) + ;; cli + "cli/getopt" + "cli/shell" + "cli/print-exit" + "cli/multicall" ;; stdio "io" "io/interface" diff --git a/src/std/cli/getopt.ss b/src/std/cli/getopt.ss new file mode 100644 index 0000000000..e0ca9eaaf7 --- /dev/null +++ b/src/std/cli/getopt.ss @@ -0,0 +1,454 @@ +;;; -*- Gerbil -*- +;;; (C) vyzo +;;; Command-line option and command argument parsing + +(import (only-in :std/error deferror-class Error:::init! exit-on-error? exit-with-error) + (only-in :std/generic defgeneric) + (only-in :std/iter for/collect in-iota) + (only-in :std/misc/hash hash->list/sort) + (only-in :std/misc/list when/list flatten) + (only-in :std/misc/string as-stringfunction-arguments + call-with-getopt-parse + call-with-processed-command-line + ->getopt-spec) +(def current-getopt-parser + (make-parameter #f)) + +(deferror-class GetOptError (getopt) getopt-error? + (lambda (self msg args getopt) + (Error:::init! self msg where: 'getopt irritants: args) + (set! (@ self getopt) getopt))) +(def (raise-getopt-error msg . args) + (raise (GetOptError msg args (current-getopt-parser)))) +(def getopt-error-e GetOptError-getopt) + +(defstruct !getopt (opts cmds args help)) +(defstruct !top (key help)) +(defstruct (!command !top) (opts args) + final: #t) +(defstruct (!opt !top) (short long)) +(defstruct (!option !opt) (value default) + final: #t) +(defstruct (!flag !opt) () + final: #t) +(defstruct (!arg !top) (value)) +(defstruct (!reqarg !arg) () + final: #t) +(defstruct (!optarg !arg) (default) + final: #t) +(defstruct (!rest !arg) () + final: #t) + +(def (getopt help: (help #f) . args) + (let lp ((rest args) (opts []) (cmds []) (args [])) + (match rest + ([hd . rest] + (cond + ((!opt? hd) + (lp rest (cons hd opts) cmds args)) + ((!command? hd) + (if (null? args) + (lp rest opts (cons hd cmds) args) + (error "Illegal command; already have arguments" hd))) + ((!reqarg? hd) + (if (null? cmds) + (if (or (null? args) + (and (not (!optarg? (car args))) + (not (!rest? (car args))))) + (lp rest opts cmds (cons hd args)) + (error "Illegal required argument; already have optional or rest arguments" hd)) + (error "Illegal required argument; already have commands" hd))) + ((or (!optarg? hd) + (!rest? hd)) + (if (null? cmds) + (if (or (null? args) + (not (!rest? (car args)))) + (lp rest opts cmds (cons hd args)) + (error "Illegal optional argument; already have rest arguments" hd)) + (error "Illegal optional argument; alreday have commands" hd))) + (else + (error "Illegal argument; must be a getopt-object" hd)))) + (else + (make-!getopt (reverse opts) (reverse cmds) (reverse args) help))))) + +(def (flag id short (long #f) + help: (help #f)) + (make-!flag id help short long)) + +(def (option id short (long #f) + help: (help #f) + value: (value-e identity) + default: (default #f)) + (make-!option id help short long value-e default)) + +(def (command id help: (help #f) . args) + (with ((!getopt opts cmds args) (apply getopt args)) + (if (null? cmds) + (make-!command id help opts args) + (error "Illegal command; cannot contain subcommands")))) + +(def (argument id + help: (help #f) + value: (value-e identity)) + (make-!reqarg id help value-e)) + +(def (optional-argument id + help: (help #f) + value: (value-e identity) + default: (default #f)) + (make-!optarg id help value-e default)) + +(def (rest-arguments id + help: (help #f) + value: (value-e identity)) + (make-!rest id help value-e)) + +(def (getopt-parse gopt args) + (let (ht (make-hash-table-eq)) + (getopt-parse! ht gopt args))) + +(def (getopt-parse! ht gopt rest) + (parameterize ((current-getopt-parser gopt)) + (with ((!getopt opts cmds args) gopt) + (getopt-parse-opts! ht opts rest + (if (null? cmds) + (lambda (rest) + (getopt-parse-args! ht args rest)) + (lambda (rest) + (getopt-parse-cmd! ht cmds rest))))))) + +(def (getopt-parse-opts! ht opts rest K) + (def (end rest) + ;; check for options with default values + (for-each (match <> + ((!option key _ _ _ _ default) + (unless (hash-key? ht key) + (hash-put! ht key default))) + (else (void))) + opts) + (K rest)) + + (def optht (make-hash-table)) + (for-each (lambda (opt) + (with ((!opt _ _ short long) opt) + (when short + (hash-put! optht short opt)) + (when long + (hash-put! optht long opt)))) + opts) + + (let lp ((rest rest)) + (match rest + ([hd . rest*] + (cond + ((string-empty? hd) + (lp rest*)) + ((eq? (string-ref hd 0) #\-) + (cond + ((equal? "--" hd) ; end of options + (end rest*)) + ((hash-get optht hd) + => (lambda (opt) + (match opt + ((!option key _ _ _ value-e) + (match rest* + ([val . rest*] + (hash-put! ht key (value-e val)) + (lp rest*)) + (else + (raise-getopt-error "Missing value for option" hd)))) + ((!flag key) + (hash-put! ht key #t) + (lp rest*))))) + (else + (raise-getopt-error "Unknown option" hd)))) + (else ; doesn't look like an option + (end rest)))) + (else ; we run out of arguments + (end rest))))) + +(def (getopt-parse-args! ht args rest) + (let lp ((args args) (rest rest)) + (match args + ([arg . args] + (match arg + ((!reqarg key _ value-e) + (match rest + ([val . rest] + (hash-put! ht key (value-e val)) + (lp args rest)) + (else + (raise-getopt-error "Missing argument" key)))) + ((!optarg key _ value-e default) + (match rest + ([val . rest] + (hash-put! ht key (value-e val)) + (lp args rest)) + (else + (hash-put! ht key default) + (lp args rest)))) + ((!rest key _ value-e) + (hash-put! ht key (map value-e rest)) + ht))) + (else + (unless (null? rest) + (raise-getopt-error "Unexpected arguments" rest)) + ht)))) + +(def (getopt-parse-cmd! ht cmds rest) + (def cmdht (make-hash-table)) + (for-each (lambda (cmd) + (with ((!command key) cmd) + (hash-put! cmdht (symbol->string key) cmd))) + cmds) + + (match rest + ([cmd . rest] + (cond + ((hash-get cmdht cmd) + => (lambda (cmd) + (with ((!command key _ opts args) cmd) + (parameterize ((current-getopt-parser cmd)) + (getopt-parse-opts! ht opts rest + (lambda (rest) + (getopt-parse-args! ht args rest) + (values key ht))))))) + (else + (raise-getopt-error "Unknown command" cmd)))) + (else + (raise-getopt-error "Missing command")))) + +(def (getopt->positional-names gopt) + (def rest-name #f) + (def argkey !top-key) + (def names (with-list-builder (c) + (for-each (lambda (arg) + (cond + ((or (!reqarg? arg) (!optarg? arg)) + (c (argkey arg))) + ((!rest? arg) (set! rest-name (argkey arg))))) + (!getopt-args gopt)))) + (values names rest-name)) + +(def (getopt-display-help obj program (port (current-output-port))) + (cond + ((!getopt? obj) + (display-help-getopt obj program port)) + ((!command? obj) + (display-help-command obj program port)) + ((getopt-error? obj) + (fprintf port "Error: ~a~n" (error-message obj)) + (unless (null? (error-irritants obj)) + (display "Irritants:" port) + (for-each (lambda(x) (display " " port) (display x port)) + (error-irritants obj)) + (newline)) + (newline) + (getopt-display-help (getopt-error-e obj) program port)) + (else + (error "Unexpected object; expected a getopt, getopt-error, or command" obj)))) + +(def (getopt-display-help-topic gopt topic program (port (current-output-port))) + (let lp ((rest (!getopt-cmds gopt))) + (match rest + ([cmd . rest] + (if (eq? topic (!top-key cmd)) + (getopt-display-help cmd program port) + (lp rest))) + (else + (getopt-display-help gopt program port))))) + +(def (display-help-getopt obj program port) + (with ((!getopt opts cmds args help) obj) + (when help + (fprintf port "~a: ~a~n~n" program help)) + (if (null? cmds) + (begin + (fprintf port "Usage: ~a ~a" + program + (if (null? opts) "" "[option ...]")) + (display-args args port) + (unless (null? opts) + (fprintf port "~nOptions:~n") + (display-option-help opts port)) + (unless (null? args) + (fprintf port "~nArguments:~n") + (display-arg-help args port))) + (begin + (fprintf port "Usage: ~a ~a command-arg ...~n" + program + (if (null? opts) "" "[option ...]")) + (unless (null? opts) + (fprintf port "~nOptions:~n") + (display-option-help opts port)) + (fprintf port "~nCommands:~n") + (for-each (match <> + ((!command key help) + (fprintf port " ~a ~a ~a~n" + key + (tabs key) + (or help "?")))) + cmds))))) + +(def (display-help-command obj program port) + (with ((!command key help opts args) obj) + (fprintf port "Usage: ~a ~a~a" + program key + (if (null? opts) "" " [command-option ...]")) + (display-args args port) + (fprintf port " ~a~n" help) + (unless (null? opts) + (fprintf port "~nCommand Options:~n") + (display-option-help opts port)) + (unless (null? args) + (fprintf port "~nArguments:~n") + (display-arg-help args port)))) + +(def (display-args args port) + (for-each (match <> + ((!reqarg key) + (fprintf port " <~a>" key)) + ((!optarg key) + (fprintf port " [<~a>]" key)) + ((!rest key) + (fprintf port " <~a> ..." key))) + args) + (newline port)) + +(def (display-option-help opts port) + (for-each (match <> + ((!option id help short long _ default) + (fprintf port " ~a ~a <~a> ~a ~a [default: ~a]~n" + (or short "") + (or long "") + id + (tabs (or short "") " " (or long "") " <" (symbol->string id) ">") + (or help "?") + default)) + ((!flag _ help short long) + (fprintf port " ~a ~a ~a ~a~n" + (or short "") + (or long "") + (tabs (or short "") " " (or long "")) + (or help "?")))) + opts)) + +(def (display-arg-help args port) + (for-each (match <> + ((!reqarg key help) + (fprintf port " ~a ~a ~a~n" + key (tabs key) (or help "?"))) + ((!optarg key help _ default) + (fprintf port " ~a ~a ~a [default: ~a]~n" + key (tabs key) (or help "?") + default)) + ((!rest key help) + (fprintf port " ~a ~a ~a~n" + key (tabs key) (or help "?")))) + args)) + +(def (tabs . strs) + (def tablen 31) + (def (string-e str) + (if (symbol? str) + (symbol->string str) + str)) + + (let* (len (foldl + 0 (map string-length (map string-e strs)))) + (if (fx< len tablen) + (make-string (fx- tablen len) #\space) + ""))) + +(def (call-with-getopt proc args + program: program + help: (help #f) + exit-on-error: (exit? (exit-on-error?)) + . gopts) + (def (parse! gopt) + (try + (getopt-parse gopt args) + (catch (e) + (cond + ((not exit?) (raise e)) + ((getopt-error? e) + (getopt-display-help e program (current-error-port)) + (exit 1)) + (else + (exit-with-error e)))))) + + (let* ((gopt (apply getopt help: help gopts)) + (cmds (!getopt-cmds gopt))) + (if (null? cmds) + ;; it only has options; add -h/--help + (let ((help-flag + (flag 'help "-h" "--help" + help: "display help")) + (opts (!getopt-opts gopt))) + (if (null? opts) + (set! (!getopt-opts gopt) + [help-flag]) + (set-cdr! (last-pair opts) + [help-flag])) + (let (opt (parse! gopt)) + (if (hash-get opt 'help) + (getopt-display-help gopt program) + (proc opt)))) + ;; it has commands; add help + (let (help-cmd + (command 'help help: "display help; help for command help" + (optional-argument 'command value: string->symbol))) + (set-cdr! (last-pair cmds) [help-cmd]) + (let ((values cmd opt) (parse! gopt)) + (if (eq? cmd 'help) + (getopt-display-help-topic gopt (hash-get opt 'command) program) + (proc cmd opt))))))) + +(def (getopt-parse->positional-arguments! gopt h) + (defvalues (names rest-name) (getopt->positional-names gopt)) + (def (extract n) (begin0 (hash-get h n) (hash-remove! h n))) + (def positional (map extract names)) + (def rest (when/list rest-name (extract rest-name))) + (append positional rest)) + +(def (getopt-parse->function-arguments gopt h) + (def positionals (getopt-parse->positional-arguments! gopt h)) + (append positionals + (foldr (lambda (kv l) (cons* (make-keyword (car kv)) (cdr kv) l)) '() + (hash->list/sort h as-stringfunction-arguments gopt hash))) + +(defgeneric call-with-processed-command-line + (lambda (processor command-line function) + (cond + ((!getopt? processor) + (call-with-getopt-parse processor (getopt-parse processor command-line) function)) + ((list? processor) + (call-with-processed-command-line (apply getopt processor) command-line function))))) + +(defgeneric ->getopt-spec + (lambda (spec) + (cond + ((list? spec) (flatten spec)) + ((fixnum? spec) (for/collect ((i (in-iota spec 1))) (argument (format "arg~d" i)))) + ((not spec) (rest-arguments "rest")) + (else (error "Bad getopt spec"))))) diff --git a/src/std/cli/multicall.ss b/src/std/cli/multicall.ss new file mode 100644 index 0000000000..800f414d0b --- /dev/null +++ b/src/std/cli/multicall.ss @@ -0,0 +1,99 @@ +;; -*- Gerbil -*- +;;;; Support for building a single multicall binary. + +(export #t) + +(import + (only-in :std/cli/getopt getopt getopt-display-help-topic getopt-display-help + call-with-processed-command-line ->getopt-spec + command flag option argument optional-argument rest-arguments) + (only-in :std/cli/print-exit begin-print-exit) + (only-in :std/cli/shell easy-shell-character?) + (only-in :std/format format) + (only-in :std/generic defgeneric) + (only-in :std/iter for/collect) + (only-in :std/misc/hash hash->list/sort) + (only-in :std/misc/list flatten) + (only-in :std/misc/number nat?) + (only-in :std/misc/string as-stringlist/sort h as-stringgetopt-spec (entry-point-getopt e))))) + +;; TODO: allow registering a getopt: structure and/or other command information, +;; so we can show detailed help and automatically parse arguments? +;; TODO: also allow a preprocess: function to further process the result of getopt (if specified) +;; or the raw arguments (if no getopt specified). +(def (register-entry-point function + id: (id #f) name: (name #f) help: (help #f) + getopt: (getopt #f)) + (let (name (make-symbol (or name (string-filter easy-shell-character? (as-string id))))) + (hash-put! entry-points name (make-entry-point name function help getopt)))) + +;; TODO: syntax to specify not just help, but getopt, etc. +(defrule (define-entry-point (id . formals) (options ...) body ...) + (begin (def (id . formals) body ...) + (register-entry-point id id: 'id options ...))) + +(defmutable multicall-default 'help) + +(def (set-default-entry-point! x) + (set! multicall-default x)) + +(define-entry-point (help (command #f)) + (help: "Print help about available commands" + getopt: [(optional-argument 'command help: "subcommand for which to display help")]) + #;(displayln (display-build-manifest (build-manifest/head))) ;; only available in v0.19 + (def gopt (getopt (entry-points-getopt-spec))) + (def program (current-program-string (cdr (current-program)))) + (if command + (getopt-display-help-topic gopt (make-symbol command) program) + (getopt-display-help gopt program))) + +;; TODO: also handle getopt specifications? +(define-entry-point (meta) + (help: "Print meta-information for completion purposes" + getopt: []) + (displayln (string-join (sort (map as-string (hash-keys entry-points)) string #t)) + "abcdefghijklmnopqrstuvwxzABCDEFGHIJKLMNOPQRSTUVWXZ012345678@%-_=+:,./") + (string-for-each (lambda (c) (check (easy-shell-character? c) => #f)) + "!`~#$^&*()[{]}\\|;'\"<>? \r\n\t\v")) + (test-case "needs-shell-escape?, escape-shell-token" + (defrules checks+1 () + ((_ (s e)) (begin + (check (needs-shell-escape? s) => #t) + (check (escape-shell-token s) => (string-append "\"" e "\"")))) + ((_ s) (begin + (check (needs-shell-escape? s) => #t) + (check (escape-shell-token s) => (string-append "\"" s "\""))))) + (defrule (checks+ x ...) + (begin (checks+1 x) ...)) + (checks+ "foo?" "~user" ("$1" "\\$1") "*.*" "!1" ("ab\\cd" "ab\\\\cd") + "{}" "a;b" "&" "|" "a b c") + (defrule (checks- s ...) (begin (check (needs-shell-escape? s) => #f) ...)) + (checks- "foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w")) + (test-case "->envvar" + (defrule (checks (s e) ...) + (begin (check (->envvar s) => e) ...)) + (checks ("foo" "FOO") + ("bar baz" "BAR_BAZ")) + (check (->envvar '("bar " "+!@#$") #(#\@ #\! "#") "baz") => "BAR_BAZ")))) diff --git a/src/std/cli/shell.ss b/src/std/cli/shell.ss new file mode 100644 index 0000000000..287c476629 --- /dev/null +++ b/src/std/cli/shell.ss @@ -0,0 +1,42 @@ +;; Support for Unix shells +;; TODO: If Windows shell support is needed, add it here, too. + +(export #t) + +(import + :std/srfi/13 :std/stxutil :std/text/char-set) + +(def (easy-shell-character? x) + (or (char-ascii-alphanumeric? x) (and (string-index "%+,-./:=@_" x) #t))) + +(def (needs-shell-escape? token) + ;; maybe also accept ^ and ~ in non-start position? + (not (string-every easy-shell-character? token))) + +(def (escape-shell-token token) + (if (needs-shell-escape? token) + (call-with-output-string [] + (lambda (port) + (def (p x) (display x port)) + (p #\") + (string-for-each + (lambda (c) (when (string-index "$`\\\"" c) (p #\\)) (p c)) + token) + (p #\"))) + token)) + +(def (escape-shell-tokens tokens) + (string-join (map escape-shell-token tokens) " ")) + +(def (->envvar . args) + (call-with-output-string + (lambda (p) + (def alpha? #t) + (string-for-each + (lambda (c) + (def caa? (char-ascii-alphanumeric? c)) + (when caa? + (unless alpha? (write-char #\_ p)) + (write-char c p)) + (set! alpha? caa?)) + (string-upcase (as-string args)))))) diff --git a/src/std/error.ss b/src/std/error.ss index 65b57047b2..70f3bdc770 100644 --- a/src/std/error.ss +++ b/src/std/error.ss @@ -29,7 +29,11 @@ (rename: raise-bug BUG) is-it-bug? with-exception-stack-trace - dump-stack-trace!) + dump-stack-trace! + exit-with-error + exit-on-error? + call-with-exit-on-error + with-exit-on-error) ;; utility macro for definint error classes (defsyntax (deferror-class stx) @@ -126,7 +130,7 @@ (IOError message irritants: [irritants ...])) (defraise/context (raise-premature-end-of-input where irritants ...) - (PrematureEndOfInput "premature end of input" irritants: [irritants ...])) + (PrematureEndOfInput "premature end of input" irritants: [irritants ...])) (defraise/context (raise-io-closed where message irritants ...) (Closed message irritants: [irritants ...])) @@ -352,3 +356,31 @@ wrong-number-of-values-exception-vals) (wrong-processor-c-return-exception?)) + +(def exit-on-error? (make-parameter #t)) + +(def (exit-with-error e) + (def port (current-error-port)) + (defrules ignore-errors () ((_ body ...) (with-catch void (lambda () body ...)))) + (ignore-errors (force-output port)) + #;(ignore-errors (display-build-manifest build-manifest port)) ;; only available in v0.19 + (ignore-errors (newline port)) + (ignore-errors (display-exception e port)) + ;; If the stack trace was printed, making the message out of reach of the user, + ;; then redundantly print the error message at the bottom without the stack trace. + (ignore-errors + (when (StackTrace? e) + (display-exception e port))) + (ignore-errors (force-output port)) + (exit 2)) + +(def (call-with-exit-on-error thunk) + (with-catch + (lambda (e) + (if (exit-on-error?) + (exit-with-error e) + (raise e))) + thunk)) + +(defrules with-exit-on-error () + ((_ body ...) (call-with-exit-on-error (lambda () body ...)))) diff --git a/src/std/getopt.ss b/src/std/getopt.ss index 710ce683de..5d370a1440 100644 --- a/src/std/getopt.ss +++ b/src/std/getopt.ss @@ -1,404 +1,5 @@ -;;; -*- Gerbil -*- -;;; (C) vyzo -;;; Command-line option and command argument parsing +;; Compatibility module for v0.18 +(import :std/cli/getopt) +(export (import: :std/cli/getopt)) -(import :std/error - :std/sugar - :std/format) -(export getopt - (rename: !getopt? getopt?) - (rename: !top? getopt-object?) - getopt-error? - getopt-parse - getopt-display-help - getopt-display-help-topic - option - flag - command - argument - optional-argument - rest-arguments - call-with-getopt - ) -(def current-getopt-parser - (make-parameter #f)) - -(deferror-class GetOptError (getopt) getopt-error? - (lambda (self msg args getopt) - (Error:::init! self msg where: 'getopt irritants: args) - (set! (@ self getopt) getopt))) -(def (raise-getopt-error msg . args) - (raise (GetOptError msg args (current-getopt-parser)))) -(def getopt-error-e GetOptError-getopt) - -(defstruct !getopt (opts cmds args help)) -(defstruct !top (key help)) -(defstruct (!command !top) (opts args) - final: #t) -(defstruct (!opt !top) (short long)) -(defstruct (!option !opt) (value default) - final: #t) -(defstruct (!flag !opt) () - final: #t) -(defstruct (!arg !top) (value)) -(defstruct (!reqarg !arg) () - final: #t) -(defstruct (!optarg !arg) (default) - final: #t) -(defstruct (!rest !arg) () - final: #t) - -(def (getopt help: (help #f) . args) - (let lp ((rest args) (opts []) (cmds []) (args [])) - (match rest - ([hd . rest] - (cond - ((!opt? hd) - (lp rest (cons hd opts) cmds args)) - ((!command? hd) - (if (null? args) - (lp rest opts (cons hd cmds) args) - (error "Illegal command; already have arguments" hd))) - ((!reqarg? hd) - (if (null? cmds) - (if (or (null? args) - (and (not (!optarg? (car args))) - (not (!rest? (car args))))) - (lp rest opts cmds (cons hd args)) - (error "Illegal required argument; already have optional or rest arguments" hd)) - (error "Illegal required argument; already have commands" hd))) - ((or (!optarg? hd) - (!rest? hd)) - (if (null? cmds) - (if (or (null? args) - (not (!rest? (car args)))) - (lp rest opts cmds (cons hd args)) - (error "Illegal optional argument; already have rest arguments" hd)) - (error "Illegal optional argument; alreday have commands" hd))) - (else - (error "Illegal argument; must be a getopt-object" hd)))) - (else - (make-!getopt (reverse opts) (reverse cmds) (reverse args) help))))) - -(def (flag id short (long #f) - help: (help #f)) - (make-!flag id help short long)) - -(def (option id short (long #f) - help: (help #f) - value: (value-e identity) - default: (default #f)) - (make-!option id help short long value-e default)) - -(def (command id help: (help #f) . args) - (with ((!getopt opts cmds args) (apply getopt args)) - (if (null? cmds) - (make-!command id help opts args) - (error "Illegal command; cannot contain subcommands")))) - -(def (argument id - help: (help #f) - value: (value-e identity)) - (make-!reqarg id help value-e)) - -(def (optional-argument id - help: (help #f) - value: (value-e identity) - default: (default #f)) - (make-!optarg id help value-e default)) - -(def (rest-arguments id - help: (help #f) - value: (value-e identity)) - (make-!rest id help value-e)) - -(def (getopt-parse gopt args) - (let (ht (make-hash-table-eq)) - (getopt-parse! ht gopt args))) - -(def (getopt-parse! ht gopt rest) - (parameterize ((current-getopt-parser gopt)) - (with ((!getopt opts cmds args) gopt) - (getopt-parse-opts! ht opts rest - (if (null? cmds) - (lambda (rest) - (getopt-parse-args! ht args rest)) - (lambda (rest) - (getopt-parse-cmd! ht cmds rest))))))) - -(def (getopt-parse-opts! ht opts rest K) - (def (end rest) - ;; check for options with default values - (for-each (match <> - ((!option key _ _ _ _ default) - (unless (hash-key? ht key) - (hash-put! ht key default))) - (else (void))) - opts) - (K rest)) - - (def optht (make-hash-table)) - (for-each (lambda (opt) - (with ((!opt _ _ short long) opt) - (when short - (hash-put! optht short opt)) - (when long - (hash-put! optht long opt)))) - opts) - - (let lp ((rest rest)) - (match rest - ([hd . rest*] - (cond - ((string-empty? hd) - (lp rest*)) - ((eq? (string-ref hd 0) #\-) - (cond - ((equal? "--" hd) ; end of options - (end rest*)) - ((hash-get optht hd) - => (lambda (opt) - (match opt - ((!option key _ _ _ value-e) - (match rest* - ([val . rest*] - (hash-put! ht key (value-e val)) - (lp rest*)) - (else - (raise-getopt-error "Missing value for option" hd)))) - ((!flag key) - (hash-put! ht key #t) - (lp rest*))))) - (else - (raise-getopt-error "Unknown option" hd)))) - (else ; doesn't look like an option - (end rest)))) - (else ; we run out of arguments - (end rest))))) - -(def (getopt-parse-args! ht args rest) - (let lp ((args args) (rest rest)) - (match args - ([arg . args] - (match arg - ((!reqarg key _ value-e) - (match rest - ([val . rest] - (hash-put! ht key (value-e val)) - (lp args rest)) - (else - (raise-getopt-error "Missing argument" key)))) - ((!optarg key _ value-e default) - (match rest - ([val . rest] - (hash-put! ht key (value-e val)) - (lp args rest)) - (else - (hash-put! ht key default) - (lp args rest)))) - ((!rest key _ value-e) - (hash-put! ht key (map value-e rest)) - ht))) - (else - (unless (null? rest) - (raise-getopt-error "Unexpected arguments" rest)) - ht)))) - -(def (getopt-parse-cmd! ht cmds rest) - (def cmdht (make-hash-table)) - (for-each (lambda (cmd) - (with ((!command key) cmd) - (hash-put! cmdht (symbol->string key) cmd))) - cmds) - - (match rest - ([cmd . rest] - (cond - ((hash-get cmdht cmd) - => (lambda (cmd) - (with ((!command key _ opts args) cmd) - (parameterize ((current-getopt-parser cmd)) - (getopt-parse-opts! ht opts rest - (lambda (rest) - (getopt-parse-args! ht args rest) - (values key ht))))))) - (else - (raise-getopt-error "Unknown command" cmd)))) - (else - (raise-getopt-error "Missing command")))) - -(def (getopt-display-help obj program (port (current-output-port))) - (cond - ((!getopt? obj) - (display-help-getopt obj program port)) - ((!command? obj) - (display-help-command obj program port)) - ((getopt-error? obj) - (fprintf port "Error: ~a~n" (error-message obj)) - (unless (null? (error-irritants obj)) - (display "Irritants:" port) - (for-each (lambda(x) (display " " port) (display x port)) - (error-irritants obj)) - (newline)) - (newline) - (getopt-display-help (getopt-error-e obj) program port)) - (else - (error "Unexpected object; expected a getopt, getopt-error, or command" obj)))) - -(def (getopt-display-help-topic gopt topic program (port (current-output-port))) - (let lp ((rest (!getopt-cmds gopt))) - (match rest - ([cmd . rest] - (if (eq? topic (!top-key cmd)) - (getopt-display-help cmd program port) - (lp rest))) - (else - (getopt-display-help gopt program port))))) - -(def (display-help-getopt obj program port) - (with ((!getopt opts cmds args help) obj) - (when help - (fprintf port "~a: ~a~n~n" program help)) - (if (null? cmds) - (begin - (fprintf port "Usage: ~a ~a" - program - (if (null? opts) "" "[option ...]")) - (display-args args port) - (unless (null? opts) - (fprintf port "~nOptions:~n") - (display-option-help opts port)) - (unless (null? args) - (fprintf port "~nArguments:~n") - (display-arg-help args port))) - (begin - (fprintf port "Usage: ~a ~a command-arg ...~n" - program - (if (null? opts) "" "[option ...]")) - (unless (null? opts) - (fprintf port "~nOptions:~n") - (display-option-help opts port)) - (fprintf port "~nCommands:~n") - (for-each (match <> - ((!command key help) - (fprintf port " ~a ~a ~a~n" - key - (tabs key) - (or help "?")))) - cmds))))) - -(def (display-help-command obj program port) - (with ((!command key help opts args) obj) - (fprintf port "Usage: ~a ~a~a" - program key - (if (null? opts) "" " [command-option ...]")) - (display-args args port) - (fprintf port " ~a~n" help) - (unless (null? opts) - (fprintf port "~nCommand Options:~n") - (display-option-help opts port)) - (unless (null? args) - (fprintf port "~nArguments:~n") - (display-arg-help args port)))) - -(def (display-args args port) - (for-each (match <> - ((!reqarg key) - (fprintf port " <~a>" key)) - ((!optarg key) - (fprintf port " [<~a>]" key)) - ((!rest key) - (fprintf port " <~a> ..." key))) - args) - (newline port)) - -(def (display-option-help opts port) - (for-each (match <> - ((!option id help short long _ default) - (fprintf port " ~a ~a <~a> ~a ~a [default: ~a]~n" - (or short "") - (or long "") - id - (tabs (or short "") " " (or long "") " <" (symbol->string id) ">") - (or help "?") - default)) - ((!flag _ help short long) - (fprintf port " ~a ~a ~a ~a~n" - (or short "") - (or long "") - (tabs (or short "") " " (or long "")) - (or help "?")))) - opts)) - -(def (display-arg-help args port) - (for-each (match <> - ((!reqarg key help) - (fprintf port " ~a ~a ~a~n" - key (tabs key) (or help "?"))) - ((!optarg key help _ default) - (fprintf port " ~a ~a ~a [default: ~a]~n" - key (tabs key) (or help "?") - default)) - ((!rest key help) - (fprintf port " ~a ~a ~a~n" - key (tabs key) (or help "?")))) - args)) - -(def (tabs . strs) - (def tablen 31) - (def (string-e str) - (if (symbol? str) - (symbol->string str) - str)) - - (let* (len (foldl + 0 (map string-length (map string-e strs)))) - (if (fx< len tablen) - (make-string (fx- tablen len) #\space) - ""))) - -(def (call-with-getopt proc args - program: program - help: (help #f) - exit-on-error: (exit-on-error? #t) - . gopts) - (def (parse! gopt return) - (try - (getopt-parse gopt args) - (catch (getopt-error? exn) - (getopt-display-help exn program (current-error-port)) - (if exit-on-error? - (exit 1) - (return 'error))) - (catch (e) - (display-exception e (current-error-port)) - (if exit-on-error? - (exit 2) - (return 'error))))) - - (let/cc return - (let* ((gopt (apply getopt help: help gopts)) - (cmds (!getopt-cmds gopt))) - (if (null? cmds) - ;; it only has options; add -h/--help - (let ((help-flag - (flag 'help "-h" "--help" - help: "display help")) - (opts (!getopt-opts gopt))) - (if (null? opts) - (set! (!getopt-opts gopt) - [help-flag]) - (set-cdr! (last-pair opts) - [help-flag])) - (let (opt (parse! gopt return)) - (if (hash-get opt 'help) - (getopt-display-help gopt program) - (proc opt)))) - ;; it has commands; add help - (let (help-cmd - (command 'help help: "display help; help for command help" - (optional-argument 'command value: string->symbol))) - (set-cdr! (last-pair cmds) [help-cmd]) - (let ((values cmd opt) (parse! gopt return)) - (if (eq? cmd 'help) - (getopt-display-help-topic gopt (hash-get opt 'command) program) - (proc cmd opt)))))))) +;; TODO: as a (begin-syntax (warnf ...)) compile-time deprecation warning at some point. diff --git a/src/tools/gxensemble.ss b/src/tools/gxensemble.ss index 1f2512516b..89374e712f 100644 --- a/src/tools/gxensemble.ss +++ b/src/tools/gxensemble.ss @@ -2,10 +2,6 @@ ;;; © vyzo ;;; actor ensemble management tool (import :gerbil/expander - :std/sugar - :std/iter - :std/getopt - :std/logger :std/actor :std/actor-v18/cookie :std/actor-v18/server @@ -13,9 +9,13 @@ :std/actor-v18/registry :std/actor-v18/path :std/actor-v18/tls - :std/os/hostname + :std/cli/getopt + :std/iter + :std/logger :std/misc/ports :std/misc/process + :std/os/hostname + :std/sugar :std/text/hex) (export main) diff --git a/src/tools/gxpkg.ss b/src/tools/gxpkg.ss index 01ac2c6a24..827846ccd4 100644 --- a/src/tools/gxpkg.ss +++ b/src/tools/gxpkg.ss @@ -23,17 +23,17 @@ ;;; TODO: add private repos support (import :gerbil/gambit + :std/cli/getopt :std/format - :std/getopt - :std/sugar :std/iter - :std/sort - :std/pregexp - :std/net/request :std/misc/process :std/misc/template + :std/net/request + :std/pregexp + :std/sort + (only-in :std/srfi/1 reverse!) (only-in :std/srfi/13 string-trim) - (only-in :std/srfi/1 reverse!)) + :std/sugar) (export main ;; script api pkg-root-dir @@ -1108,7 +1108,7 @@ END ;;; -*- Gerbil -*- (import :std/error :std/sugar - :std/getopt + :std/cli/getopt ./lib) (export main) @@ -1120,7 +1120,7 @@ END (call-with-getopt ${name}-main args program: "${name}" help: "A one line description of your program" - ;; commands/options/flags for your program; see :std/getopt + ;; commands/options/flags for your program; see :std/cli/getopt ;; ... )) diff --git a/src/tools/gxprof.ss b/src/tools/gxprof.ss index d1d51853ce..ec0731341b 100644 --- a/src/tools/gxprof.ss +++ b/src/tools/gxprof.ss @@ -8,10 +8,10 @@ ;;; as a list [[procedure-name ....] ...] (import :gerbil/expander - :std/sugar - :std/getopt + :std/cli/getopt :std/format - :std/sort) + :std/sort + :std/sugar) (export main) (def (main . args) diff --git a/src/tools/gxtags.ss b/src/tools/gxtags.ss index 01b2a84515..ad6a429c10 100644 --- a/src/tools/gxtags.ss +++ b/src/tools/gxtags.ss @@ -8,13 +8,13 @@ (only-in :gerbil/compiler/base ast-case) (only-in syntax) :gerbil/gambit - :std/getopt - :std/sugar - :std/sort - :std/text/utf8 + :std/cli/getopt :std/misc/ports :std/os/temporaries - (only-in :std/srfi/1 delete-duplicates reverse!)) + :std/sort + (only-in :std/srfi/1 delete-duplicates reverse!) + :std/sugar + :std/text/utf8) (export main make-tags) (def (main . args) diff --git a/src/tools/gxtest.ss b/src/tools/gxtest.ss index 741808f4ae..e48228ec4c 100644 --- a/src/tools/gxtest.ss +++ b/src/tools/gxtest.ss @@ -1,16 +1,16 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; tool to run tests without the need of glue code -(import :gerbil/gambit - :gerbil/expander - :std/sugar - :std/getopt - :std/iter +(import :gerbil/expander + :gerbil/gambit + :std/cli/getopt :std/format - :std/sort - :std/test + :std/iter :std/pregexp - :std/srfi/13) + :std/sort + :std/srfi/13 + :std/sugar + :std/test) (export main) (def (main . args) diff --git a/src/tutorial/ensemble/httpd-prod-exe.ss b/src/tutorial/ensemble/httpd-prod-exe.ss index 2fb7bb4c81..00274b779d 100644 --- a/src/tutorial/ensemble/httpd-prod-exe.ss +++ b/src/tutorial/ensemble/httpd-prod-exe.ss @@ -1,8 +1,8 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; "production httpd executable -(import :std/getopt - :std/actor +(import :std/actor + :std/cli/getopt :std/sugar ./server) (export main) diff --git a/src/tutorial/ensemble/registry-prod-exe.ss b/src/tutorial/ensemble/registry-prod-exe.ss index 3a1bc35c53..1df41935a3 100644 --- a/src/tutorial/ensemble/registry-prod-exe.ss +++ b/src/tutorial/ensemble/registry-prod-exe.ss @@ -1,9 +1,9 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; "production httpd executable -(import :std/getopt - :std/actor +(import :std/actor :std/actor-v18/registry + :std/cli/getopt :std/sugar) (export main) diff --git a/src/tutorial/httpd/simpled.ss b/src/tutorial/httpd/simpled.ss index dac2a368e0..ed5be165fa 100644 --- a/src/tutorial/httpd/simpled.ss +++ b/src/tutorial/httpd/simpled.ss @@ -1,12 +1,12 @@ ;;; -*- Gerbil -*- ;;; (C) vyzo at hackzen.org ;;; Simple web server -(import :std/net/httpd +(import :std/cli/getopt + :std/iter :std/net/address - :std/text/json + :std/net/httpd :std/sugar - :std/iter - :std/getopt) + :std/text/json) (export main) (def (run address) diff --git a/src/tutorial/kvstore/kvstorec.ss b/src/tutorial/kvstore/kvstorec.ss index b948408634..c4ad408e0e 100644 --- a/src/tutorial/kvstore/kvstorec.ss +++ b/src/tutorial/kvstore/kvstorec.ss @@ -2,10 +2,10 @@ ;;; © vyzo ;;; kvstore command line client (import :gerbil/gambit - :std/sugar - :std/getopt :std/actor + :std/cli/getopt :std/misc/ports + :std/sugar ./proto) (export main) diff --git a/src/tutorial/proxy/tcp-proxy1.ss b/src/tutorial/proxy/tcp-proxy1.ss index bfccea2ac6..46b1996378 100644 --- a/src/tutorial/proxy/tcp-proxy1.ss +++ b/src/tutorial/proxy/tcp-proxy1.ss @@ -1,12 +1,12 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; transparent TCP proxy using low level socket programming -(import :std/os/socket - :std/os/fd - :std/os/error +(import :std/cli/getopt :std/event - :std/getopt :std/logger + :std/os/error + :std/os/fd + :std/os/socket :std/sugar) (export main) diff --git a/src/tutorial/proxy/tcp-proxy2.ss b/src/tutorial/proxy/tcp-proxy2.ss index 46d3d79e92..5eed14b14a 100644 --- a/src/tutorial/proxy/tcp-proxy2.ss +++ b/src/tutorial/proxy/tcp-proxy2.ss @@ -1,11 +1,11 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; transparent TCP proxy using stdio -(import :std/sugar +(import :std/cli/getopt :std/logger - :std/getopt :std/net/address - :std/io) + :std/io + :std/sugar) (export main) (deflogger tcp-proxy) diff --git a/src/tutorial/proxy/tcp-proxy3.ss b/src/tutorial/proxy/tcp-proxy3.ss index 7d7c1d169f..00d7d22a58 100644 --- a/src/tutorial/proxy/tcp-proxy3.ss +++ b/src/tutorial/proxy/tcp-proxy3.ss @@ -1,12 +1,12 @@ ;;; -*- Gerbil -*- ;;; © vyzo ;;; transparent TCP proxy using stdio -(import :std/contract - :std/sugar +(import :std/cli/getopt + :std/contract + :std/io :std/logger - :std/getopt :std/net/address - :std/io) + :std/sugar) (export main) (deflogger tcp-proxy)