Rename tied_handle_method() to tied_method(), and make it non-static.
[perl.git] / lib / getopts.pl
1 warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n";
2
3 ;# getopts.pl - a better getopt.pl
4 #
5 # This library is no longer being maintained, and is included for backward
6 # compatibility with Perl 4 programs which may require it.
7 #
8 # In particular, this should not be used as an example of modern Perl
9 # programming techniques.
10 #
11 # Suggested alternatives: Getopt::Long  or  Getopt::Std
12
13 ;# Usage:
14 ;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
15 ;#                           #  side effect.
16
17 sub Getopts {
18     local($argumentative) = @_;
19     local(@args,$_,$first,$rest);
20     local($errs) = 0;
21
22     @args = split( / */, $argumentative );
23     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
24                 ($first,$rest) = ($1,$2);
25                 $pos = index($argumentative,$first);
26                 if($pos >= 0) {
27                         if($args[$pos+1] eq ':') {
28                                 shift(@ARGV);
29                                 if($rest eq '') {
30                                         ++$errs unless(@ARGV);
31                                         $rest = shift(@ARGV);
32                                 }
33                                 eval "
34                                 push(\@opt_$first, \$rest);
35                                 if (!defined \$opt_$first or \$opt_$first eq '') {
36                                         \$opt_$first = \$rest;
37                                 }
38                                 else {
39                                         \$opt_$first .= ' ' . \$rest;
40                                 }
41                                 ";
42                         }
43                         else {
44                                 eval "\$opt_$first = 1";
45                                 if($rest eq '') {
46                                         shift(@ARGV);
47                                 }
48                                 else {
49                                         $ARGV[0] = "-$rest";
50                                 }
51                         }
52                 }
53                 else {
54                         print STDERR "Unknown option: $first\n";
55                         ++$errs;
56                         if($rest ne '') {
57                                 $ARGV[0] = "-$rest";
58                         }
59                         else {
60                                 shift(@ARGV);
61                         }
62                 }
63         }
64     $errs == 0;
65 }
66
67 1;