Previous: Command Service, Up: Embedded Commands


6.1.4.6 Command Example

Here is an example of setting up a command with arguments and parsing those arguments from a getopt style argument list (see Getopt).

     (require 'database-commands)
     (require 'databases)
     (require 'getopt-parameters)
     (require 'parameters)
     (require 'getopt)
     (require 'fluid-let)
     (require 'printf)
     
     (define my-rdb (add-command-tables (create-database #f 'alist-table)))
     
     (define-tables my-rdb
       '(foo-params
         *parameter-columns*
         *parameter-columns*
         ((1 single-string single string
             (lambda (pl) '("str")) #f "single string")
          (2 nary-symbols nary symbol
             (lambda (pl) '()) #f "zero or more symbols")
          (3 nary1-symbols nary1 symbol
             (lambda (pl) '(symb)) #f "one or more symbols")
          (4 optional-number optional ordinal
             (lambda (pl) '()) #f "zero or one number")
          (5 flag boolean boolean
             (lambda (pl) '(#f)) #f "a boolean flag")))
       '(foo-pnames
         ((name string))
         ((parameter-index ordinal))
         (("s" 1)
          ("single-string" 1)
          ("n" 2)
          ("nary-symbols" 2)
          ("N" 3)
          ("nary1-symbols" 3)
          ("o" 4)
          ("optional-number" 4)
          ("f" 5)
          ("flag" 5)))
       '(my-commands
         ((name symbol))
         ((parameters parameter-list)
          (parameter-names parameter-name-translation)
          (procedure expression)
          (documentation string))
         ((foo
           foo-params
           foo-pnames
           (lambda (rdb) (lambda args (print args)))
           "test command arguments"))))
     
     (define (dbutil:serve-command-line rdb command-table command argv)
       (set! *argv* (if (vector? argv) (vector->list argv) argv))
       ((make-command-server rdb command-table)
        command
        (lambda (comname comval options positions
                         arities types defaulters dirs aliases)
          (apply comval (getopt->arglist options positions
                         arities types defaulters dirs aliases)))))
     
     (define (cmd . opts)
       (fluid-let ((*optind* 1))
         (printf "%-34s ⇒ "
                 (call-with-output-string
                  (lambda (pt) (write (cons 'cmd opts) pt))))
         (set! opts (cons "cmd" opts))
         (force-output)
         (dbutil:serve-command-line
          my-rdb 'my-commands 'foo (length opts) opts)))
     
     (cmd)                              ⇒ ("str" () (symb) () #f)
     (cmd "-f")                         ⇒ ("str" () (symb) () #t)
     (cmd "--flag")                     ⇒ ("str" () (symb) () #t)
     (cmd "-o177")                      ⇒ ("str" () (symb) (177) #f)
     (cmd "-o" "177")                   ⇒ ("str" () (symb) (177) #f)
     (cmd "--optional" "621")           ⇒ ("str" () (symb) (621) #f)
     (cmd "--optional=621")             ⇒ ("str" () (symb) (621) #f)
     (cmd "-s" "speciality")            ⇒ ("speciality" () (symb) () #f)
     (cmd "-sspeciality")               ⇒ ("speciality" () (symb) () #f)
     (cmd "--single" "serendipity")     ⇒ ("serendipity" () (symb) () #f)
     (cmd "--single=serendipity")       ⇒ ("serendipity" () (symb) () #f)
     (cmd "-n" "gravity" "piety")       ⇒ ("str" () (piety gravity) () #f)
     (cmd "-ngravity" "piety")          ⇒ ("str" () (piety gravity) () #f)
     (cmd "--nary" "chastity")          ⇒ ("str" () (chastity) () #f)
     (cmd "--nary=chastity" "")         ⇒ ("str" () ( chastity) () #f)
     (cmd "-N" "calamity")              ⇒ ("str" () (calamity) () #f)
     (cmd "-Ncalamity")                 ⇒ ("str" () (calamity) () #f)
     (cmd "--nary1" "surety")           ⇒ ("str" () (surety) () #f)
     (cmd "--nary1=surety")             ⇒ ("str" () (surety) () #f)
     (cmd "-N" "levity" "fealty")       ⇒ ("str" () (fealty levity) () #f)
     (cmd "-Nlevity" "fealty")          ⇒ ("str" () (fealty levity) () #f)
     (cmd "--nary1" "surety" "brevity") ⇒ ("str" () (brevity surety) () #f)
     (cmd "--nary1=surety" "brevity")   ⇒ ("str" () (brevity surety) () #f)
     (cmd "-?")
     -|
     Usage: cmd [OPTION ARGUMENT ...] ...
     
       -f, --flag
       -o, --optional[=]<number>
       -n, --nary[=]<symbols> ...
       -N, --nary1[=]<symbols> ...
       -s, --single[=]<string>
     
     ERROR: getopt->parameter-list "unrecognized option" "-?"