doc/lispref/tindex.pl

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