summaryrefslogtreecommitdiff
path: root/fonts/utilities/mkpkfontdir/lnggetopt.pl
blob: f3a1bc2988b06ea40c611359bbabfb131ad30bd3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
# newgetopt.pl -- new options parsing

# SCCS Status     : @(#)@ newgetopt.pl	1.14
# Author          : Johan Vromans
# Created On      : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Sat Feb 12 18:24:02 1994
# Update Count    : 138
# Status          : Okay

# Modified by Yves Arrouye under the name 'lnggetopt.pl' for use with Perl 4

################ Introduction ################
#
# This package implements an extended getopt function. This function adheres
# to the new syntax (long option names, no bundling).
# It tries to implement the better functionality of traditional, GNU and
# POSIX getopt functions.
# 
# This program is Copyright 1990,1994 by Johan Vromans.
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# If you do not have a copy of the GNU General Public License write to
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
# MA 02139, USA.

################ Description ################
#
# Usage:
# 
#    require "lnggetopt.pl";
#    ...change configuration values, if needed...
#    $result = &NGetOpt (...option-descriptions...);
# 
# Each description should designate a valid perl identifier, optionally
# followed by an argument specifier.
# 
# Values for argument specifiers are:
# 
#   <none>   option does not take an argument
#   !        option does not take an argument and may be negated
#   =s :s    option takes a mandatory (=) or optional (:) string argument
#   =i :i    option takes a mandatory (=) or optional (:) integer argument
#   =f :f    option takes a mandatory (=) or optional (:) real number argument
# 
# If option "name" is set, it will cause the perl variable $opt_name to
# be set to the specified value. The calling program can use this
# variable to detect whether the option has been set. Options that do
# not take an argument will be set to 1 (one).
# 
# Options that take an optional argument will be defined, but set to ''
# if no actual argument has been supplied.
# 
# If an "@" sign is appended to the argument specifier, the option is
# treated as an array. Value(s) are not set, but pushed into array
# @opt_name.
# 
# Options that do not take a value may have an "!" argument spacifier to
# indicate that they may be negated. E.g. "foo!" will allow -foo (which
# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
# 
# The option name may actually be a list of option names, separated by
# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
# 'blech' will set $opt_foo instead.
# 
# Option names may be abbreviated to uniqueness, depending on
# configuration variable $autoabbrev.
# 
# Dashes in option names are allowed (e.g. pcc-struct-return) and will
# be translated to underscores in the corresponding perl variable (e.g.
# $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
# option, corresponding perl identifier is $opt_ .
# 
# A double dash "--" signals end of the options list.
# 
# If the first option of the list consists of non-alphanumeric
# characters only, it is interpreted as a generic option starter.
# Everything starting with one of the characters from the starter will
# be considered an option.
# 
# The default values for the option starters are "-" (traditional), "--"
# (POSIX) and "+" (GNU, being phased out).
# 
# Options that start with "--" may have an argument appended, separated
# with an "=", e.g. "--foo=bar".
# 
# If configuration varaible $getopt_compat is set to a non-zero value,
# options that start with "+" may also include their arguments,
# e.g. "+foo=bar".
# 
# A return status of 0 (false) indicates that the function detected
# one or more errors.
#
################ Some examples ################
# 
# If option "one:i" (i.e. takes an optional integer argument), then
# the following situations are handled:
# 
#    -one -two		-> $opt_one = '', -two is next option
#    -one -2		-> $opt_one = -2
# 
# Also, assume "foo=s" and "bar:s" :
# 
#    -bar -xxx		-> $opt_bar = '', '-xxx' is next option
#    -foo -bar		-> $opt_foo = '-bar'
#    -foo --		-> $opt_foo = '--'
# 
# In GNU or POSIX format, option names and values can be combined:
# 
#    +foo=blech		-> $opt_foo = 'blech'
#    --bar=		-> $opt_bar = ''
#    --bar=--		-> $opt_bar = '--'
# 
################ Configuration values ################
# 
#   $autoabbrev      Allow option names to be abbreviated to uniqueness.
#                    Default is 1 unless environment variable
#                    POSIXLY_CORRECT has been set.
# 
#   $getopt_compat   Allow '+' to start options.
#                    Default is 1 unless environment variable
#                    POSIXLY_CORRECT has been set.
# 
#   $option_start    Regexp with option starters.
#                    Default is (--|-) if environment variable
#                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
# 
#   $order           Whether non-options are allowed to be mixed with
#                    options.
#                    Default is $REQUIRE_ORDER if environment variable
#                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
# 
#   $ignorecase      Ignore case when matching options. Default is 1.
# 
#   $debug           Enable debugging output. Default is 0.

################ History ################
# 
# 12-Feb-1994		Johan Vromans	
#    Added "!" for negation.
#    Released to the net.
#
# 26-Aug-1992		Johan Vromans	
#    More POSIX/GNU compliance.
#    Lone dash and double-dash are now independent of the option prefix
#      that is used.
#    Make errors in NGetOpt parameters fatal.
#    Allow options to be mixed with arguments.
#      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
#    Allow --foo=bar and +foo=bar (but not -foo=bar).
#    Allow options to be abbreviated to minimum needed for uniqueness.
#      (Controlled by configuration variable $autoabbrev.)
#    Allow alias names for options (e.g. "foo|bar=s").
#    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
#      translated to "_" to form valid perl identifiers
#      (e.g. $opt_pcc_struct_return). 
#
# 2-Jun-1992		Johan Vromans	
#    Do not use //o to allow multiple NGetOpt calls with different delimeters.
#    Prevent typeless option from using previous $array state.
#    Prevent empty option from being eaten as a (negative) number.
#
# 25-May-1992		Johan Vromans	
#    Add array options. "foo=s@" will return an array @opt_foo that
#    contains all values that were supplied. E.g. "-foo one -foo -two" will
#    return @opt_foo = ("one", "-two");
#    Correct bug in handling options that allow for a argument when followed
#    by another option.
#
# 4-May-1992		Johan Vromans	
#    Add $ignorecase to match options in either case.
#    Allow '' option.
#
# 19-Mar-1992		Johan Vromans	
#    Allow require from packages.
#    NGetOpt is now defined in the package that requires it.
#    @ARGV and $opt_... are taken from the package that calls it.
#    Use standard (?) option prefixes: -, -- and +.
#
# 20-Sep-1990		Johan Vromans	
#    Set options w/o argument to 1.
#    Correct the dreadful semicolon/require bug.

################ Configuration Section ################

{
    package lnggetopt;

    # Values for $order. See GNU getopt.c for details.
    $REQUIRE_ORDER = 0;
    $PERMUTE = 1;
    $RETURN_IN_ORDER = 2;

    # Handle POSIX compliancy.
    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
	$autoabbrev = 0;	# no automatic abbrev of options (???)
	$getopt_compat = 0;	# disallow '+' to start options
	$option_start = "(--|-)";
	$order = $REQUIRE_ORDER;
    }
    else {
	$autoabbrev = 1;	# automatic abbrev of options
	$getopt_compat = 1;	# allow '+' to start options
	$option_start = "(--|-|\\+)";
	$order = $PERMUTE;
    }

    # Other configurable settings.
    $debug = 0;			# for debugging
    $ignorecase = 1;		# ignore case when matching options
    $argv_end = "--";		# don't change this!
}

################ Subroutines ################

sub GetOptions {

    @lnggetopt'optionlist = @_;	#';

    package lnggetopt;

    local ($[) = 0;
    local ($genprefix) = $option_start;
    local ($argend) = $argv_end;
    local ($error) = 0;
    local ($opt, $optx, $arg, $type, $mand, %opctl);
    local ($pkg) = (caller)[0];
    local ($optarg);
    local (%aliases);
    local (@ret) = ();

    print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;

    # See if the first element of the optionlist contains option
    # starter characters.
    if ( $optionlist[0] =~ /^\W+$/ ) {
	$genprefix = shift (@optionlist);
	# Turn into regexp.
	$genprefix =~ s/(\W)/\\$1/g;
	$genprefix = "[" . $genprefix . "]";
    }

    # Verify correctness of optionlist.
    %opctl = ();
    foreach $opt ( @optionlist ) {
	$opt =~ tr/A-Z/a-z/ if $ignorecase;
	if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
	    die ("Error in option spec: \"", $opt, "\"\n");
	    $error++;
	    next;
	}
	local ($o, $c, $a) = ($1, $2);

	if ( ! defined $o ) {
	    $opctl{''} = defined $c ? $c : '';
	}
	else {
	    # Handle alias names
	    foreach ( split (/\|/, $o)) {
		if ( defined $c && $c eq '!' ) {
		    $opctl{"no$_"} = $c;
		    $c = '';
		}
		$opctl{$_} = defined $c ? $c : '';
		if ( defined $a ) {
		    # Note alias.
		    $aliases{$_} = $a;
		}
		else {
		    # Set primary name.
		    $a = $_;
		}
	    }
	}
    }
    @opctl = sort(keys (%opctl)) if $autoabbrev;

    return 0 if $error;

    if ( $debug ) {
	local ($arrow, $k, $v);
	$arrow = "=> ";
	while ( ($k,$v) = each(%opctl) ) {
	    print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
	    $arrow = "   ";
	}
    }

    # Process argument list

    while ( $#ARGV >= 0 ) {

	# >>> See also the continue block <<<

	#### Get next argument ####

	$opt = shift (@ARGV);
	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
	$arg = undef;
	$optarg = undef;
	$array = 0;

	#### Determine what we have ####

	# Double dash is option list terminator.
	if ( $opt eq $argend ) {
	    unshift (@ret, @ARGV) if $order == $PERMUTE;
	    return ($error == 0);
	}
	elsif ( $opt =~ /^$genprefix/ ) {
	    # Looks like an option.
	    $opt = $';		# option name (w/o prefix)
	    # If it is a long opt, it may include the value.
	    if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
		$opt =~ /^([^=]+)=/ ) {
		$opt = $1;
		$optarg = $';
		print STDERR ("=> option \"", $opt, 
			      "\", optarg = \"$optarg\"\n")
		    if $debug;
	    }

	}
	# Not an option. Save it if we may permute...
	elsif ( $order == $PERMUTE ) {
	    push (@ret, $opt);
	    next;
	}
	# ...otherwise, terminate.
	else {
	    # Push back and exit.
	    unshift (@ARGV, $opt);
	    return ($error == 0);
	}

	#### Look it up ###

	$opt =~ tr/A-Z/a-z/ if $ignorecase;

	local ($tryopt) = $opt;
	if ( $autoabbrev ) {
	    local ($pat, @hits);

	    # Turn option name into pattern.
	    ($pat = $opt) =~ s/(\W)/\\$1/g;
	    # Look up in option names.
	    @hits = grep (/^$pat/, @opctl);
	    print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
			  "out of ", 0+@opctl, "\n")
		if $debug;

	    # Check for ambiguous results.
	    unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
		print STDERR ("Option ", $opt, " is ambiguous (",
			      join(", ", @hits), ")\n");
		$error++;
		next;
	    }

	    # Complete the option name, if appropriate.
	    if ( @hits == 1 && $hits[0] ne $opt ) {
		$tryopt = $hits[0];
		print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
		    if $debug;
	    }
	}

	unless  ( defined ( $type = $opctl{$tryopt} ) ) {
	    print STDERR ("Unknown option: ", $opt, "\n");
	    $error++;
	    next;
	}
	$opt = $tryopt;
	print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;

	#### Determine argument status ####

	# If it is an option w/o argument, we're almost finished with it.
	if ( $type eq '' || $type eq '!' ) {
	    if ( defined $optarg ) {
		print STDERR ("Option ", $opt, " does not take an argument\n");
		$error++;
	    }
	    elsif ( $type eq '' ) {
		$arg = 1;		# supply explicit value
	    }
	    else {
		substr ($opt, 0, 2) = ''; # strip NO prefix
		$arg = 0;		# supply explicit value
	    }
	    next;
	}

	# Get mandatory status and type info.
	($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;

	# Check if there is an option argument available.
	if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {

	    # Complain if this option needs an argument.
	    if ( $mand eq "=" ) {
		print STDERR ("Option ", $opt, " requires an argument\n");
		$error++;
	    }
	    if ( $mand eq ":" ) {
		$arg = $type eq "s" ? '' : 0;
	    }
	    next;
	}

	# Get (possibly optional) argument.
	$arg = defined $optarg ? $optarg : shift (@ARGV);

	#### Check if the argument is valid for this option ####

	if ( $type eq "s" ) {	# string
	    # A mandatory string takes anything. 
	    next if $mand eq "=";

	    # An optional string takes almost anything. 
	    next if defined $optarg;
	    next if $arg eq "-";

	    # Check for option or option list terminator.
	    if ($arg eq $argend ||
		$arg =~ /^$genprefix.+/) {
		# Push back.
		unshift (@ARGV, $arg);
		# Supply empty value.
		$arg = '';
	    }
	    next;
	}

	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
	    if ( $arg !~ /^-?[0-9]+$/ ) {
		if ( defined $optarg || $mand eq "=" ) {
		    print STDERR ("Value \"", $arg, "\" invalid for option ",
				  $opt, " (number expected)\n");
		    $error++;
		    undef $arg;	# don't assign it
		}
		else {
		    # Push back.
		    unshift (@ARGV, $arg);
		    # Supply default value.
		    $arg = 0;
		}
	    }
	    next;
	}

	if ( $type eq "f" ) { # fixed real number, int is also ok
	    if ( $arg !~ /^-?[0-9.]+$/ ) {
		if ( defined $optarg || $mand eq "=" ) {
		    print STDERR ("Value \"", $arg, "\" invalid for option ",
				  $opt, " (real number expected)\n");
		    $error++;
		    undef $arg;	# don't assign it
		}
		else {
		    # Push back.
		    unshift (@ARGV, $arg);
		    # Supply default value.
		    $arg = 0.0;
		}
	    }
	    next;
	}

	die ("NGetOpt internal error (Can't happen)\n");
    }

    continue {
	if ( defined $arg ) {
	    $opt = $aliases{$opt} if defined $aliases{$opt};
	    # Make sure a valid perl identifier results.
	    $opt =~ s/\W/_/g;
	    if ( $array ) {
		print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
		    if $debug;
	        eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
	    }
	    else {
		print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
		    if $debug;
	        eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
	    }
	}
    }

    if ( $order == $PERMUTE && @ret > 0 ) {
	unshift (@ARGV, @ret);
    }
    return ($error == 0);
}

################ Package return ################

1;