[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[groff] [PATCH] Avoid Perl's unsafe "<>" operator
|
From: |
Colin Watson |
|
Subject: |
[groff] [PATCH] Avoid Perl's unsafe "<>" operator |
|
Date: |
Thu, 24 Jan 2019 14:34:35 +0000 |
|
User-agent: |
NeoMutt/20170113 (1.7.2) |
The "<>" operator is implemented using the two-argument form of "open",
which interprets magic such as pipe characters, allowing execution of
arbitrary commands which is unlikely to be expected. Perl >= 5.22 has a
"<<>>" operator which avoids this, but also forbids the use of "-" to
mean the standard input, which is a facility that the affected groff
programs document.
ARGV::readonly would probably also fix this, but I fundamentally dislike
the approach of escaping data in preparation for a language facility to
unescape it, especially when the required escaping is as non-obvious as
it is here. (For the same reason, I prefer to use subprocess invocation
facilities that allow passing the argument list as a list rather than as
a string to be interpreted by the shell.) So I've abandoned this
dubious convenience and changed the affected programs to iterate over
command-line arguments manually using the three-argument form of open.
This change involves an extra level of indentation, so it's a little
awkward to review. It consists of changing this form:
while (<>) { # or foreach, which is similar but less efficient
...
}
... into this:
unshift @ARGV, '-' unless @ARGV;
foreach my $filename (@ARGV) {
my $input;
if ($filename eq '-') {
$input = \*STDIN;
} elsif (not open $input, '<', $filename) {
warn $!;
next;
}
while (<$input>) {
...
}
}
Local variations: glilypond doesn't need the initial unshift since
that's already handled in contrib/glilypond/args.pl; gropdf declares
$input in a slightly different way since it's also used in the LoadAhead
function.
Fixes: https://bugs.debian.org/920269
---
contrib/glilypond/glilypond.pl | 128 +++++++++++-----------
contrib/gperl/gperl.pl | 188 +++++++++++++++++----------------
contrib/gpinyin/gpinyin.pl | 88 ++++++++-------
src/devices/gropdf/gropdf.pl | 99 +++++++++--------
tmac/hyphenex.pl | 86 ++++++++-------
5 files changed, 318 insertions(+), 271 deletions(-)
diff --git a/contrib/glilypond/glilypond.pl b/contrib/glilypond/glilypond.pl
index 868801b2..f2a76158 100755
--- a/contrib/glilypond/glilypond.pl
+++ b/contrib/glilypond/glilypond.pl
@@ -565,73 +565,81 @@ our $Read =
); # end definition %lilypond_args
- LILYPOND: foreach (<>) {
- chomp;
- my $line = $_;
+ LILYPOND: foreach my $filename (@ARGV) {
+ my $input;
+ if ($filename eq '-') {
+ $input = \*STDIN;
+ } elsif (not open $input, '<', $filename) {
+ warn $!;
+ next;
+ }
+ while (<$input>) {
+ chomp;
+ my $line = $_;
- # now the lines with '.lilypond ...'
+ # now the lines with '.lilypond ...'
- if ( /
- ^
- [.']
- \s*
- lilypond
- (
- .*
- )
- $
- /x ) { # .lilypond ...
- my $args = $1;
- $args =~ s/
- ^
- \s*
- //x;
- $args =~ s/
- \s*
- $
- //x;
- $args =~ s/
- ^
- (
- \S*
- )
- \s*
- //x;
- my $arg1 = $1; # 'start', 'end' or 'include'
- $args =~ s/["'`]//g;
- my $arg2 = $args; # file argument for '.lilypond include'
-
- if ( exists $lilypond_args{$arg1} ) {
- $lilypond_args{$arg1}->($arg2);
- next;
- } else {
- # not a suitable argument of '.lilypond'
- $stderr->print( "Unknown command: '$arg1' '$arg2': '$line'" );
- }
-
- next LILYPOND;
- } # end if for .lilypond
+ if ( /
+ ^
+ [.']
+ \s*
+ lilypond
+ (
+ .*
+ )
+ $
+ /x ) { # .lilypond ...
+ my $args = $1;
+ $args =~ s/
+ ^
+ \s*
+ //x;
+ $args =~ s/
+ \s*
+ $
+ //x;
+ $args =~ s/
+ ^
+ (
+ \S*
+ )
+ \s*
+ //x;
+ my $arg1 = $1; # 'start', 'end' or 'include'
+ $args =~ s/["'`]//g;
+ my $arg2 = $args; # file argument for '.lilypond include'
+
+ if ( exists $lilypond_args{$arg1} ) {
+ $lilypond_args{$arg1}->($arg2);
+ next;
+ } else {
+ # not a suitable argument of '.lilypond'
+ $stderr->print( "Unknown command: '$arg1' '$arg2': '$line'" );
+ }
+ next LILYPOND;
+ } # end if for .lilypond
- if ( $lilypond_mode ) { # do lilypond-mode
- # see '.lilypond start'
- $ly->print( $line );
- next LILYPOND;
- } # do lilypond-mode
- # unknown line without lilypond
- unless ( /
- ^
- [.']
- \s*
- lilypond
- /x ) { # not a '.lilypond' line
- $out->print($line);
- next LILYPOND;
- }
+ if ( $lilypond_mode ) { # do lilypond-mode
+ # see '.lilypond start'
+ $ly->print( $line );
+ next LILYPOND;
+ } # do lilypond-mode
- } # end foreach <>
+ # unknown line without lilypond
+ unless ( /
+ ^
+ [.']
+ \s*
+ lilypond
+ /x ) { # not a '.lilypond' line
+ $out->print($line);
+ next LILYPOND;
+ }
+ } # end while <$input>
+ } # end foreach $filename
} # end Read
diff --git a/contrib/gperl/gperl.pl b/contrib/gperl/gperl.pl
index fdb93fff..6eb2f13b 100755
--- a/contrib/gperl/gperl.pl
+++ b/contrib/gperl/gperl.pl
@@ -132,114 +132,124 @@ my $out_file;
my $perl_mode = 0;
-foreach (<>) {
- chomp;
- s/\s+$//;
- my $line = $_;
- my $is_dot_Perl = $line =~ /^[.']\s*Perl(|\s+.*)$/;
-
- unless ( $is_dot_Perl ) { # not a '.Perl' line
- if ( $perl_mode ) { # is running in Perl mode
- print OUT $line;
- } else { # normal line, not Perl-related
- print $line;
- }
+unshift @ARGV, '-' unless @ARGV;
+foreach my $filename (@ARGV) {
+ my $input;
+ if ($filename eq '-') {
+ $input = \*STDIN;
+ } elsif (not open $input, '<', $filename) {
+ warn $!;
next;
}
-
-
- ##########
- # now the line is a '.Perl' line
-
- my $args = $line;
- $args =~ s/\s+$//; # remove final spaces
- $args =~ s/^[.']\s*Perl\s*//; # omit .Perl part, leave the arguments
-
- my @args = split /\s+/, $args;
-
- ##########
- # start Perl mode
- if ( @args == 0 || @args == 1 && $args[0] eq 'start' ) {
- # For '.Perl' no args or first arg 'start' means opening 'Perl' mode.
- # Everything else means an ending command.
- if ( $perl_mode ) {
- # '.Perl' was started twice, ignore
- print STDERR q('.Perl' starter was run several times);
- next;
- } else { # new Perl start
- $perl_mode = 1;
- open OUT, '>', $out_file;
+ while (<$input>) {
+ chomp;
+ s/\s+$//;
+ my $line = $_;
+ my $is_dot_Perl = $line =~ /^[.']\s*Perl(|\s+.*)$/;
+
+ unless ( $is_dot_Perl ) { # not a '.Perl' line
+ if ( $perl_mode ) { # is running in Perl mode
+ print OUT $line;
+ } else { # normal line, not Perl-related
+ print $line;
+ }
next;
}
- }
- ##########
- # now the line must be a Perl ending line (stop)
- unless ( $perl_mode ) {
- print STDERR 'gperl: there was a Perl ending without being in ' .
- 'Perl mode:';
- print STDERR ' ' . $line;
- next;
- }
+ ##########
+ # now the line is a '.Perl' line
+
+ my $args = $line;
+ $args =~ s/\s+$//; # remove final spaces
+ $args =~ s/^[.']\s*Perl\s*//; # omit .Perl part, leave the arguments
+
+ my @args = split /\s+/, $args;
+
+ ##########
+ # start Perl mode
+ if ( @args == 0 || @args == 1 && $args[0] eq 'start' ) {
+ # For '.Perl' no args or first arg 'start' means opening 'Perl' mode.
+ # Everything else means an ending command.
+ if ( $perl_mode ) {
+ # '.Perl' was started twice, ignore
+ print STDERR q('.Perl' starter was run several times);
+ next;
+ } else { # new Perl start
+ $perl_mode = 1;
+ open OUT, '>', $out_file;
+ next;
+ }
+ }
- $perl_mode = 0; # 'Perl' stop calling is correct
- close OUT; # close the storing of 'Perl' commands
+ ##########
+ # now the line must be a Perl ending line (stop)
- ##########
- # run this 'Perl' part, later on about storage of the result
- # array stores prints with \n
- my @print_res = `perl $out_file`;
+ unless ( $perl_mode ) {
+ print STDERR 'gperl: there was a Perl ending without being in ' .
+ 'Perl mode:';
+ print STDERR ' ' . $line;
+ next;
+ }
- # remove 'stop' arg if exists
- shift @args if ( $args[0] eq 'stop' );
+ $perl_mode = 0; # 'Perl' stop calling is correct
+ close OUT; # close the storing of 'Perl' commands
- if ( @args == 0 ) {
- # no args for saving, so @print_res doesn't matter
- next;
- }
+ ##########
+ # run this 'Perl' part, later on about storage of the result
+ # array stores prints with \n
+ my @print_res = `perl $out_file`;
- my @var_names = ();
- my @mode_names = ();
+ # remove 'stop' arg if exists
+ shift @args if ( $args[0] eq 'stop' );
- my $mode = '.ds';
- for ( @args ) {
- if ( /^\.?ds$/ ) {
- $mode = '.ds';
+ if ( @args == 0 ) {
+ # no args for saving, so @print_res doesn't matter
next;
}
- if ( /^\.?nr$/ ) {
- $mode = '.nr';
- next;
+
+ my @var_names = ();
+ my @mode_names = ();
+
+ my $mode = '.ds';
+ for ( @args ) {
+ if ( /^\.?ds$/ ) {
+ $mode = '.ds';
+ next;
+ }
+ if ( /^\.?nr$/ ) {
+ $mode = '.nr';
+ next;
+ }
+ push @mode_names, $mode;
+ push @var_names, $_;
}
- push @mode_names, $mode;
- push @var_names, $_;
- }
- my $n_res = @print_res;
- my $n_vars = @var_names;
+ my $n_res = @print_res;
+ my $n_vars = @var_names;
- if ( $n_vars < $n_res ) {
- print STDERR 'gperl: not enough variables for Perl part: ' .
- $n_vars . ' variables for ' . $n_res . ' output lines.';
- } elsif ( $n_vars > $n_res ) {
- print STDERR 'gperl: too many variablenames for Perl part: ' .
- $n_vars . ' variables for ' . $n_res . ' output lines.';
- }
- if ( $n_vars < $n_res ) {
- print STDERR 'gperl: not enough variables for Perl part: ' .
- $n_vars . ' variables for ' . $n_res . ' output lines.';
- }
+ if ( $n_vars < $n_res ) {
+ print STDERR 'gperl: not enough variables for Perl part: ' .
+ $n_vars . ' variables for ' . $n_res . ' output lines.';
+ } elsif ( $n_vars > $n_res ) {
+ print STDERR 'gperl: too many variablenames for Perl part: ' .
+ $n_vars . ' variables for ' . $n_res . ' output lines.';
+ }
+ if ( $n_vars < $n_res ) {
+ print STDERR 'gperl: not enough variables for Perl part: ' .
+ $n_vars . ' variables for ' . $n_res . ' output lines.';
+ }
- my $n_min = $n_res;
- $n_min = $n_vars if ( $n_vars < $n_res );
- exit unless ( $n_min );
- $n_min -= 1; # for starting with 0
+ my $n_min = $n_res;
+ $n_min = $n_vars if ( $n_vars < $n_res );
+ exit unless ( $n_min );
+ $n_min -= 1; # for starting with 0
- for my $i ( 0..$n_min ) {
- my $value = $print_res[$i];
- chomp $value;
- print $mode_names[$i] . ' ' . $var_names[$i] . ' ' . $value;
+ for my $i ( 0..$n_min ) {
+ my $value = $print_res[$i];
+ chomp $value;
+ print $mode_names[$i] . ' ' . $var_names[$i] . ' ' . $value;
+ }
}
}
diff --git a/contrib/gpinyin/gpinyin.pl b/contrib/gpinyin/gpinyin.pl
index e4bb5a31..57414f33 100755
--- a/contrib/gpinyin/gpinyin.pl
+++ b/contrib/gpinyin/gpinyin.pl
@@ -126,53 +126,63 @@ my @output_t = # troff
'.el \\{\\',
);
-foreach (<>) { # get line from input
- chomp;
- s/\s+$//; # remove final spaces
-# &err('gpinyin: ' . $_);
-
- my $line = $_; # with starting blanks
-
- # .pinyin start or begin line
- if ( $line =~ /^[.']\s*pinyin\s+(start|begin)$/ ) {
- if ( $pinyin_mode ) {
- # '.pinyin' was started twice, ignore
- &err( q['.pinyin' starter was run several times] );
- } else { # new pinyin start
- $pinyin_mode = 1;
- }
+unshift @ARGV, '-' unless @ARGV;
+foreach my $filename (@ARGV) {
+ my $input;
+ if ($filename eq '-') {
+ $input = \*STDIN;
+ } elsif (not open $input, '<', $filename) {
+ warn $!;
next;
}
+ while (<$input>) {
+ chomp;
+ s/\s+$//; # remove final spaces
+# &err('gpinyin: ' . $_);
+
+ my $line = $_; # with starting blanks
+
+ # .pinyin start or begin line
+ if ( $line =~ /^[.']\s*pinyin\s+(start|begin)$/ ) {
+ if ( $pinyin_mode ) {
+ # '.pinyin' was started twice, ignore
+ &err( q['.pinyin' starter was run several times] );
+ } else { # new pinyin start
+ $pinyin_mode = 1;
+ }
+ next;
+ }
- # .pinyin stop or end line
- if ( $line =~ /^[.']\s*pinyin\s+(stop|end)$/ ) {
- if ( $pinyin_mode ) { # normal stop
- $pinyin_mode = 0;
- &finish_pinyin_mode( address@hidden, address@hidden );
- } else { # ignore
- &err( 'gpinyin: there was a .pinyin stop without ' .
- 'being in pinyin mode' );
+ # .pinyin stop or end line
+ if ( $line =~ /^[.']\s*pinyin\s+(stop|end)$/ ) {
+ if ( $pinyin_mode ) { # normal stop
+ $pinyin_mode = 0;
+ &finish_pinyin_mode( address@hidden, address@hidden );
+ } else { # ignore
+ &err( 'gpinyin: there was a .pinyin stop without ' .
+ 'being in pinyin mode' );
+ }
+ next;
}
- next;
- }
- # now not a .pinyin line
+ # now not a .pinyin line
- if ( $pinyin_mode ) { # within Pinyin
- my $starting_blanks = '';
- $starting_blanks = $1 if ( s/^(s+)// ); # handle starting spaces
+ if ( $pinyin_mode ) { # within Pinyin
+ my $starting_blanks = '';
+ $starting_blanks = $1 if ( s/^(s+)// ); # handle starting spaces
- my %outline = &handle_line($starting_blanks, $line);
-#&err('gpinyin outline n: ' . $outline{'n'} );
-#&err('gpinyin outline t: ' . $outline{'t'} );
- push @output_n, $outline{'n'};
- push @output_t, $outline{'t'};
- } else { # normal roff line, not within Pinyin
- print $line;
- }
- next;
-} # end of input line
+ my %outline = &handle_line($starting_blanks, $line);
+# &err('gpinyin outline n: ' . $outline{'n'} );
+# &err('gpinyin outline t: ' . $outline{'t'} );
+ push @output_n, $outline{'n'};
+ push @output_t, $outline{'t'};
+ } else { # normal roff line, not within Pinyin
+ print $line;
+ }
+ next;
+ } # end of input line
+}
########################################################################
diff --git a/src/devices/gropdf/gropdf.pl b/src/devices/gropdf/gropdf.pl
index 2ec52d06..b08c4b18 100644
--- a/src/devices/gropdf/gropdf.pl
+++ b/src/devices/gropdf/gropdf.pl
@@ -61,6 +61,7 @@ my @obj; # Array of PDF objects
my $objct=0; # Count of Objects
my $fct=0; # Output count
my %fnt; # Used fonts
+our $input; # Current input filehandle
my $lct=0; # Input Line Count
my $src_name='';
my %env; # Current environment
@@ -288,56 +289,64 @@ my %info=('Creator' => "(groff version
$cfg{GROFF_VERSION})",
'ModDate' => "($dt)",
'CreationDate' => "($dt)");
-while (<>)
-{
- chomp;
- s/\r$//;
- $lct++;
+unshift @ARGV, '-' unless @ARGV;
+foreach my $filename (@ARGV) {
+ local $input;
+ if ($filename eq '-') {
+ $input = \*STDIN;
+ } elsif (not open $input, '<', $filename) {
+ warn $!;
+ next;
+ }
+ while (<$input>) {
+ chomp;
+ s/\r$//;
+ $lct++;
- do # The ahead buffer behaves like 'ungetc'
- {{
- if (scalar(@ahead))
- {
- $_=shift(@ahead);
- }
+ do # The ahead buffer behaves like 'ungetc'
+ {{
+ if (scalar(@ahead))
+ {
+ $_=shift(@ahead);
+ }
- my $cmd=substr($_,0,1);
- next if $cmd eq '#'; # just a comment
- my $lin=substr($_,1);
+ my $cmd=substr($_,0,1);
+ next if $cmd eq '#'; # just a comment
+ my $lin=substr($_,1);
- while ($cmd eq 'w')
- {
- $cmd=substr($lin,0,1);
- $lin=substr($lin,1);
- $w_flg=1 if $gotT;
- }
+ while ($cmd eq 'w')
+ {
+ $cmd=substr($lin,0,1);
+ $lin=substr($lin,1);
+ $w_flg=1 if $gotT;
+ }
- $lin=~s/^\s+//;
+ $lin=~s/^\s+//;
# $lin=~s/\s#.*?$//; # remove comment
- $stream.="\% $_\n" if $debug;
-
- do_x($lin),next if ($cmd eq 'x');
- next if $suppress;
- do_p($lin),next if ($cmd eq 'p');
- do_f($lin),next if ($cmd eq 'f');
- do_s($lin),next if ($cmd eq 's');
- do_m($lin),next if ($cmd eq 'm');
- do_D($lin),next if ($cmd eq 'D');
- do_V($lin),next if ($cmd eq 'V');
- do_v($lin),next if ($cmd eq 'v');
- do_t($lin),next if ($cmd eq 't');
- do_u($lin),next if ($cmd eq 'u');
- do_C($lin),next if ($cmd eq 'C');
- do_c($lin),next if ($cmd eq 'c');
- do_N($lin),next if ($cmd eq 'N');
- do_h($lin),next if ($cmd eq 'h');
- do_H($lin),next if ($cmd eq 'H');
- do_n($lin),next if ($cmd eq 'n');
-
- my $tmp=scalar(@ahead);
- }} until scalar(@ahead) == 0;
-
+ $stream.="\% $_\n" if $debug;
+
+ do_x($lin),next if ($cmd eq 'x');
+ next if $suppress;
+ do_p($lin),next if ($cmd eq 'p');
+ do_f($lin),next if ($cmd eq 'f');
+ do_s($lin),next if ($cmd eq 's');
+ do_m($lin),next if ($cmd eq 'm');
+ do_D($lin),next if ($cmd eq 'D');
+ do_V($lin),next if ($cmd eq 'V');
+ do_v($lin),next if ($cmd eq 'v');
+ do_t($lin),next if ($cmd eq 't');
+ do_u($lin),next if ($cmd eq 'u');
+ do_C($lin),next if ($cmd eq 'C');
+ do_c($lin),next if ($cmd eq 'c');
+ do_N($lin),next if ($cmd eq 'N');
+ do_h($lin),next if ($cmd eq 'h');
+ do_H($lin),next if ($cmd eq 'H');
+ do_n($lin),next if ($cmd eq 'n');
+
+ my $tmp=scalar(@ahead);
+ }} until scalar(@ahead) == 0;
+ }
}
exit 0 if $lct==0;
@@ -3248,7 +3257,7 @@ sub LoadAhead
foreach my $j (1..$no)
{
- my $lin=<>;
+ my $lin=<$input>;
chomp($lin);
$lin=~s/\r$//;
$lct++;
diff --git a/tmac/hyphenex.pl b/tmac/hyphenex.pl
index fba3e8d6..aee5845b 100644
--- a/tmac/hyphenex.pl
+++ b/tmac/hyphenex.pl
@@ -31,47 +31,57 @@ print "% for corrections and omissions.\n";
print "\n";
print "\\hyphenation{\n";
-while (<>) {
- # retain only lines starting with \1 ... \6 or \tabalign
- next if not (m/^\\[123456]/ || m/^\\tabalign/);
- # remove final newline
- chop;
- # remove all TeX commands except \1 ... \6
- s/\\[^123456\s{]+//g;
- # remove all paired { ... }
- 1 while s/{(.*?)}/\1/g;
- # skip lines which now have only whitespace before '&'
- next if m/^\s*&/;
- # remove comments
- s/%.*//;
- # remove trailing whitespace
- s/\s*$//;
- # remove trailing '*' (used as a marker in the document)
- s/\*$//;
- # split at whitespace
- @field = split(' ');
- if ($field[0] eq "\\1" || $field[0] eq "\\4") {
- print " $field[2]\n";
+unshift @ARGV, '-' unless @ARGV;
+foreach my $filename (@ARGV) {
+ my $input;
+ if ($filename eq '-') {
+ $input = \*STDIN;
+ } elsif (not open $input, '<', $filename) {
+ warn $!;
+ next;
}
- elsif ($field[0] eq "\\2" || $field[0] eq "\\5") {
- print " $field[2]\n";
- # handle multiple suffixes separated by commata
- @suffix_list = split(/,/, "$field[3]");
- foreach $suffix (@suffix_list) {
- print " $field[2]$suffix\n";
+ while (<$input>) {
+ # retain only lines starting with \1 ... \6 or \tabalign
+ next if not (m/^\\[123456]/ || m/^\\tabalign/);
+ # remove final newline
+ chop;
+ # remove all TeX commands except \1 ... \6
+ s/\\[^123456\s{]+//g;
+ # remove all paired { ... }
+ 1 while s/{(.*?)}/\1/g;
+ # skip lines which now have only whitespace before '&'
+ next if m/^\s*&/;
+ # remove comments
+ s/%.*//;
+ # remove trailing whitespace
+ s/\s*$//;
+ # remove trailing '*' (used as a marker in the document)
+ s/\*$//;
+ # split at whitespace
+ @field = split(' ');
+ if ($field[0] eq "\\1" || $field[0] eq "\\4") {
+ print " $field[2]\n";
}
- }
- elsif ($field[0] eq "\\3" || $field[0] eq "\\6") {
- # handle multiple suffixes separated by commata
- @suffix_list = split(/,/, "$field[3],$field[4]");
- foreach $suffix (@suffix_list) {
- print " $field[2]$suffix\n";
+ elsif ($field[0] eq "\\2" || $field[0] eq "\\5") {
+ print " $field[2]\n";
+ # handle multiple suffixes separated by commata
+ @suffix_list = split(/,/, "$field[3]");
+ foreach $suffix (@suffix_list) {
+ print " $field[2]$suffix\n";
+ }
+ }
+ elsif ($field[0] eq "\\3" || $field[0] eq "\\6") {
+ # handle multiple suffixes separated by commata
+ @suffix_list = split(/,/, "$field[3],$field[4]");
+ foreach $suffix (@suffix_list) {
+ print " $field[2]$suffix\n";
+ }
+ }
+ else {
+ # for '&', split at '&' with trailing whitespace
+ @field = split(/&\s*/);
+ print " $field[1]\n";
}
- }
- else {
- # for '&', split at '&' with trailing whitespace
- @field = split(/&\s*/);
- print " $field[1]\n";
}
}
--
2.20.1