doc/lispref/tindex.pl

   1 #! /usr/bin/perl
   2
   3 # Copyright (C) 2000-2012  Free Software Foundation, Inc.
   4
   5 # This file is part of GNU Emacs.
   6
   7 # GNU Emacs 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 # GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 require 5;
  22 use Getopt::Long;
  23
  24 my $USAGE = <<ENDUSAGE;
  25 Remove \@tindex lines from files that were already present in previous
  26 versions.
  27
  28 Usage: $0 [--old=EXT] FILE...
  29        $0 --help
  30        $0 --version
  31
  32   --help        display this help and exit
  33   --version     print version and exit
  34   --old=DIR     find old files in DIR
  35
  36 The script performs two passes.  In the first pass, Texinfo files from
  37 DIR are scanned for \@tindex lines, and identifiers in them are
  38 recorded.  In a second pass, Texinfo files in the current directory
  39 are scanned, and \@tindex lines for identifiers that were recorded in
  40 the first pass are removed.  Old file contents are saved in files
  41 with extension ".orig".  A list of modified files and removed \@tindex
  42 identifiers is printed to stdout at the end.
  43 ENDUSAGE
  44
  45 sub fatal {
  46     print STDERR "$0: ", @_, ".\n";
  47     exit 1;
  48 }
  49
  50 my $help = 0;
  51 my $version = 0;
  52 my $old;
  53
  54 my $rc = GetOptions ('help' => \$help, 'version' => \$version,
  55                      'old=s' => \$old);
  56 if ($version) {
  57     print "0.1\n";
  58     exit 0;
  59 } elsif (!$rc || !$old || @ARGV) {
  60     print $USAGE;
  61     exit 1;
  62 } elsif ($help) {
  63     print $USAGE;
  64     exit 0;
  65 }
  66
  67 # Fill the hash %tindex with associations VAR -> COUNT where
  68 # the keys VAR are identifiers mentioned in @tindex lines in the older
  69 # files to process and COUNT is the number of times they are seen in
  70 # the files.
  71
  72 my %tindex;
  73 my %removed;
  74 my @old_files = glob "$old/*.texi";
  75 my @new_files = glob "*.texi";
  76 fatal ("No Texinfo files found in `$old'") unless @old_files;
  77 fatal ("No Texinfo files found in current directory") unless @new_files;
  78
  79 print "Scanning old files for \@tindex lines\n";
  80 foreach $file (@old_files) {
  81     open (IN, "<$file") or fatal "Cannot open $file: $!";
  82     while (<IN>) {
  83         ++$tindex{$1} if /^\s*\@tindex\s+(\S+)/;
  84     }
  85     close IN;
  86 }
  87
  88 # Process current files and remove those @tindex lines which we
  89 # know were already present in the files scanned above.
  90
  91 print "Removing old \@tindex lines\n";
  92 foreach $file (@new_files) {
  93     my $modified = 0;
  94     my $contents = "";
  95
  96     open (IN, "< $file") or fatal "Cannot open $file.orig for reading: $!";
  97     while (<IN>) {
  98         if (/^\s*\@tindex\s+(\S+)/ && $tindex{$1}) {
  99             ++$removed{$1};
 100             $modified = 1;
 101         } else {
 102             $contents = $contents . $_;
 103         }
 104     }
 105
 106     close IN;
 107
 108     if ($modified) {
 109         print "  $file\n";
 110         system ("cp $file $file.orig") == 0 or fatal "Cannot backup $file: $!";
 111         open (OUT, ">$file") or fatal "Cannot open $file for writing: $!";
 112         print OUT $contents;
 113         close OUT;
 114     }
 115 }
 116
 117 # Print a list of identifiers removed.
 118
 119 print "Removed \@tindex commands for:\n";
 120 my $key;
 121 foreach $key (keys %removed) {
 122     print "  $key\n";
 123 }
 124