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