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

   1 #!/usr/bin/perl
   2 #
   3 #   Empire - A multi-player, client/server Internet based war game.
   4 #   Copyright (C) 1986-2021, Dave Pare, Jeff Bailey, Thomas Ruschak,
   5 #                 Ken Stevens, Steve McClure, Markus Armbruster
   6 #
   7 #   Empire is free software: you can redistribute it and/or modify
   8 #   it under the terms of the GNU General Public License as published by
   9 #   the Free Software Foundation, either version 3 of the License, or
  10 #   (at your option) any later version.
  11 #
  12 #   This program is distributed in the hope that it will be useful,
  13 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 #   GNU General Public License for more details.
  16 #
  17 #   You should have received a copy of the GNU General Public License
  18 #   along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19 #
  20 #   ---
  21 #
  22 #   See files README, COPYING and CREDITS in the root of the source
  23 #   tree for related information and legal notices.  It is expected
  24 #   that future projects/authors will amend these files as needed.
  25 #
  26 #   ---
  27 #
  28 #   mksubj.pl: Update the subject index pages
  29 #
  30 #   Known contributors to this file:
  31 #      Ken Stevens (when it was still info.pl)
  32 #      Markus Armbruster, 2006-2016
  33 #
  34 # Usage: mksubj.pl SUBJECT... INFO-FILE...
  35 #
  36 # Read the INFO-FILE..., update info/SUBJECT.t for each SUBJECT.
  37
  38 use strict;
  39 use warnings;
  40
  41 # The chapters, in order
  42 my @Chapters = qw/Introduction Concept Command Server/;
  43
  44 my @Levels = qw/Basic Expert Obsolete/;
  45
  46 # $Subjects{SUBJECT} is a reference to an anonymous array
  47 # containing SUBJECT's topics
  48 my %Subjects;
  49
  50 # $filename{TOPIC} is TOPIC's file name
  51 my %filename;
  52 # $lines{TOPIC} is the number of lines in $filename{TOPIC}
  53 my %lines;
  54 # $chapter{TOPIC} is TOPIC's chapter (first arg to .TH)
  55 my %chapter;
  56 # $desc{TOPIC} is a one line description of TOPIC (second arg to .NA)
  57 my %desc;
  58 # $level{TOPIC} is TOPIC's difficulty level (arg to .LV)
  59 my %level;
  60
  61 # current info file
  62 my $filename;
  63
  64 while ($#ARGV >= 0 && $ARGV[0] !~ /\.t$/) {
  65     $Subjects{shift @ARGV} = [];
  66 }
  67
  68 for (@ARGV) {
  69     $filename{fn2topic($_)} = $_;
  70 }
  71
  72 for (@ARGV) {
  73     parse_file($_);
  74 }
  75
  76 for (keys %Subjects) {
  77     update_subj($_);
  78 }
  79
  80 write_toc();
  81
  82 sub fn2topic {
  83     my ($fn) = @_;
  84     $fn =~ s,.*/([^/]*)\.t$,$1,;
  85     return $fn;
  86 }
  87
  88 # Parse an info file
  89 # Set $filename, $lines{TOPIC}, $chapter{TOPIC}, $desc{TOPIC},
  90 # $level{TOPIC}.
  91 # Update %Subjects.
  92 sub parse_file {
  93     ($filename) = @_;
  94     my $topic = fn2topic($filename);
  95
  96     open(F, "<$filename")
  97         or die "Can't open $filename: $!";
  98
  99     $_ = <F>;
 100     if (/^\.TH (\S+) (\S.+\S)$/) {
 101         if (!grep(/^$1$/, @Chapters)) {
 102             error("First argument to .TH was '$1', which is not a known chapter");
 103         }
 104         $chapter{$topic} = $1;
 105         if ($1 eq "Command" && $2 ne "\U$topic") {
 106             error("Second argument to .TH was '$2' but it should be '\U$topic'");
 107         }
 108     } else {
 109         error("The first line in the file must be a .TH request");
 110     }
 111
 112     $_ = <F>;
 113     if (/^\.NA (\S+) "(\S.+\S)"$/) {
 114         if ($topic ne $1) {
 115             error("First argument to .NA was '$1' but it should be '$topic'");
 116         }
 117         $desc{$topic} = $2;
 118     } else {
 119         error("The second line in the file must be a .NA request");
 120     }
 121
 122     $_ = <F>;
 123     if (/^\.LV (\S+)$/) {
 124         if (!grep(/^$1$/, @Levels)) {
 125             error("The argument to .LV was '$1', which is not a known level");
 126         }
 127         $level{$topic} = $1;
 128     } else {
 129         error("The third line in the file must be a .LV request");
 130     }
 131
 132     while (<F>) {
 133         last if /^\.SA/;
 134     }
 135
 136     if ($_) {
 137         if (/^\.SA "([^\"]*)"/) {
 138             parse_see_also($topic, $1);
 139         } else {
 140             error("Incorrect .SA argument, expecting '.SA \"item1, item2\"'");
 141         }
 142     } else {
 143         error(".SA request is missing");
 144     }
 145
 146     if (<F>) {
 147         error(".SA request must be the last line");
 148     }
 149
 150     $lines{$topic} = $.;
 151     close F;
 152 }
 153
 154 sub parse_see_also {
 155     my ($topic, $sa) = @_;
 156     my $wanted = $chapter{$topic};
 157     my $found;                 # found a subject?
 158
 159     $wanted = undef if $wanted eq 'Concept' or $wanted eq 'Command';
 160
 161     for (split(/, /, $sa)) {
 162         next if exists $filename{$_};
 163         error("Unknown topic $_ in .SA") unless exists $Subjects{$_};
 164         push @{$Subjects{$_}}, $topic;
 165         $found = 1;
 166         if ($wanted && $_ eq $wanted) {
 167             $wanted = undef;
 168         }
 169     }
 170
 171     error("No subject listed in .SA") unless $found;
 172     error("Chapter $wanted not listed in .SA") if $wanted;
 173 }
 174
 175 # Update a Subject.t file
 176 sub update_subj {
 177     my ($subj) = @_;
 178     my $fname = "info/$subj.t";
 179     my @topics = @{$Subjects{$subj}};
 180     my $out = "";
 181     my ($any_topic, $any_basic, $any_obsolete, $any_long);
 182
 183     my $largest = "";
 184     for my $topic (@topics) {
 185         $largest = $topic if length $topic > length $largest;
 186     }
 187
 188     $out .= '.\" DO NOT EDIT THIS FILE.  It was automatically generated by mksubj.pl'."\n";
 189     $out .= ".TH Subject \U$subj\n";
 190     $largest =~ s/-/M/g;
 191     $out .= ".in \\w'$largest" . "XX\\0\\0\\0\\0'u\n";
 192
 193     for my $chap (@Chapters) {
 194         my $empty = 1;
 195         for my $topic (@topics) {
 196             $any_topic = 1;
 197             next if $chapter{$topic} ne $chap;
 198             $out .= ".s1\n" if $empty;
 199             $empty = 0;
 200             my $flags = "";
 201             if ($level{$topic} eq 'Basic') {
 202                 $flags .= "*";
 203                 $any_basic = 1;
 204             }
 205             if ($level{$topic} eq 'Obsolete') {
 206                 $flags .= "+";
 207                 $any_obsolete = 1;
 208             }
 209             if ($lines{$topic} > 300) {
 210                 # TODO use formatted line count
 211                 $flags .= "!";
 212                 $any_long = 1;
 213             }
 214             $flags = sprintf("%-2s", $flags);
 215             $out .= ".L \"$topic $flags\"\n";
 216             $out .= "$desc{$topic}\n";
 217         }
 218     }
 219     unless ($any_topic) {
 220         print STDERR "$0: Subject $subj has no topics\n";
 221         exit 1;
 222     }
 223     $out .= ".s1\n"
 224         . ".in 0\n"
 225         . "For info on a particular topic, type \"info <topic>\" where <topic> is\n"
 226         . "one of the topics listed above.\n";
 227     $out .= "Topics marked by * are the most important and should be read by new players.\n"
 228         if $any_basic;
 229     $out .= "Topics marked by + are obsolete.\n"
 230         if $any_obsolete;
 231     $out .= "Topics with unusually long info are marked with a !.\n"
 232         if $any_long;
 233
 234     return if (same_contents($fname, $out));
 235     open(SUBJ, ">$fname")
 236         or die "Can't open $fname for writing: $!";
 237     print SUBJ $out;
 238     close SUBJ;
 239 }
 240
 241 sub same_contents {
 242     my ($fname, $contents) = @_;
 243     local $/;
 244
 245     if (!open(SUBJ, "<$fname")) {
 246         return 0 if ($!{ENOENT});
 247         die "Can't open $fname for reading: $!";
 248     }
 249     my $old = <SUBJ>;
 250     close SUBJ;
 251     return $contents eq $old;
 252 }
 253
 254 sub write_toc {
 255     my @toc;
 256     for (keys %chapter) {
 257         push @toc, "$chapter{$_} $_";
 258     }
 259     open(TOC, ">info/toc")
 260         or die "Can't open info/toc for writing: $!";
 261     print TOC join("\n", sort @toc);
 262     print TOC "\n";
 263     close TOC;
 264 }
 265
 266 # Print an integrity error message and exit with code 1
 267 sub error {
 268     my ($error) = @_;
 269
 270     print STDERR "mksubj.pl:$filename:$.: $error\n";
 271     exit 1;
 272 }