gnu/dist/groff/contrib/mm/mmroff.pl

   1 #! /usr/bin/perl
   2
   3 use strict;
   4 # runs groff in safe mode, that seems to be the default
   5 # installation now. That means that I have to fix all nice
   6 # features outside groff. Sigh.
   7 # I do agree however that the previous way opened a whole bunch
   8 # of security holes.
   9
  10 my $no_exec;
  11 # check for -x and remove it
  12 if (grep(/^-x$/, @ARGV)) {
  13         $no_exec++;
  14         @ARGV = grep(!/^-x$/, @ARGV);
  15 }
  16
  17 # mmroff should always have -mm, but not twice
  18 @ARGV = grep(!/^-mm$/, @ARGV);
  19 my $check_macro = "groff -rRef=1 -z -mm @ARGV";
  20 my $run_macro = "groff -mm @ARGV";
  21
  22 my (%cur, $rfilename, $max_height, $imacro, $max_width, @out, @indi);
  23 open(MACRO, "$check_macro 2>&1 |") || die "run $check_macro:$!";
  24 while(<MACRO>) {
  25         if (m#^\.\\" Rfilename: (\S+)#) {
  26                 # remove all directories just to be more secure
  27                 ($rfilename = $1) =~ s#.*/##;
  28                 next;
  29         }
  30         if (m#^\.\\" Imacro: (\S+)#) {
  31                 # remove all directories just to be more secure
  32                 ($imacro = $1) =~ s#.*/##;
  33                 next;
  34         }
  35         if (m#^\.\\" Index: (\S+)#) {
  36                 # remove all directories just to be more secure
  37                 my $f;
  38                 ($f = $1) =~ s#.*/##;
  39                 &print_index($f, \@indi, $imacro);
  40                 @indi = ();
  41                 $imacro = '';
  42                 next;
  43         }
  44         my $x;
  45         if (($x) = m#^\.\\" IND (.+)#) {
  46                 $x =~ s#\\##g;
  47                 my @x = split(/\t/, $x);
  48                 grep(s/\s+$//, @x);
  49                 push(@indi, join("\t", @x));
  50                 next;
  51         }
  52         if (m#^\.\\" PIC id (\d+)#) {
  53                 %cur = ('id', $1);
  54                 next;
  55         }
  56         if (m#^\.\\" PIC file (\S+)#) {
  57                 &psbb($1);
  58                 &ps_calc($1);
  59                 next;
  60         }
  61         if (m#^\.\\" PIC (\w+)\s+(\S+)#) {
  62                 eval "\$cur{'$1'} = '$2'";
  63                 next;
  64         }
  65         s#\\ \\ $##;
  66         push(@out, $_);
  67 }
  68 close(MACRO);
  69
  70
  71 if ($rfilename) {
  72         push(@out, ".nr pict*max-height $max_height\n") if defined $max_height;
  73         push(@out, ".nr pict*max-width $max_width\n") if defined $max_width;
  74
  75         open(OUT, ">$rfilename") || "create $rfilename:$!";
  76         print OUT '.\" references', "\n";
  77         my $i;
  78         for $i (@out) {
  79                 print OUT $i;
  80         }
  81         close(OUT);
  82 }
  83
  84 exit 0 if $no_exec;
  85 exit system($run_macro);
  86
  87 sub print_index {
  88         my ($f, $ind, $macro) = @_;
  89
  90         open(OUT, ">$f") || "create $f:$!";
  91         my $i;
  92         for $i (sort @$ind) {
  93                 if ($macro) {
  94                         $i = '.'.$macro.' "'.join('" "', split(/\t/, $i)).'"';
  95                 }
  96                 print OUT "$i\n";
  97         }
  98         close(OUT);
  99 }
 100
 101 sub ps_calc {
 102         my ($f) = @_;
 103
 104         my $w = abs($cur{'llx'}-$cur{'urx'});
 105         my $h = abs($cur{'lly'}-$cur{'ury'});
 106         $max_width = $w if $w > $max_width;
 107         $max_height = $h if $h > $max_height;
 108
 109         my $id = $cur{'id'};
 110         push(@out, ".ds pict*file!$id $f\n");
 111         push(@out, ".ds pict*id!$f $id\n");
 112         push(@out, ".nr pict*llx!$id $cur{'llx'}\n");
 113         push(@out, ".nr pict*lly!$id $cur{'lly'}\n");
 114         push(@out, ".nr pict*urx!$id $cur{'urx'}\n");
 115         push(@out, ".nr pict*ury!$id $cur{'ury'}\n");
 116         push(@out, ".nr pict*w!$id $w\n");
 117         push(@out, ".nr pict*h!$id $h\n");
 118 }
 119
 120
 121 sub psbb {
 122         my ($f) = @_;
 123
 124         unless (open(IN, $f)) {
 125                 print STDERR "Warning: Postscript file $f:$!";
 126                 next;
 127         }
 128         while(<IN>) {
 129                 if (/^%%BoundingBox:\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/) {
 130                         $cur{'llx'} = $1;
 131                         $cur{'lly'} = $2;
 132                         $cur{'urx'} = $3;
 133                         $cur{'ury'} = $4;
 134                 }
 135         }
 136         close(IN);
 137 }