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