[groff] 03/04: Avoid Perl's unsafe "<>" operator.

[G. Branden Robinson]

gbranden pushed a commit to branch master
in repository groff.

commit 27472b5ae548d3dbe933713d488d676708996253
Author: Colin Watson <cjwatson@debian.org>
AuthorDate: Thu Jan 24 13:39:06 2019 +0000

    Avoid Perl's unsafe "<>" operator.
    
    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 variation: glilypond doesn't need the initial unshift since
    that's already handled in contrib/glilypond/args.pl.
    
    Fixes: https://bugs.debian.org/920269
    
    [Commit automerged but altered by GBR to omit changes to gropdf, already
    handled by Deri James in 2fc912f0751320a1fba0094dded38e2df46d1dbe.]
---
 contrib/glilypond/glilypond.pl | 128 +++++++++++++++-------------
 contrib/gperl/gperl.pl         | 188 ++++++++++++++++++++++-------------------
 contrib/gpinyin/gpinyin.pl     |  88 ++++++++++---------
 tmac/hyphenex.pl               |  86 ++++++++++---------
 4 files changed, 264 insertions(+), 226 deletions(-)

diff --git a/contrib/glilypond/glilypond.pl b/contrib/glilypond/glilypond.pl
index b0f8db4..1cde0be 100755
--- a/contrib/glilypond/glilypond.pl
+++ b/contrib/glilypond/glilypond.pl
@@ -560,73 +560,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 adfb503..67b3ef4 100755
--- a/contrib/gperl/gperl.pl
+++ b/contrib/gperl/gperl.pl
@@ -129,114 +129,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 ed7d6bb..1b9680c 100755
--- a/contrib/gpinyin/gpinyin.pl
+++ b/contrib/gpinyin/gpinyin.pl
@@ -123,53 +123,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( \@output_n, \@output_t );
-    } 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( \@output_n, \@output_t );
+      } 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/tmac/hyphenex.pl b/tmac/hyphenex.pl
index fba3e8d..aee5845 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";
   }
 }