contrib/ntp/sntp/ag-tpl/0-old/perlopt.tpl

   1 [= AutoGen5 template foo=(base-name) -*- Mode: scheme -*-=]
   2 [=
   3
   4 (emit (dne "# "))
   5
   6 (if (not (and (exist? "prog-name") (exist? "prog-title") (exist? "version")))
   7     (error "prog-name and prog-title are required"))
   8 (define prog-name (get "prog-name"))
   9
  10 (if (> (string-length prog-name) 16)
  11     (error (sprintf "prog-name limited to 16 characters:  %s"
  12            prog-name)) )
  13 (if (not (exist? "long-opts"))
  14     (error "long-opts is required"))
  15
  16 ;; perl list containing string to initialize the option hash
  17 (define perl_opts "")
  18 ;; perl list containing option definitions for Getopt::Long
  19 (define perl_defs "       ")
  20 ;; usage string
  21 (define perl_usage "")
  22
  23 (define optname-from "A-Z_^")
  24 (define optname-to   "a-z--")
  25 (define counter 0)
  26
  27 (define q (lambda (s) (string-append "'" s "'")))
  28 (define qp (lambda (s) (string-append "q{" s "}")))
  29
  30 =][=
  31
  32 FOR flag =][=
  33
  34 (define optarg "")      ;; the option argument for Getopt::Long
  35 (define opttarget "''") ;; the value of a hash key that represents option
  36 (define optargname "")
  37 (define optisarray #f)
  38 (define optname (string-tr! (get "name") optname-from optname-to))
  39
  40 =][= #
  41 ;; since autoopts doesn't support float we take the combination arg-name =
  42 ;; float and arg-type = string as float
  43 =][=
  44   IF arg-type       =][=
  45     CASE arg-type   =][=
  46
  47     =* num          =][= (set! optarg "=i") =][=
  48
  49     =* str          =][=
  50         (if (and (exist? "arg-name") (== (get "arg-name") "float"))
  51             (set! optarg "=f")
  52             (set! optarg "=s")
  53         )           =][=
  54
  55     *               =][=
  56         (error (string-append "unknown arg type '"
  57         (get "arg-type") "' for " (get "name"))) =][=
  58     ESAC arg-type   =][=
  59   ENDIF             =][=
  60
  61 (if (exist? "stack-arg")
  62     ;; set optarget to array reference if can take more than one value
  63     ;;  FIXME:  if "max" exists, then just presume it is greater than 1
  64     ;;
  65     (if (and (exist? "max") (== (get "max") "NOLIMIT"))
  66         (begin
  67           (set! opttarget (string-append
  68             "["
  69             (if (exist? "arg-default") (q (get "arg-default")) "")
  70             "]"
  71             )
  72           )
  73           (set! optisarray #t)
  74         )
  75         (error "If stack-arg then max has to be NOLIMIT")
  76     )
  77     ;; just scalar otherwise
  78     (if (exist? "arg-default") (set! opttarget (q (get "arg-default"))))
  79 )
  80
  81 (set! perl_opts (string-append perl_opts
  82       "'" (get "name") "' => " opttarget ",\n        "))
  83
  84 (define def_add (string-append "'" optname (if (exist? "value")
  85                   (string-append "|" (get "value")) "") optarg "',"))
  86
  87 (define add_len (+ (string-length def_add) counter))
  88 (if (> add_len 80)
  89     (begin
  90       (set! perl_defs (string-append perl_defs "\n        " def_add))
  91       (set! counter 8)
  92     )
  93     (begin
  94       (set! perl_defs (string-append perl_defs " " def_add))
  95       (set! counter (+ counter add_len))
  96     )
  97 )
  98
  99 (if (exist? "arg-type")
 100     (if (and (exist? "arg-name") (== (get "arg-name") "float"))
 101         (set! optargname "=float")
 102         (set! optargname (string-append "=" (substring (get "arg-type") 0 3)))
 103     )
 104     (set! optargname "  ")
 105 )
 106
 107 (if (not (exist? "deprecated"))
 108     (set! perl_usage (string-append perl_usage
 109        (sprintf "\n    %-28s %s" (string-append
 110             (if (exist? "value") (string-append "-" (get "value") ",") "   ")
 111             " --"
 112             (get "name")
 113             optargname)
 114          (get "descrip"))
 115 )   )  )
 116 (if optisarray
 117   (set! perl_usage (string-append perl_usage
 118         "\n                                   - may appear multiple times"))
 119 )
 120
 121 =][=
 122
 123 ENDFOR each "flag" =]
 124
 125 use Getopt::Long qw(GetOptionsFromArray);
 126 Getopt::Long::Configure(qw(no_auto_abbrev no_ignore_case_always));
 127
 128 my $usage;
 129
 130 sub usage {
 131     my ($ret) = @_;
 132     print STDERR $usage;
 133     exit $ret;
 134 }
 135
 136 sub paged_usage {
 137     my ($ret) = @_;
 138     my $pager = $ENV{PAGER} || '(less || more)';
 139
 140     open STDOUT, "| $pager" or die "Can't fork a pager: $!";
 141     print $usage;
 142
 143     exit $ret;
 144 }
 145
 146 sub processOptions {
 147     my $args = shift;
 148
 149     my $opts = {
 150         [= (. perl_opts) =]'help' => '', 'more-help' => ''
 151     };
 152     my $argument = '[= argument =]';
 153     my $ret = GetOptionsFromArray($args, $opts, (
 154 [= (. perl_defs) =]
 155         'help|?', 'more-help'));
 156
 157     $usage = <<'USAGE';
 158 [= prog-name =] - [= prog-title =] - Ver. [= version =]
 159 USAGE: [= prog-name =] [ -<flag> [<val>] | --<name>[{=| }<val>] ]... [= argument =]
 160 [= (. perl_usage)   =]
 161     -?, --help                   Display usage information and exit
 162         --more-help              Pass the extended usage information through a pager
 163
 164 Options are specified by doubled hyphens and their name or by a single
 165 hyphen and the flag character.
 166 USAGE
 167
 168     usage(0)       if $opts->{'help'};
 169     paged_usage(0) if $opts->{'more-help'};[=
 170
 171 CASE argument       =][=
 172 !E                  =][=
 173 ==* "["             =][=
 174 *                   =]
 175
 176     if ($argument && $argument =~ /^[^\[]/ && !@$args) {
 177         print STDERR "Not enough arguments supplied (See --help/-?)\n";
 178         exit 1;
 179     }[=
 180
 181 ESAC
 182
 183 =]
 184     $_[0] = $opts;
 185     return $ret;
 186 }
 187
 188 END { close STDOUT };