lib/Automake/Getopt.pm

   1 # Copyright (C) 2012-2017 Free Software Foundation, Inc.
   2
   3 # This program is free software: you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation, either version 3 of the License, or
   6 # (at your option) any later version.
   7
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 package Automake::Getopt;
  17
  18 =head1 NAME
  19
  20 Automake::Getopt - GCS conforming parser for command line options
  21
  22 =head1 SYNOPSIS
  23
  24   use Automake::Getopt;
  25
  26 =head1 DESCRIPTION
  27
  28 Export a function C<parse_options>, performing parsing of command
  29 line options in conformance to the GNU Coding standards.
  30
  31 =cut
  32
  33 use 5.006;
  34 use strict;
  35 use warnings FATAL => 'all';
  36 use Exporter ();
  37 use Getopt::Long ();
  38 use Automake::ChannelDefs qw/fatal/;
  39 use Carp qw/croak confess/;
  40
  41 use vars qw (@ISA @EXPORT);
  42 @ISA = qw (Exporter);
  43 @EXPORT= qw/getopt/;
  44
  45 =item C<parse_options (%option)>
  46
  47 Wrapper around C<Getopt::Long>, trying to conform to the GNU
  48 Coding Standards for error messages.
  49
  50 =cut
  51
  52 sub parse_options (%)
  53 {
  54   my %option = @_;
  55
  56   Getopt::Long::Configure ("bundling", "pass_through");
  57   # Unrecognized options are passed through, so GetOption can only fail
  58   # due to internal errors or misuse of options specification.
  59   Getopt::Long::GetOptions (%option)
  60     or confess "error in options specification (likely)";
  61
  62   if (@ARGV && $ARGV[0] =~ /^-./)
  63     {
  64       my %argopts;
  65       for my $k (keys %option)
  66         {
  67           if ($k =~ /(.*)=s$/)
  68             {
  69               map { $argopts{(length ($_) == 1)
  70                              ? "-$_" : "--$_" } = 1; } (split (/\|/, $1));
  71             }
  72         }
  73       if ($ARGV[0] eq '--')
  74         {
  75           shift @ARGV;
  76         }
  77       elsif (exists $argopts{$ARGV[0]})
  78         {
  79           fatal ("option '$ARGV[0]' requires an argument\n"
  80                  . "Try '$0 --help' for more information.");
  81         }
  82       else
  83         {
  84           fatal ("unrecognized option '$ARGV[0]'.\n"
  85                  . "Try '$0 --help' for more information.");
  86         }
  87     }
  88 }
  89
  90 =back
  91
  92 =head1 SEE ALSO
  93
  94 L<Getopt::Long>
  95
  96 =cut
  97
  98 1; # for require