/contrib/groff/src/roff/grog/grog.pl
https://bitbucket.org/freebsd/freebsd-head/ · Perl · 222 lines · 192 code · 17 blank · 13 comment · 52 complexity · 5db626462fa72bc4ea2de28b2a63b26e MD5 · raw file
- #! /usr/bin/perl
- # grog -- guess options for groff command
- # Inspired by doctype script in Kernighan & Pike, Unix Programming
- # Environment, pp 306-8.
- $prog = $0;
- $prog =~ s@.*/@@;
- $sp = "[\\s\\n]";
- push(@command, "groff");
- while ($ARGV[0] =~ /^-./) {
- $arg = shift(@ARGV);
- $sp = "" if $arg eq "-C";
- &usage(0) if $arg eq "-v" || $arg eq "--version";
- &help() if $arg eq "--help";
- last if $arg eq "--";
- push(@command, $arg);
- }
- @ARGV = ('-') unless @ARGV;
- foreach $arg (@ARGV) {
- &process($arg, 0);
- }
- sub process {
- local($filename, $level) = @_;
- local(*FILE);
- if (!open(FILE, $filename eq "-" ? $filename : "< $filename")) {
- print STDERR "$prog: can't open \`$filename': $!\n";
- exit 1 unless $level;
- return;
- }
- while (<FILE>) {
- if (/^\.TS$sp/) {
- $_ = <FILE>;
- if (!/^\./) {
- $tbl++;
- $soelim++ if $level;
- }
- }
- elsif (/^\.EQ$sp/) {
- $_ = <FILE>;
- if (!/^\./ || /^\.[0-9]/) {
- $eqn++;
- $soelim++ if $level;
- }
- }
- elsif (/^\.GS$sp/) {
- $_ = <FILE>;
- if (!/^\./) {
- $grn++;
- $soelim++ if $level;
- }
- }
- elsif (/^\.G1$sp/) {
- $_ = <FILE>;
- if (!/^\./) {
- $grap++;
- $pic++;
- $soelim++ if $level;
- }
- }
- elsif (/^\.PS$sp([ 0-9.<].*)?$/) {
- if (/^\.PS\s*<\s*(\S+)/) {
- $pic++;
- $soelim++ if $level;
- &process($1, $level);
- }
- else {
- $_ = <FILE>;
- if (!/^\./ || /^\.ps/) {
- $pic++;
- $soelim++ if $level;
- }
- }
- }
- elsif (/^\.R1$sp/) {
- $refer++;
- $soelim++ if $level;
- }
- elsif (/^\.\[/) {
- $refer_open++;
- $soelim++ if $level;
- }
- elsif (/^\.\]/) {
- $refer_close++;
- $soelim++ if $level;
- }
- elsif (/^\.[PLI]P$sp/) {
- $PP++;
- }
- elsif (/^\.P$/) {
- $P++;
- }
- elsif (/^\.(PH|SA)$sp/) {
- $mm++;
- }
- elsif (/^\.TH$sp/) {
- $TH++;
- }
- elsif (/^\.SH$sp/) {
- $SH++;
- }
- elsif (/^\.([pnil]p|sh)$sp/) {
- $me++;
- }
- elsif (/^\.Dd$sp/) {
- $mdoc++;
- }
- elsif (/^\.(Tp|Dp|De|Cx|Cl)$sp/) {
- $mdoc_old = 1;
- }
- # In the old version of -mdoc `Oo' is a toggle, in the new it's
- # closed by `Oc'.
- elsif (/^\.Oo$sp/) {
- $Oo++;
- s/^\.Oo/\. /;
- redo;
- }
- # The test for `Oo' and `Oc' not starting a line (as allowed by the
- # new implementation of -mdoc) is not complete; it assumes that
- # macro arguments are well behaved, i.e., "" is used within "..." to
- # indicate a doublequote as a string element, and weird features
- # like `.foo a"b' are not used.
- elsif (/^\..* Oo( |$)/) {
- s/\\\".*//;
- s/\"[^\"]*\"//g;
- s/\".*//;
- if (s/ Oo( |$)/ /) {
- $Oo++;
- }
- redo;
- }
- elsif (/^\.Oc$sp/) {
- $Oo--;
- s/^\.Oc/\. /;
- redo;
- }
- elsif (/^\..* Oc( |$)/) {
- s/\\\".*//;
- s/\"[^\"]*\"//g;
- s/\".*//;
- if (s/ Oc( |$)/ /) {
- $Oo--;
- }
- redo;
- }
- elsif (/^\.(PRINTSTYLE|START)$sp/) {
- $mom++;
- }
- if (/^\.so$sp/) {
- chop;
- s/^.so *//;
- s/\\\".*//;
- s/ .*$//;
- &process($_, $level + 1) unless /\\/ || $_ eq "";
- }
- }
- close(FILE);
- }
- sub usage {
- local($exit_status) = $_;
- print "GNU grog (groff) version @VERSION@\n";
- exit $exit_status;
- }
- sub help {
- print "usage: grog [ option ...] [files...]\n";
- exit 0;
- }
- $refer ||= $refer_open && $refer_close;
- if ($pic || $tbl || $eqn || $grn || $grap || $refer) {
- $s = "-";
- $s .= "s" if $soelim;
- $s .= "R" if $refer;
- # grap must be run before pic
- $s .= "G" if $grap;
- $s .= "p" if $pic;
- $s .= "g" if $grn;
- $s .= "t" if $tbl;
- $s .= "e" if $eqn;
- push(@command, $s);
- }
- if ($me > 0) {
- push(@command, "-me");
- }
- elsif ($SH > 0 && $TH > 0) {
- push(@command, "-man");
- }
- else ($mom > 0) {
- push(@command, "-mom");
- }
- elsif ($PP > 0) {
- push(@command, "-ms");
- }
- elsif ($P > 0 || $mm > 0) {
- push(@command, "-mm");
- }
- elsif ($mdoc > 0) {
- push(@command, ($mdoc_old || $Oo > 0) ? "-mdoc-old" : "-mdoc");
- }
- push(@command, "--") if @ARGV && $ARGV[0] =~ /^-./;
- push(@command, @ARGV);
- # We could implement an option to execute the command here.
- foreach (@command) {
- next unless /[\$\\\"\';&()|<> \t\n]/;
- s/\'/\'\\\'\'/;
- $_ = "'" . $_ . "'";
- }
- print join(' ', @command), "\n";