git.pond.sub.org Git - empserver/blob - info/subj2html.pl

   1 #!/usr/local/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my $dome = 0;
   7 my $esc="\\";
   8 my @a;
   9
  10 print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"\n";
  11 print "   \"http://www.w3.org/TR/html4/strict.dtd\">\n";
  12 print "<html>\n";
  13 print "<head>\n";
  14
  15 line: while (<>) {
  16     chomp;                      # strip record separator
  17     s/([^\\](\\\\)*)\\\".*/$1/g; # strip comments
  18
  19     @a = req($_);
  20     if (!@a) {
  21         if ($dome) {
  22             while ($_ =~ /[A-Za-z0-9\-\.]+/g) {
  23                 print htmlify("$`");
  24                 print anchor("$&");
  25                 $_="$'";
  26             }
  27         }
  28         print htmlify($_), "\n";
  29         next line;
  30     }
  31
  32     # requests
  33
  34     if ($a[1] eq "TH") {
  35         @a = checkarg(2, @a);
  36         $a[3] = htmlify($a[3]);
  37         print "<title>$a[2] : $a[3]</title>\n";
  38         print "</head>\n";
  39         print "<body>\n";
  40         print "<h1>$a[2] : $a[3]</h1>\n";
  41         print "<p>\n";
  42         next line;
  43     }
  44
  45     if ($a[1] eq "SY") {
  46         @a = checkarg(1, @a);
  47         $a[2] = htmlify($a[2]);
  48         print "<samp>[##:##] Command : </samp><KBD>$a[2]</KBD><p>\n";
  49         next line;
  50     }
  51
  52     if ($a[1] eq "EX") {
  53         my $str = htmlify(join(' ',@a[2..$#a]));
  54         print "<br><samp>[##:##] Command : </samp><kbd>$str</kbd><p>\n";
  55         next line;
  56     }
  57
  58     if ($a[1] eq "L") {
  59         $a[2] =~ / /;
  60         print "<br>" . anchor("$`") . " $'\n";
  61         next line;
  62     }
  63
  64     if ($a[1] eq "eo") { $esc = 0; next line; }
  65     if ($a[1] eq "ec") { $esc = $#a == 1 ? "\\" : $a[2]; next line; }
  66
  67     if ($a[1] =~ /NF|nf/i) { $dome = 1; printf (("<p><pre>\n")); next line; }
  68     if ($a[1] =~ /FI|fi/i) { $dome = 0; printf (("</pre><p>\n")); next line; }
  69     if ($a[1] eq "s1") { printf (("<hr><p>\n")); next line; }
  70     if ($a[1] eq "br") { printf "<br>\n"; next line; }
  71
  72     if ($a[1] eq "SA") {
  73         @a = checkarg(1, @a);
  74         @a = split(/[\: \"\,\.]+/, $a[2]);
  75         for my $a (@a) {
  76             $a = anchor($a);
  77         }
  78         print "<p>See also : ", join("\n, ", @a), "\n";
  79     }
  80
  81     # ignore unknown request
  82 }
  83
  84 print "</body>\n";
  85 print "</html>\n";
  86
  87 sub req {
  88     local ($_) = @_;
  89     if (/^([\.\'])[ \t]*([^ ]*) *(.*)/) {
  90         my @a = ($1, $2);
  91         $_ = $3;
  92         while (/\G(\"((\\.|[^\\\"])*)(\"|\Z))|\G(([^ ]|\\.)+) */g) {
  93             push(@a, $2 || $5);
  94         }
  95         return @a;
  96     }
  97     return ();
  98 }
  99
 100 sub checkarg {
 101     my ($n, @a) = @_;
 102     warn "extra arguments for $a[1] ignored" if $#a > $n+1;
 103     warn "missing arguments for $a[1] supplied" if $#a < $n+1;
 104     while ($#a < $n+1) {
 105         push @a, "";
 106     }
 107     return @a;
 108 }
 109
 110 sub anchor {
 111     local ($_) = @_;
 112     # FIXME don't create dangling links here
 113     return "<a href=\"$_.html\">$_</a>";
 114 }
 115
 116 # Translate HTML special characters into escape sequences
 117 sub htmlify {
 118     local ($_) = @_;
 119     die "funny escape character `$esc' not supported"
 120         if $esc && $esc ne "\\";
 121     # translate some troff escapes
 122     s/\\&//g if $esc;           # zero width space character
 123     # escape HTML special characters
 124     s/\&/&amp;/g;
 125     s/\</&lt;/g;
 126     s/\>/&gt;/g;
 127     # delete form feed
 128     s/\f//g;
 129     return $_ unless $esc;
 130     # translate more troff escapes
 131     s/\\e/&\#92;/g;             # escape character
 132     # turn quoted strings that look like info names into links
 133     # tacky...
 134     while (/(\\\*Q)([A-Za-z0-9\-\.]+)(\\\*U)/) {
 135         $_ = $` . anchor($2) . "$'";
 136     }
 137     while (/(\"info )([A-Za-z0-9\-\.]+)/) {
 138         $_ = "$`\"info " . anchor($2) . "$'";
 139     }
 140     # tranlate more troff escapes and strings
 141     s/\\\*Q/<em>/g;
 142     s/\\\*U/<\/em>/g;
 143     s/\\fI/<em>/g;
 144     s/\\fR/<\/em><\/em>/g;
 145     s/\\fB/<strong>/g;
 146     s/\\fP/<\/strong><\/em>/g;
 147     s/\\\*\(bF/<strong>/g;      # bold font
 148     s/\\\*\(pF/<\/strong><\/em>/g; # pica font
 149     s/\\\*\(nF/<\/strong><\/em>/g; # normal font
 150     s/\\\*\(iF/<em>/g;          # italic font
 151     s/\\\(mu/x/g;               # multiply symbol
 152     s/\\ /&nbsp;/g;             # non breaking space
 153     return $_;
 154 }