#!/usr/bin/env perl
# $Id: txicmdcheck 6132 2015-02-18 00:07:53Z karl $
# Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015
# Free Software Foundation, Inc.
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License,
# or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# Original author: Karl Berry.
#
# Kludge of a script to check command lists in refcard vs. refman vs.
# tp for consistency. 

exit (&main ());

sub main {
  my $no_common = $ARGV[0] eq "--no-common";

  my %card_cmds = &read_refcard ("txirefcard.tex");
  my %idx_cmds = &read_refidx ("../texinfo.texi");
  my %man_cmds = &read_refman ("../texinfo.texi");
  my %tp_cmds = &read_tp ("../../util/txicmdlist");

  # find the commands that are covered everywhere.
  my @found = ();
  for my $cc (keys %card_cmds) {
    if (exists $idx_cmds{$cc}
        && exists $man_cmds{$cc}
        && exists $tp_cmds{$cc}) {
      push (@found, $cc);
      delete $card_cmds{$cc};
      delete $idx_cmds{$cc};
      delete $man_cmds{$cc};
      delete $tp_cmds{$cc};
    }
  }
  
  printf ("    common %d: @{[sort @found]}\n", @found + 0)
    unless $no_common;

  # there are numerous @findex entries which are not @-commands, which
  # can be seen this way:
  #my @idx_only = keys %idx_cmds;
  #printf "findex  only %s: @{[sort @idx_only]}\n", @idx_only + 0;
  #
  # let's not report those, but we do want to report normal commands that
  # did not have findex entries: those which are present in all the
  # other lists.
  my @idx_missing = ();
  for my $cc (sort keys %card_cmds) {
    if (exists $man_cmds{$cc} && exists $tp_cmds{$cc}) {
      push (@idx_missing, $cc);
      delete $card_cmds{$cc};
      delete $man_cmds{$cc};
      delete $tp_cmds{$cc};
    }
  }
  printf "findex missing %s: @idx_missing\n", @idx_missing + 0
    if @idx_missing;

  # now report on commands only in some other subset.
  my @card_only = keys %card_cmds;
  printf "refcard only %s: @{[sort @card_only]}\n", @card_only + 0;

  my @man_only = keys %man_cmds;
  printf "refman  only %s: @{[sort @man_only]}\n", @man_only + 0;
  
  my @tp_only = keys %tp_cmds;
  printf "tp      only %s: @{[sort @tp_only]}\n", @tp_only + 0;
  
  return @card_only + @man_only + @tp_only;
}


# Return command names from the reference card as the keys of a hash
# (with empty values).  In principle it's a list, but as a practical
# matter we want to work with a hash anyway, so we might as well return
# it that way in the first place.  (Ditto for the other functions.)
# 
sub read_refcard {
  my ($fname) = @_;
  my @ret = ();

  local *FILE;
  $FILE = $fname;
  open (FILE) || die "open($FILE) failed: $!";
  while (<FILE>) {
    next unless /^\\txicmd/;
    chomp;
    my $xcmd = 0;
    s/\\txicmdarg{.*?}}?//; # first get rid of the arguments
    s/}{.*//;               # then the descriptions
    s/^\\txicmdx{// && ($xcmd = 1);  # used for the @def...x
    s/^\\txicmd{//;         # finally the markup cmd itself
    s/\\ttbraced{}//g;      # quote cmd list
    
    my (@cmds) = split (/,? +/, $_);  # occasionally we combine cmds
    
    # we typeset these specially in TeX.
    if ("@cmds" eq "@#1footing") {
      @cmds = ('@oddfooting', '@evenfooting', '@everyfooting');
    } elsif ("@cmds" eq "@#1heading") {
      @cmds = ('@oddheading', '@evenheading', '@everyheading');
    }
    
    # add each command from this line to the return.
    for my $c (@cmds) {
#warn "refcard $c\n";
#warn "refcard $c{x}\n" if $xcmd;
      next if $c eq "txicommandconditionals"; # variable not separate in manual
      if ($c eq '@\tildechar') { # TeX specialties, forcibly make them match
        $c = '@~';
      } elsif ($c eq '@\var{whitespace}') {
        $c = '@var{whitespace}';
      }
      $c = '@~' if $c eq '@\tildechar';  # TeX
      $c = '@\\' if $c eq '@\bschar';  # TeX
      $c = '@{' if $c eq '@\lbracechar';  # TeX
      $c = '@}' if $c eq '@\rbracechar';  # TeX
      push (@ret, $c);
      push (@ret, "${c}x") if $xcmd;
    }
  }
  push (@ret, '@end', '@uref', '@appendixsection');  # described in text
  push (@ret, '@,');  # our non-parsing above lost these
  push (@ret, qw(@atchar @lbracechar @rbracechar @backslashchar));
  close (FILE) || warn "close($FILE) failed: $!";
  
  my %ret; @ret{@ret} = ();
  return %ret;
}


# Return command names from @findex entries in the reference manual as
# the keys of a hash (empty values).
# 
sub read_refidx {
  my ($fname) = @_;
  my @ret = ();

  local *FILE;
  $FILE = $fname;
  open (FILE) || die "open($FILE) failed: $!";
  while (<FILE>) {
    next unless s/^\@findex\s+//; # only consider @findex lines
    chomp;
    s/\s+\@r.*$//;# if /^[^a-zA-Z]/;        # remove comment
    s/\@\{\@\}//;         # remove @{@} used in atchar, etc.
    s/<colon>/:/;         # @:
    s/<newline>/var{whitespace}/;  # special generic entry: @var{whitespace}
    s/^/\@/ unless /^\@/; # prepend @ unless already there (@@ @{ @})
    push (@ret, $_);
  }
  close (FILE) || warn "close($FILE) failed: $!";
  
  my %ret; @ret{@ret} = ();
  return %ret;
}


# Return command names from the @-Command List node in the reference
# manual as the keys of a hash (empty values).
# 
sub read_refman {
  my ($fname) = @_;
  my @ret = ();

  local *FILE;
  $FILE = $fname;
  open (FILE) || die "open($FILE) failed: $!";
  while (<FILE>) {
    last if /^\@appendix \@\@-Command List/;  # ignore until right appendix
  }
  while (<FILE>) {
    last if /^\@end table/; # ignore again after the summary
    next unless s/^\@itemx? *\@//;  # only want item[x]s in the table
    chomp;
    s/\@\{.+//;  # remove braced arguments (but not @{)
    s/ .*//;     # remove arguments following a space
    s/\@\@/@/g;  # @@ -> @
    next if $_ =~ /^\@(br|ctrl)$/;  # @ignore-d in text
    push (@ret, $_);
  }
  push (@ret, '@{'); # our non-parsing above fails on this one
  close (FILE) || warn "close($FILE) failed: $!";
  
  my %ret; @ret{@ret} = ();
  return %ret;
}


# Return command names implemented in the general parser as the keys of
# a hash (empty values).  The argument is the command to run to return
# the list.
#
sub read_tp {
  my ($prog) = @_;
  my @ret = ();
  
  local *FILE;
  $FILE = "$prog |";
  open (FILE) || die "open($FILE) failed: $!";
  while (<FILE>) {
    chomp;
    # excise @<whitespace> commands from normal list.
    next if $_ eq '@ ' || $_ eq "\@\t" || $_ eq "" || $_ eq '@';
    
    # obsolete and/or subsidiary commands we don't want to document as usual.
    next if $_ =~ /allow-recursion
                   |columnfractions
                   |cropmarks
                   |ctrl
                   |(even|every|odd)(foot|head)ingmarks
                   |quote-arg
                   |rmacro
                   |shorttitle$
                   |\|
                  /x;
    push (@ret, $_);
  }
  close (FILE) || warn "close($FILE) failed: $!";  
  
  push (@ret, '@var{whitespace}');

  my %ret; @ret{@ret} = ();
  return %ret;
}