#!/usr/bin/perl -w

# I like to have a program tell the user how to use it.
my $nargs = scalar(@ARGV);
if (!$nargs) {
  print<<"HERE";

Usage: $0 <preferred forms file> <file1> [<file2> ... <fileN>][--debug]
  Check the input files for use of non-preferred forms of phrases or word.

HERE
  exit;
}

$pref_filename = shift; # the file containing the deprecated/preferred forms

my $debug = 0;
@dbfiles = (); # the docbook files to check
foreach my $arg (@ARGV) {
  if ($arg =~ /-debug/) { $debug = 1; }
  else { push @dbfiles, $arg; }
}

open(PREF_FORMS, $pref_filename) || die "Can't open preferred forms file $pref_filename: $!";

%forms = ();

while (<PREF_FORMS>) {
  if (! /^\s*\#|^\s*$/) { # if line is not a comment or empty
    chop;
    (my $depr, my $repl, my $comm) = split(m!/!);
    if (! $comm) { $comm = ""};
    $forms{"$depr"} = [ $repl, $comm ];
  }
}

foreach my $dbfile (@dbfiles) {
  open(DBFILE, $dbfile) || die "Can't open docbook file $_: $!";

  my $s = 0; # Will hold file as a long string if needed for checking phrases across line breaks.
  my %lines = (); # Will hold line number versus character position info for line break test.

  while (my $line=<DBFILE>) {
    foreach my $depform (keys %forms) {

      # $depform is usually a phrase and the one used may have multiple spaces
      # which are generally ignored in docbook conversions to html or pdf.  So
      # we want to transform the "bad" phrase to a search expression which
      # ignores multiple whitespace between parts of the phrase. For eaxmple,
      # if $depform == 'anti alias' we change it to 'anti\Walias' for the search.

      # Save $depform though for later use.
      my $regex = $depform;
      my $phrase = 0; # If true, indicates embedded white space.
      if ($regex =~ m/\s/o) {
	my @d = split(' ', $regex);
	$phrase = 1 if (scalar(@d) > 1);
	$regex = join('\\s+', @d);
	if (0 && $debug) {
	  print "\$regex = '$regex'\n";
	  next;
	}
      }
      while ($line =~ /(^|\s+)$regex(\s+|$)*/g) {
	# Note the regex includes allowing for the phrase to start at the
	# beginning of a line or it can end a line.
	print "Deprecated form  `$depform'. Prefer `$forms{$depform}[0]'";
	if ($comment) {
	  print "($comment)";
	}
	print "\n";
	print "${dbfile}:${.}: $line";
	print " " x ( length("${dbfile}:${.}: ") + $-[0] + 1 ), "^^^\n";
      }

      next if (!$phrase);

      # Now we slurp rhe file in as an entire string to check for phrases
      # across line breaks.
      if (!$s) {
	# Only need to do this once per docbook.
	local(*FP);
	open(FP, $dbfile) || die "Can't open docbook file $dbfile: $!";
	# undef input delimiter (normally defined as: $/ = "\n";)
	undef $/;
	# slurp in all of input file
	$s = <FP>; # may have an extra newline
	close(FP);
	# return input delimiter to normal
	$/ = "\n";
      }

      while ($s =~ /($regex)/g) {
	# Test the match for at least one newline.
	my $t = $1;
	if (0 && $debug) {
	  print "matched expression '$t'\n";
	  next;
	}
	if ($1 =~ /\n/o) {
	  if ($debug) {
	    print "matched expression '$t'\n";
	  }
	  print "Deprecated form  `$depform'. Prefer `$forms{$depform}[0]'";
	  if ($comment) {
	    print "($comment)";
	  }
	  print "\n";
	  print "${dbfile}:${.}: $line";
	  print " " x ( length("${dbfile}:${.}: ") + $-[0] + 1 ), "^^^\n";
	}
      }

    }
  }
  close(DBFILE);
}
