File Coverage

blib/script/shell-quote
Criterion Covered Total %
statement 21 38 55.2
branch 8 20 40.0
condition 4 18 22.2
subroutine 5 9 55.5
pod n/a
total 38 85 44.7


line stmt bran cond sub pod time code
1             #!/usr/local/bin/perl -w
2              
3 4         8 eval 'exec /usr/local/bin/perl -w -S $0 ${1+"$@"}'
4             if 0; # not running under some shell
5 4     4   22 use strict;
  4         6  
  4         178  
6              
7             # $Id: shell-quote,v 1.3 2010-06-11 20:00:24 roderick Exp $
8             #
9             # Roderick Schertler
10              
11             # Copyright (C) 1999 Roderick Schertler
12             #
13             # This program is free software; you can redistribute it and/or modify
14             # it under the terms of the GNU General Public License as published by
15             # the Free Software Foundation; either version 2 of the License, or (at
16             # your option) any later version.
17             #
18             # This program is distributed in the hope that it will be useful,
19             # but WITHOUT ANY WARRANTY; without even the implied warranty of
20             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21             # General Public License for more details.
22             #
23             # For a copy of the GNU General Public License write to the Free Software
24             # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25              
26 4     4   2090 use String::ShellQuote qw(shell_quote);
  4         8  
  4         9063  
27              
28 4 50       47 (my $Me = $0 ne '-e' ? $0 : $^X) =~ s-.*/--;
29 4         9 my $Debug = 0;
30 4         8 my $Exit = 0;
31 4 50       29 my $Version = q$Revision: 1.3 $ =~ /(\d\S+)/ ? $1 : '?';
32              
33             my @Option_spec = (
34             'debug!' => \$Debug,
35 0     0   0 'help!' => sub { usage() },
36 0     0   0 'version' => sub { print "$Me version $Version\n"; exit },
  0         0  
37 4         47 );
38              
39 4         22 my $Usage = <
40             usage: $Me [switch]...
41             switches:
42             --debug turn debugging on
43             --help show this and then die
44             --version show the version ($Version) and exit
45             Use \`perldoc $Me\' to see the full documentation.
46             EOF
47              
48             sub debug {
49 0 0   0   0 print STDERR "debug: ", @_, "\n" if $Debug;
50             }
51              
52             sub usage {
53 0 0   0   0 warn "$Me: ", @_ if @_;
54             # Use exit() rather than die(), as Getopt::Long does eval().
55 0         0 print STDERR $Usage;
56 0         0 exit 1;
57             }
58              
59             # This is basically Getopt::Long but it has the defaults set up the way I
60             # think they should be.
61              
62             sub getopt {
63             # Don't bother if there aren't any switches. This test works because
64             # I'm setting $REQUIRE_ORDER.
65 3 50 33 3   38 return 1 unless @ARGV && substr($ARGV[0], 0, 1) eq '-';
66              
67 0         0 my $bundling = 0;
68 0 0 0     0 if (@_ && ($_[0] eq -bundle || $_[0] eq -bundling)) {
      0        
69 0         0 $bundling = 1;
70 0         0 shift;
71             }
72              
73             {
74             # I'm setting this environment variable when loading Getopt::Long
75             # so that the defaults for options added later (which aren't set
76             # explicitly below) are more likely to match what I'd like.
77 0         0 local $ENV{POSIXLY_CORRECT} = 1;
  0         0  
78 0         0 require Getopt::Long;
79             }
80              
81 0         0 Getopt::Long->VERSION(2.19);
82 0 0       0 Getopt::Long::Configure(
83             'no_auto_abbrev',
84             'no_getopt_compat',
85             'require_order',
86             $bundling ? 'bundling' : (),
87             'no_ignore_case',
88             'prefix_pattern=(--|-)',
89             ) if 1;
90              
91             # The getopt function puts the vars into its caller's package so
92             # it's necessary to jump to it so that its caller is my caller.
93             #goto &Getopt::Long::GetOptions;
94 0         0 Getopt::Long::GetOptions(@_);
95             }
96              
97             sub init {
98 4 100 33 4   30 getopt -bundle, @Option_spec or usage if @ARGV;
99             }
100              
101             sub main {
102 4     4   14 init;
103 4 100       26 print shell_quote(@ARGV), "\n"
104             if @ARGV;
105 4         32 return 0;
106             }
107              
108 4   33     15 $Exit = main || $Exit;
109 4 50 33     17 $Exit = 1 if $Exit && !($Exit % 256);
110 4         0 exit $Exit;
111              
112             __END__