modules/fallback/String/ShellQuote.pm

   1 # $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
   2 #
   3 # Copyright (c) 1997 Roderick Schertler.  All rights reserved.  This
   4 # program is free software; you can redistribute it and/or modify it
   5 # under the same terms as Perl itself.
   6
   7 =head1 NAME
   8
   9 String::ShellQuote - quote strings for passing through the shell
  10
  11 =head1 SYNOPSIS
  12
  13     $string = shell_quote @list;
  14     $string = shell_quote_best_effort @list;
  15     $string = shell_comment_quote $string;
  16
  17 =head1 DESCRIPTION
  18
  19 This module contains some functions which are useful for quoting strings
  20 which are going to pass through the shell or a shell-like object.
  21
  22 =over
  23
  24 =cut
  25
  26 package String::ShellQuote;
  27
  28 use strict;
  29 use vars qw($VERSION @ISA @EXPORT);
  30
  31 require Exporter;
  32
  33 $VERSION    = '1.04';
  34 @ISA        = qw(Exporter);
  35 @EXPORT     = qw(shell_quote shell_quote_best_effort shell_comment_quote);
  36
  37 sub croak {
  38     require Carp;
  39     goto &Carp::croak;
  40 }
  41
  42 sub _shell_quote_backend {
  43     my @in = @_;
  44     my @err = ();
  45
  46     if (0) {
  47   require RS::Handy;
  48   print RS::Handy::data_dump(\@in);
  49     }
  50
  51     return \@err, '' unless @in;
  52
  53     my $ret = '';
  54     my $saw_non_equal = 0;
  55     foreach (@in) {
  56   if (!defined $_ or $_ eq '') {
  57       $_ = "''";
  58       next;
  59   }
  60
  61   if (s/\x00//g) {
  62       push @err, "No way to quote string containing null (\\000) bytes";
  63   }
  64
  65       my $escape = 0;
  66
  67   # = needs quoting when it's the first element (or part of a
  68   # series of such elements), as in command position it's a
  69   # program-local environment setting
  70
  71   if (/=/) {
  72       if (!$saw_non_equal) {
  73         $escape = 1;
  74       }
  75   }
  76   else {
  77       $saw_non_equal = 1;
  78   }
  79
  80   if (m|[^\w!%+,\-./:=@^]|) {
  81       $escape = 1;
  82   }
  83
  84   if ($escape
  85     || (!$saw_non_equal && /=/)) {
  86
  87       # ' -> '\''
  88           s/'/'\\''/g;
  89
  90       # make multiple ' in a row look simpler
  91       # '\'''\'''\'' -> '"'''"'
  92           s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
  93
  94       $_ = "'$_'";
  95       s/^''//;
  96       s/''$//;
  97   }
  98     }
  99     continue {
 100   $ret .= "$_ ";
 101     }
 102
 103     chop $ret;
 104     return \@err, $ret;
 105 }
 106
 107 =item B<shell_quote> [I<string>]...
 108
 109 B<shell_quote> quotes strings so they can be passed through the shell.
 110 Each I<string> is quoted so that the shell will pass it along as a
 111 single argument and without further interpretation.  If no I<string>s
 112 are given an empty string is returned.
 113
 114 If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
 115
 116 =cut
 117
 118 sub shell_quote {
 119     my ($rerr, $s) = _shell_quote_backend @_;
 120
 121     if (@$rerr) {
 122       my %seen;
 123       @$rerr = grep { !$seen{$_}++ } @$rerr;
 124   my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
 125   chomp $s;
 126   croak $s;
 127     }
 128     return $s;
 129 }
 130
 131 =item B<shell_quote_best_effort> [I<string>]...
 132
 133 This is like B<shell_quote>, excpet if the string can't be safely quoted
 134 it does the best it can and returns the result, instead of dying.
 135
 136 =cut
 137
 138 sub shell_quote_best_effort {
 139     my ($rerr, $s) = _shell_quote_backend @_;
 140
 141     return $s;
 142 }
 143
 144 =item B<shell_comment_quote> [I<string>]
 145
 146 B<shell_comment_quote> quotes the I<string> so that it can safely be
 147 included in a shell-style comment (the current algorithm is that a sharp
 148 character is placed after any newlines in the string).
 149
 150 This routine might be changed to accept multiple I<string> arguments
 151 in the future.  I haven't done this yet because I'm not sure if the
 152 I<string>s should be joined with blanks ($") or nothing ($,).  Cast
 153 your vote today!  Be sure to justify your answer.
 154
 155 =cut
 156
 157 sub shell_comment_quote {
 158     return '' unless @_;
 159     unless (@_ == 1) {
 160   croak "Too many arguments to shell_comment_quote "
 161             . "(got " . @_ . " expected 1)";
 162     }
 163     local $_ = shift;
 164     s/\n/\n#/g;
 165     return $_;
 166 }
 167
 168 1;
 169
 170 __END__
 171
 172 =back
 173
 174 =head1 EXAMPLES
 175
 176     $cmd = 'fuser 2>/dev/null ' . shell_quote @files;
 177     @pids = split ' ', `$cmd`;
 178
 179     print CFG "# Configured by: ",
 180     shell_comment_quote($ENV{LOGNAME}), "\n";
 181
 182 =head1 BUGS
 183
 184 Only Bourne shell quoting is supported.  I'd like to add other shells
 185 (particularly cmd.exe), but I'm not familiar with them.  It would be a
 186 big help if somebody supplied the details.
 187
 188 =head1 AUTHOR
 189
 190 Roderick Schertler <F<roderick@argon.org>>
 191
 192 =head1 SEE ALSO
 193
 194 perl(1).
 195
 196 =cut
 197