This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
This is my patch patch.1g for perl5.001.
[perl5.git] / lib / Getopt / Std.pm
1 package Getopt::Std;
2 require 5.000;
3 require Exporter;
4
5 =head1 NAME
6
7 getopt - Process single-character switches with switch clustering
8
9 getopts - Process single-character switches with switch clustering
10
11 =head1 SYNOPSIS
12
13     use Getopt::Std;
14     getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
15     getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
16                       # Sets opt_* as a side effect.
17
18 =head1 DESCRIPTION
19
20 The getopt() functions processes single-character switches with switch
21 clustering.  Pass one argument which is a string containing all switches
22 that take an argument.  For each switch found, sets $opt_x (where x is the
23 switch name) to the value of the argument, or 1 if no argument.  Switches
24 which take an argument don't care whether there is a space between the
25 switch and the argument.
26
27 =cut
28
29 @ISA = qw(Exporter);
30 @EXPORT = qw(getopt getopts);
31
32 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
33
34 # Process single-character switches with switch clustering.  Pass one argument
35 # which is a string containing all switches that take an argument.  For each
36 # switch found, sets $opt_x (where x is the switch name) to the value of the
37 # argument, or 1 if no argument.  Switches which take an argument don't care
38 # whether there is a space between the switch and the argument.
39
40 # Usage:
41 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
42
43 sub getopt {
44     local($argumentative) = @_;
45     local($_,$first,$rest);
46     local $Exporter::ExportLevel;
47
48     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
49         ($first,$rest) = ($1,$2);
50         if (index($argumentative,$first) >= 0) {
51             if ($rest ne '') {
52                 shift(@ARGV);
53             }
54             else {
55                 shift(@ARGV);
56                 $rest = shift(@ARGV);
57             }
58             eval "\$opt_$first = \$rest;";
59             push( @EXPORT, "\$opt_$first" );
60         }
61         else {
62             eval "\$opt_$first = 1;";
63             push( @EXPORT, "\$opt_$first" );
64             if ($rest ne '') {
65                 $ARGV[0] = "-$rest";
66             }
67             else {
68                 shift(@ARGV);
69             }
70         }
71     }
72     $Exporter::ExportLevel++;
73     import Getopt::Std;
74 }
75
76 # Usage:
77 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
78 #                       #  side effect.
79
80 sub getopts {
81     local($argumentative) = @_;
82     local(@args,$_,$first,$rest);
83     local($errs) = 0;
84     local $Exporter::ExportLevel;
85
86     @args = split( / */, $argumentative );
87     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
88         ($first,$rest) = ($1,$2);
89         $pos = index($argumentative,$first);
90         if($pos >= 0) {
91             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
92                 shift(@ARGV);
93                 if($rest eq '') {
94                     ++$errs unless @ARGV;
95                     $rest = shift(@ARGV);
96                 }
97                 eval "\$opt_$first = \$rest;";
98                 push( @EXPORT, "\$opt_$first" );
99             }
100             else {
101                 eval "\$opt_$first = 1";
102                 push( @EXPORT, "\$opt_$first" );
103                 if($rest eq '') {
104                     shift(@ARGV);
105                 }
106                 else {
107                     $ARGV[0] = "-$rest";
108                 }
109             }
110         }
111         else {
112             print STDERR "Unknown option: $first\n";
113             ++$errs;
114             if($rest ne '') {
115                 $ARGV[0] = "-$rest";
116             }
117             else {
118                 shift(@ARGV);
119             }
120         }
121     }
122     $Exporter::ExportLevel++;
123     import Getopt::Std;
124     $errs == 0;
125 }
126
127 1;
128