lib/Autom4te/Getopt.pm

   1 # Copyright (C) 2012-2023 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 Autom4te::Getopt;
  17
  18 =head1 NAME
  19
  20 Autom4te::Getopt - GCS conforming parser for command line options
  21
  22 =head1 SYNOPSIS
  23
  24   use Autom4te::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
  37 use Carp qw (confess croak);
  38 use Exporter ();
  39 use Getopt::Long ();
  40
  41 use Autom4te::ChannelDefs qw (fatal);
  42
  43 our @ISA = qw (Exporter);
  44 our @EXPORT = qw (getopt);
  45
  46 =item C<parse_options (%option)>
  47
  48 Wrapper around C<Getopt::Long>, trying to conform to the GNU
  49 Coding Standards for error messages.
  50
  51 =cut
  52
  53 sub parse_options (%)
  54 {
  55   my %option = @_;
  56
  57   Getopt::Long::Configure ("bundling", "pass_through");
  58   # Unrecognized options are passed through, so GetOption can only fail
  59   # due to internal errors or misuse of options specification.
  60   Getopt::Long::GetOptions (%option)
  61     or confess "error in options specification (likely)";
  62
  63   if (@ARGV && $ARGV[0] =~ /^-./)
  64     {
  65       my %argopts;
  66       for my $k (keys %option)
  67         {
  68           if ($k =~ /(.*)=s$/)
  69             {
  70               map { $argopts{(length ($_) == 1)
  71                              ? "-$_" : "--$_" } = 1; } (split (/\|/, $1));
  72             }
  73         }
  74       if ($ARGV[0] eq '--')
  75         {
  76           shift @ARGV;
  77         }
  78       elsif (exists $argopts{$ARGV[0]})
  79         {
  80           fatal ("option '$ARGV[0]' requires an argument\n"
  81                  . "Try '$0 --help' for more information.");
  82         }
  83       else
  84         {
  85           fatal ("unrecognized option '$ARGV[0]'.\n"
  86                  . "Try '$0 --help' for more information.");
  87         }
  88     }
  89 }
  90
  91 =back
  92
  93 =head1 SEE ALSO
  94
  95 L<Getopt::Long>
  96
  97 =cut
  98
  99 1; # for require