#!/usr/bin/perl

#######################################################################
#
# Compare two LCFG profiles
#
# Stephen Quinney <squinney@inf.ed.ac.uk>
# Version 1.13.5 : 01/02/19 09:58:14
#
#######################################################################

use strict;
use Getopt::Std;
use HTML::Entities;
use LCFG::DB_File;
use LCFG::Utils::Diff::Module;

#######################################################################
# Constants
#######################################################################

my $VERSION   = '1.13.5';
my $date      = '01/02/19 09:58:14';

my $maxmsgs   = 200;          # Maximum messages to show

#######################################################################
# Globals
#######################################################################

my $opts = {};              # Option flags
my $verbose = 0;            # Verbose
my $debug = 0;              # Debug
my $quiet = 0;              # Quiet
my $ignorews = 0;           # Ignore whitespace
my $ignoreorder = 0;        # Ignore order
my $interactive = 0;        # Interactive mode
my $strict = 0;             # Strict string comparisons
my $type = undef;           # File type
my $format = undef;         # File format
my $update = 0;             # Force update
my $title = 'lcfgdiff';     # Window title
my $xmlparser = 0;          # XML parser module loaded

my $msgcount = undef;       # Message count
my $msglist = undef;        # Messages
my $hostname = undef;       # Current hostname (short)
my $domain = undef;         # Current domain
my $here = undef;           # Current directory
my $editor = undef;         # Editor
my $browser = undef;        # Browser
my $vdiff = undef;          # Vdiff program
my $module = undef;         # Type-specific module

sub Hostname() { return $hostname; }
sub Domain() { return $domain; }

# Tricky. Depending on how the application has substituted the _dl/_dr
# Strings, they may (template) or may not (perl,shell) contain the 
# backslash characters which we use to escape the [] for perl. So we
# create a regexp which matches versions with or without the backslashes.

my $dlsq = '\[%%'; $dlsq =~ s/\\/\\\\?\\/g; $dlsq =~ s/\%/\\\\?\%/g;
my $drsq = '%%\]'; $drsq =~ s/\\/\\\\?\\/g; $drsq =~ s/\%/\\\\?\%/g;

#########################################################################
sub Abort ($;$$$$) {
#########################################################################

  my $msg = shift;
  my $prof1 = shift;
  my $prof2 = shift;
  my $fmt1 = shift;
  my $fmt2 = shift;  

  if ($interactive) {
    Error($msg) if ($msg);
    GUIUpdate($prof1,$prof2,undef,undef,undef,$fmt1,$fmt2);
  } else { print stderr "$msg\n"; }
  exit(1);
}

#########################################################################
sub Error ($;$$) {
#########################################################################

  my $msg = shift;
  my $path = shift;
  my $type = shift;
  
  return if ($msgcount++>$maxmsgs);
  
  $path = "\[$path\] " if ($path);
  $type = "$type: " if ($type);
  my $text = ($msgcount>$maxmsgs) ?
    "further differences not shown ...\n" :
      "$path$type$msg\n";
  
  if ($interactive) { $msglist .= $text; }
  else { print $text unless ($quiet); }
}

#########################################################################
sub ParseXML ($$) {
#########################################################################

# Read and parse XML profile,or XHTML status page.
# Return the parse tree.

  my $source = shift;
  my $fmt = shift;

  if (!$xmlparser) {
    eval {
        require XML::Parser;
    };
    if ($@) {
      Error("No XML parser module: $source\n$@");
      return undef;
    }
    $xmlparser=1;
  }
  
  my $xmlParser = new XML::Parser(Style => 'Tree');

  my $t = eval { $xmlParser->parsefile($source); };

  return $t unless ($@);

  Error("XML parse failed: $source\n$@");
  return undef;
}

#########################################################################
sub Parse ($$$) {
#########################################################################

# Parse a file - return some kind of handle that Compare can use

  my $source = shift;
  my $fmt = shift;
  my $type = shift;
  
  return ParseXML($source,$fmt)
    if ($fmt eq 'xml' || $fmt eq 'html' || $fmt eq 'shtml');
  
  return $source if ($fmt eq 'dbm');

  # The default action is to create a 'stringhacked" copy of the input
  # file and return the pathname
  
  Abort("$!: $source") unless (open(FPI,"<$source"));
  Abort("$!: $source+") unless (open(FPO,">$source+"));
  my $s; while (defined($s=<FPI>)) {
    chomp $s;
    if (IgnoreWS()) { $s =~ s/(\s|\n)+/ /g; $s =~ s/^ //; $s =~ s/ $//; }
    print FPO HackString($s,$fmt,$type), "\n";
  }
  Abort("$!: $source") unless (close(FPI));
  Abort("$!: $source+") unless (close(FPO));
  
  return "$source+";
}

#########################################################################
sub HackString ($$$;$) {
#########################################################################

  # Ignore comparison of data which is irrelevant

  my $s = shift;
  my $fmt = shift;
  my $type = shift;
  my $path = shift;

  # Profile-specific stuff
  $s = $module->HackString($s,$path,$strict) if ($module);

  # Do not match strings inside _dls/_drs brackets
  $s =~ s/$dlsq(.*?)$drsq/\[%%*%%\]/g unless ($strict);

  # Ignore the current directory
  $s =~ s/($here)/\[%%*%%\]/g unless ($strict);

  return $s;
}

#########################################################################
sub Unparse ($$$;$) {
#########################################################################
  
  my $h = shift;
  my $fmt = shift;
  my $type = shift;
  my $path = shift || '';

  return UnparseXML($h,$fmt,$type,$path)
    if ($fmt eq 'xml' || $fmt eq 'html' || $fmt eq 'shtml');
  
  Abort("$!: $h") unless (open(FPI,"<$h"));
  while (<FPI>) { chomp; print FP HackString($_,$fmt,$type), "\n"; }
  Abort("$!: $h") unless (close(FPI));
}

#########################################################################
sub CopyDBM ($$$) {
#########################################################################
  
  my $f1 = shift;
  my $f2 = shift;
  my $type = shift;
  
  my $h1={}; Abort("$!: $f1") unless (LCFG::DB::TieReadOnly($f1,$h1));
  my $h2={}; Abort("$!: $f2") unless (LCFG::DB::TieReadWrite($f2,$h2));
  
  foreach my $k (sort keys(%$h1)) {
    $h2->{$k} = HackString($h1->{$k},'dbm',$type);
  }
  
  untie($h1);
  untie($h2);
}

#########################################################################
sub UnparseXML ($$$;$) {
#########################################################################
  
  my $t = shift;
  my $fmt = shift;
  my $type = shift;
  my $path = shift || '';

  my $tag = $t->[0];
  
  if ($tag eq "0") {
    print FP HTML::Entities::encode(HackString($t->[1],$fmt,$type));
    return;
  }
  
  my @contents = @{$t->[1]};
  my $attrs = shift @contents;
  my $s = "<$tag";
  
  foreach my $a (keys %$attrs) {
    my $v = $attrs->{$a};
    $s .= " $a=\"".
      HTML::Entities::encode(HackString($v,$fmt,$type)).'"';
  }
  
  print FP "$s>";
  
  while (defined($contents[0])) {
    my $t1 = shift @contents;
    my $v1 = shift @contents;
    my $newpath = $path ? "$path.$tag" : $tag;
    Unparse([$t1,$v1],$fmt,$type,$newpath);
  }
  
  print FP "</$tag>";
}

#########################################################################
sub IgnoreWS (;$) {
#########################################################################

  # We normally don't care about whitespace in certain elements

  my $path = shift;
  
  return 1 if ($ignorews);    # Ignore all whitespace differences

  return $module->IgnoreWS($path,$strict) if ($module);

  return 0;
}

#########################################################################
sub IgnoreOrder ($) {
#########################################################################

  # We normally don't care about order in certain elements

  my $path = shift;
  
  return 1 if ($ignoreorder); # Ignore all order differences

  return $module->IgnoreOrder($path,$strict) if ($module);

  return 0;
}

#########################################################################
sub CompareText ($$$$$) {
#########################################################################

# Compare two text strings

  my $s1 = shift;
  my $s2 = shift;
  my $path = shift;
  my $fmt = shift;
  my $type = shift;

  my $hs1 = HackString($s1,$fmt,$type,$path);
  my $hs2 = HackString($s2,$fmt,$type,$path);

  return 1 if ($hs1 eq $hs2);
  
  my $ss1 = $hs1; $ss1 =~ s/(\s|\n)+/ /g; $ss1 =~ s/^ //; $ss1 =~ s/ $//;
  my $ss2 = $hs2; $ss2 =~ s/(\s|\n)+/ /g; $ss2 =~ s/^ //; $ss2 =~ s/ $//;
  my $details = $verbose ? "\n  (1) '$hs1'\n  (2) '$hs2'" : '';
  # my $details = $verbose ? "\n  (1) '$s1'\n  (2) '$s2'" : '';
  # $details .= "\n  (1*) '$ss1'\n  (2*) '$ss2'";
  if ($ss1 eq $ss2) {
    return 1 if (IgnoreWS($path));
    Error("text content different $details",$path,'whitespace');
    return 0;
  }
  Error("text content different $details",$path,'text');
  return 0;
}
  
#########################################################################
sub CompareAttrs ($$$$$) {
#########################################################################

# Compare two attribute hashes

  my $a1 = shift;
  my $a2 = shift;
  my $path = shift;
  my $fmt = shift;
  my $type = shift;
  
  my $match = 1;
  my $details = '';
  
  foreach my $k (keys %$a1) {
    
    if (exists($a2->{$k})) {
      my $s1 = HackString($a1->{$k},$fmt,$type,"$path*");
      my $s2 = HackString($a2->{$k},$fmt,$type,"$path*");
      if ($s1 ne $s2) {
	$details .= "\n  - values different: $k" if ($verbose);
	$details .= "\n    (1) '$s1'\n    (2) '$s2'" if ($verbose);
	$match = 0;
      }
      next;
    }

    $details .= "\n  - in first profile only: $k" if ($verbose);
    $match = 0;
  }
  
  foreach my $k (keys %$a2) {
    next if (exists($a1->{$k}));
    $details .= "\n  - in second profile only: $k" if ($verbose);
    $match = 0;
  }
  
  Error("attributes different$details",$path,'list') unless ($match);

  return $match;
}
  
#########################################################################
sub Show ($$) {
#########################################################################

# Compare two element content lists

  my $k = shift;
  my $v = shift;
  
  return "text = '$v'" if ($k =~ /^%text/);
  return $k;
}

#########################################################################
sub CompareContents ($$$$$) {
#########################################################################

# Compare two element content lists

  my $c1 = shift;
  my $c2 = shift;
  my $path = shift;
  my $fmt = shift;
  my $type = shift;
  
  # For each content list, we create:
  # A hash of tag/name -> contents
  # A list of the tag/name/context
  # If there are duplicate tag/name/context, we complain and disambiguate
  # them with a numeric prefix (unless they are in the package list,
  # in which case, duplicate tags are expected).
  
  my ($i1,$t1,$h1,$l1,$d1,$ignws) = (0,0,{},[],{},IgnoreWS($path)); 
  
  my ($match,$ignorder) = (1,IgnoreOrder($path));
  
  while (defined($c1->[$i1])) {
    my $tag = $c1->[$i1++];
    my $content = $c1->[$i1++];
    if ($tag eq "0") {
      next if ($ignws && $content =~ /^\s*$/);
      $tag = "%text/".++$t1 ;
    } else {
      my $name = $content->[0]->{'cfg:name'};
      $tag .= "/$name" if ($name);
      my $context = $content->[0]->{'cfg:context'};
      $tag .= "+$context" if ($context);
    }
    if ($h1->{$tag}) {
      if ($module && $module->UniqueTags($path,$strict)) {
	Error("duplicate tag: $tag",$path,"duptag");
	$match = 0;
      }
      my $n = $d1->{$tag} || 0;
      $d1->{$tag} = ++$n;
      $tag = "$tag:$n";
    }
    $h1->{$tag} = $content;
    push @$l1, ($tag);
  }

  my ($i2,$t2,$h2,$l2,$d2) = (0,0,{},[],{}); 
  
  while (defined($c2->[$i2])) {
    my $tag = $c2->[$i2++];
    my $content = $c2->[$i2++];
    if ($tag eq "0") {
      next if ($ignws && $content =~ /^\s*$/);
      $tag = "%text/".++$t2 ;
    } else {
      my $name = $content->[0]->{'cfg:name'};
      $tag .= "/$name" if ($name);
      my $context= $content->[0]->{'cfg:context'};
      $tag .= "+$context" if ($context);
    }
    if ($h2->{$tag}) {
      if ($module && $module->UniqueTags($path,$strict)) {
	Error("duplicate tag: $tag",$path,"duptag");
	$match = 0;
      }
      my $n = $d2->{$tag} || 0;
      $d2->{$tag} = ++$n;
      $tag = "$tag:$n";
    }
    $h2->{$tag} = $content;
    push @$l2,($tag);
  }

  # Compare the tag lists

  if (join('.',@$l1) ne join('.',@$l2)) {
    if (join('.',(sort @$l1)) eq join('.',(sort @$l2))) {
      unless ($ignorder) {
	Error("list order different",$path,'order');
	$match = 0;
      }
    } else {
      my @l1s = sort @$l1;
      my @l2s = sort @$l2;
      my $details = '';
      if ($verbose) {
	while (defined($l1s[0]) || defined($l2s[0])) {
	  if (!defined($l2s[0])) {
	    $details .= "\n  - first profile only: " . 
	      Show($l1s[0],$h1->{$l1s[0]});
	    shift @l1s;
	    next;
	  } elsif (!defined($l1s[0])) {
	    $details .= "\n  - second profile only: " .
	      Show($l2s[0],$h2->{$l2s[0]});
	    shift @l2s;
	    next;
	  } elsif ($l1s[0] lt $l2s[0]) {
	    $details .= "\n  - first profile only: " .
	      Show($l1s[0],$h1->{$l1s[0]});
	    shift @l1s; next;
	  } elsif ($l1s[0] gt $l2s[0]) {
	    $details .= "\n  - second profile only: " .
	      Show($l2s[0],$h2->{$l2s[0]});
	    shift @l2s; next;
	  } else {
	    shift @l1s;
	    shift @l2s;
	    next;
	  }
	}
      }
      Error("lists different$details",$path,'list');
      $match = 0;
    }
  }

  # Now compare the contents of matching elements

  foreach my $t (keys %$h1) {
    next unless (defined($h2->{$t}));
    my ($c1,$c2) = ($h1->{$t},$h2->{$t});
    my $tag = $t; $tag = "0" if ($tag =~ /^%text\//);
    $match = 0 unless Compare([$tag,$c1],[$tag,$c2],$fmt,$type,$path);
  }

  return $match;
}

#########################################################################
sub CompareDBM ($$$$) {
#########################################################################

# Compare two DBM files

  my $f1 = shift;
  my $f2 = shift;
  my $fmt = shift;
  my $type = shift;

  my $h1={}; Abort("$!: $f1") unless (LCFG::DB::TieReadOnly($f1,$h1));
  my $h2={}; Abort("$!: $f2") unless (LCFG::DB::TieReadOnly($f2,$h2));

  my $match = 1;

  foreach my $k (sort keys(%$h1)) {
    if (exists($h2->{$k})) {
      $match=0 unless (CompareText($h1->{$k},$h2->{$k},$k,$fmt,$type));
    } else {
      $match=0; Error("in first dbm only: $k");
    }
  }
  
  foreach my $k (sort keys(%$h2)) {
    next if (exists($h1->{$k}));
    $match=0; Error("in second dbm only: $k");
  }
    
  untie($f1);
  untie($f2);
  
  return $match;
}
  
#########################################################################
sub CompareXML ($$$$;$) {
#########################################################################

# Compare two XML parse trees

  my $t1 = shift;
  my $t2 = shift;
  my $fmt = shift;
  my $type = shift;
  my $path = shift || '';

  my ($tag1,$content1) = ($t1->[0],$t1->[1]);
  my ($tag2,$content2) = ($t2->[0],$t2->[1]);
  
  Error("tag1 != tag2",$path,"tags") unless ($tag1 eq $tag2);
  
  return CompareText($content1,$content2,$path,$fmt,$type) if ($tag1 eq "0");
  
  my @c1 = @$content1; my $attr1 = shift @c1;
  my @c2 = @$content2; my $attr2 = shift @c2;
  
  my $newpath = $path ? "$path.$tag1" : $tag1;

  return CompareAttrs($attr1,$attr2,$newpath,$fmt,$type) &
    CompareContents(\@c1,\@c2,$newpath,$fmt,$type);
}

#########################################################################
sub Compare ($$$$;$) {
#########################################################################

# Compare two objects with handles as returned by Parse

  my $a = shift;
  my $b = shift;
  my $fmt = shift;
  my $type = shift;
  my $path = shift || '';
  
  return CompareXML($a,$b,$fmt,$type,$path)
    if ($fmt eq 'xml' || $fmt eq 'html' || $fmt eq 'shtml');

  return CompareDBM($a,$b,$fmt,$type) if ($fmt eq 'dbm');

  # The default action is to diff the two files
 
  my $result = `diff $a $b 2>&1`;
  my $status = $?;
  Error($result) if ($result);

  return ($status==0) ? 1 : 0;
}

#########################################################################
sub LoadModule ($) {
#########################################################################

# Dynamically load the type-specfic module

  my $type = shift;
  
  eval "use LCFG::Utils::Diff::$type;";
  if ($@ =~ /^can\'t locate/i) {
    Abort("no module -  LCFG::Utils::Diff::$type");
  } elsif ($@) {
    Abort("error loading LCFG::Utils::Diff::$type\n$@");
  }

  my $module = eval 'new LCFG::Utils::Diff::'.$type.'();';
  if ($@) {
    Abort("can't create module LCFG::Utils::Diff::$type\n$@");
  }

  return $module;
}

#########################################################################
sub Format ($) {
#########################################################################
  
# Find file format
  
  my $path = shift;
  
  return 'empty' unless (-f $path);
  return $format if ($format);

  my $dbm={};
  if (LCFG::DB::TieReadOnly($path,$dbm)) { untie($dbm); return 'dbm'; }

  Abort("$!: $path") unless (open(FP,"<$path"));
  my $line; while (defined($line=<FP>)) {
    last unless ($line =~ /^\s*$/);
  } 
  Abort("$!: $path") unless (close(FP));
  return 'empty' unless (defined($line));
  return 'xml' if ($path =~ /\.xml$/);
  return 'html' if ($path =~ /\.html$/);
  return 'shtml' if ($path =~ /\.shtml$/);
  return 'xml' if ($line =~ /^\s*\<\?xml\s+/);
  return 'html' if ($line =~ /^\s*\<!DOCTYPE\s+/);
  return 'html' if ($line =~ /^\s*\<html/);
  return 'text';
}

#########################################################################
sub Update ($$$$) {
#########################################################################
  
  my $prof = shift;
  my $t = shift;
  my $fmt = shift;
  my $type = shift;

  if (!defined($t)) {
    Abort("$!: $prof~") unless (! -f "$prof~" || unlink("$prof~"));
    Abort("$!: $prof -> $prof~") unless (! -f $prof || rename($prof,"$prof~"));
    return;
  }
  
  my $ofile = "$prof#";

  if ($fmt eq 'dbm') {
    CopyDBM($t,$ofile,$type);
  } else {
    Abort("$!: $ofile") unless (open(FP,">$ofile"));
    print FP '<?xml version="1.0"?>',"\n" if ($fmt eq 'xml');
    Unparse($t,$fmt,$type) if ($t);
    Abort("$!: $ofile") unless (close(FP));
  }
  
  Abort("$!: $prof~") unless (! -f "$prof~" || unlink("$prof~"));
  Abort("$!: $prof -> $prof~") unless (! -f $prof || rename($prof,"$prof~"));
  Abort("$!: $prof# -> $prof") unless (rename("$prof#",$prof));

  return 1;
}

#########################################################################
sub Diff ($$$) {
#########################################################################

# Diff two files
  
  my $f1 = shift;
  my $f2 = shift;
  my $fmt = shift;
  
  return if (fork());
  if ($fmt eq 'text') { $f1 .= '+'; $f2 .= '+'; }
  my $result = `$vdiff $f1 $f2 2>&1`;
  my $status = $?;
  exit($status);
}

#########################################################################
sub Edit ($$) {
#########################################################################

# Edit file
  
  my $f = shift;
  my $fmt = shift;
  
  return if (fork());
  my $result = `$editor $f 2>&1`;
  my $status = $?;
  exit($status);
}

#########################################################################
sub View ($$) {
#########################################################################

# View file
  
  my $f = shift;
  my $fmt = shift;
  
  return if (fork());
  my $result = `$browser file://$f 2>&1`;
  my $status = $?;
  exit($status);
}

#########################################################################
sub GUIUpdate (;$$$$$$$) {
#########################################################################

# Use GUI to show differences and give user the option of updating
# The second profile to match the first
  
  my $prof1 = shift;
  my $prof2 = shift;
  my $t1 = shift;
  my $t2 = shift;
  my $fmt = shift;
  my $fmt1 = shift;
  my $fmt2 = shift;

  my $action = undef;

  my $mw = MainWindow->new;

  $mw->title($title);
  
  my $buttonframe = $mw->Frame()->pack( -anchor => 'nw', -fill => 'x' );
  
  $buttonframe->Button( -text => 'Quit',
			-command =>  sub{ $action = 'quit'; $mw->destroy; }
		      )->pack( -side => 'right' );
  
  $buttonframe->Button( -text => 'Again',
			-command => sub{ $action = 'again'; $mw->destroy; }
		      )->pack( -side => 'right' );
  
  $buttonframe->Button( -text => 'Update',
			-command => sub{ $action = 'update'; $mw->destroy; }
		      )->pack( -side => 'right' ) if (defined($t1) && $prof2);
  
  $buttonframe->Button( -text => 'Diff',
			-command => sub{ Diff($prof1,$prof2,$fmt); }
		      )->pack( -side => 'right' )
			if ($prof1 && $prof2 && $vdiff && $fmt ne 'dbm');
    

  $buttonframe->Checkbutton( -text => 'Verbose',
			     -variable => \$verbose
			   )->pack( -side => 'left' );
  
  $buttonframe->Checkbutton( -text => 'Strict',
			     -variable => \$strict
			   )->pack( -side => 'left' );
  
  $buttonframe->Checkbutton( -text => 'Whitespace',
			     -variable => \$ignorews
			   )->pack( -side => 'left' );
  
  $buttonframe->Checkbutton( -text => 'Order',
			     -variable => \$ignoreorder
			   )->pack( -side => 'left' );
  
  my $pathbox = $mw->Frame()->pack( -fill => 'x' );
  
  if ($prof1) {

    my $pathframe = $pathbox->Frame()->pack( -side => 'top', -fill => 'x' );
    
    $pathframe->Button( -text => 'View',
			-command => sub{ View($prof1,$fmt1); }
		      )->pack( -side => 'left' )
			if (($fmt1 eq 'html'||$fmt1 eq 'shtml' ) && $browser);
    
    $pathframe->Button( -text => 'Edit',
			-command => sub{ Edit($prof1,$fmt1); }
		      )->pack( -side => 'left' ) if ($editor && $fmt ne 'dbm');
    
    my $pf1 = $pathframe->Text( -width => 100, -height => 1,
			      )->pack( -side => 'left', -fill => 'x' );
    
    $pf1->configure( -state => 'normal' );
    $pf1->delete('1.0','end'); 
    $pf1->insert('1.0',"[1] $prof1 ($fmt1)");
    $pf1->configure( -state => 'disabled' );
  }
  
  if ($prof2) {

    my $pathframe = $pathbox->Frame()->pack( -side => 'top', -fill => 'x' );
  
    $pathframe->Button( -text => 'View',
			-command => sub{ View($prof2,$fmt2); }
		      )->pack( -side => 'left' )
			if (($fmt2 eq 'html'||$fmt2 eq 'shtml' ) && $browser);
    
    $pathframe->Button( -text => 'Edit',
			-command => sub{ Edit($prof2,$fmt2); }
		      )->pack( -side => 'left' ) if ($editor && $fmt ne 'dbm');

    my $pf2 = $pathframe->Text( -width => 100, -height => 1,
			      )->pack( -fill => 'x' );
    
    $pf2->configure( -state => 'normal' );
    $pf2->delete('1.0','end'); 
    $pf2->insert('1.0',"[2] $prof2 ($fmt2)");
    $pf2->configure( -state => 'disabled' );
  }

  my $textframe = $mw->Frame()->pack( -fill => 'both', -expand => 1 );
  
  my $msgbox = $textframe->Scrolled
    ( 'Text',
      -scrollbars => 'e',
      -width      => 100,
    )->pack( -fill => 'both', -expand => 1 );
  
  $msgbox->configure( -state => 'normal' );
  $msgbox->delete('1.0','end'); 
  $msgbox->insert('1.0',$msglist);
  $msgbox->configure( -state => 'disabled' );
  
  MainLoop();

  return $action;
}

#######################################################################
sub Usage ($) {
#######################################################################

  my $estatus = shift;    # Exit status

  print <<EOF;

usage: lcfgdiff [opts] profile1.xml profile2.xml
  -D          - debug
  -d domain   - domain
  -f format   - set file format
  -i          - interactive update mode
  -o          - ignore differences in element order
  -q          - quiet mode - report difference by exit status only
  -s          - strict string comparisons
  -t type     - set file type
  -T title    - window title for interactive mode
  -u          - force update
  -v          - verbose
  -V          - print usage mesage and exit
  -w          - ignore differences in whitespace

EOF

  exit($estatus);
}

#######################################################################
# Main program
#######################################################################

my $cmd = join(' ',@ARGV);
Abort("invalid options: $cmd") unless (getopts("T:d:f:t:VsvqiuDwo",$opts));

Usage(0) if (defined($opts->{'V'}));
$debug = 1 if (defined($opts->{'D'}));
$verbose = 1 if (defined($opts->{'v'}));
$quiet = 1 if (defined($opts->{'q'}));
$ignorews = 1 if (defined($opts->{'w'}));
$ignoreorder = 1 if (defined($opts->{'o'}));
$interactive = 1 if (defined($opts->{'i'}));
$strict = 1 if (defined($opts->{'s'}));
$update = 1 if (defined($opts->{'u'}));
$type = $opts->{'t'} if (defined($opts->{'t'}));
$format = $opts->{'f'} if (defined($opts->{'f'}));
$domain = $opts->{'d'} if (defined($opts->{'d'}));
$title = $opts->{'T'} if (defined($opts->{'T'}));

Usage(1) unless ($ARGV[0]);
my $prof1 = shift @ARGV;

Usage(1) unless ($ARGV[0]);
my $prof2 = shift @ARGV;

# Only load the Tk module if we are interactive - this
# allows us to use the program, on systems with no Tk
# if we don't need the interactive mode
if ($interactive) {
  eval "use Tk;";
  if ($@ =~ /^can\'t locate/i) {
    $interactive=0;
    Abort("Perl Tk module is required for interactive mode");
  } elsif ($@) {
    $interactive=0;
    Abort("error loading Tk module\n$@");
  }
}

$hostname = `/bin/hostname`; chomp $hostname; $hostname =~ s/\..*//;
$domain = `/bin/dnsdomainname` unless ($domain); chomp $domain;
$here = `echo pwd | bash`; chomp $here;
$editor = $ENV{XEDITOR};
$browser = $ENV{BROWSER};
$vdiff = $ENV{VDIFF};

if ($debug) {
  print stderr "host: $hostname\n";
  print stderr "domain: $domain\n";
  print stderr "here: $here\n";
  print stderr "browser: $browser\n";
  print stderr "editor: $editor\n";
  print stderr "vdiff: $vdiff\n";
  print stderr "type: $type\n" if ($type);
}

$module = LoadModule($type) if ($type);

$prof1 = "$here/$prof1" unless ($prof1 =~ /^\//);
$prof2 = "$here/$prof2" unless ($prof2 =~ /^\//);

my ($fmt,$fmt1,$fmt2) = (undef,Format($prof1),Format($prof2));
if ($fmt1 eq 'empty') { $fmt = $fmt2; }
elsif ($fmt2 eq 'empty') { $fmt = $fmt1; }
elsif ($fmt1 eq $fmt2) { $fmt = $fmt1; }
else { Abort("files have different formats",$prof1,$prof2,$fmt1,$fmt2); }

if ($debug) {
  print stderr "file1: $prof1\n";
  print stderr "format1: $fmt1\n";
  print stderr "file2: $prof2\n";
  print stderr "format2: $fmt2\n";
}

while (1) {

  $msgcount = 0;
  $msglist = '';
  
  my $h1 = ($fmt1 eq 'empty') ? 0 : Parse($prof1,$fmt,$type);
  my $h2 = ($fmt2 eq 'empty') ? 0 : Parse($prof2,$fmt,$type);

  my $match = 1;
  if ($h1 && $h2) { $match = Compare($h1,$h2,$fmt,$type); }
  elsif ($h1 && !$h2) {
    Error( defined($h2) ? "unexpected output generated" :
	   "destination parse failed!" );
    $match=0; 
  } elsif (!$h1 && $h2) {
    Error( defined($h1) ? "no output generated" :
	   "source parse failed!" );
    Error("no output generated");
    $match=0; 
  } elsif( !defined($h1) || !defined($h2)) {
    Error( defined($h1) ? "no output generated" :
	   "source parse failed!" );
    Error( defined($h2) ? "unexpected output generated" :
	   "destination parse failed!" );
    $match=0; 
  }
  
  Error("(matching with ignored whitespace)") if ($match && $ignorews);
  Error("(matching with ignored order)") if ($match && $ignoreorder);
  
  my $action = ($update) ? ( $match ? 'quit' : 'update' ) :
    ($interactive && (!$match || $ignorews || $ignoreorder))
      ? GUIUpdate($prof1,$prof2,$h1,$h2,$fmt,$fmt1,$fmt2) : 'quit';
 
  next if ($action eq 'again');
  
  $match = Update($prof2,$h1,$fmt,$type) if ($action eq 'update');
  
  exit( $match ? (($action eq 'update') ? 7 : 0 ) : 1 );
}

__END__

=head1 NAME

lcfgdiff - compare profiles (or other files)

=head1 SYNOPSIS

lcfgdiff [I<options>] I<file> I<file> ...

=head1 DESCRIPTION

This command is used by the LCFG test procedures to compare generated files
with previous (known good) copies. It can compare XML, XHTML, text and
DBM files.

Unless the B<strict> option is used, strings are preprocessed before
comparison by removing any text between the delimiters B<\[%%> and
B<%%\]>. The LCFG buildtools defines the symbols B<_dl> and B<_dr> to
be these delimiters at test time, and to be null when generating
production releases. This means that test programs can enclose
insignificant output inside these delimiters and it will be ignored
when testing.

Individual applications can also define instances of the
B<LCFG::Utils::Diff::Modules> class. This allows additional
type-specific preprocessing to be performed before comparisons. It
allows other options to be controllde - for example ignoring the order
of the tags at ceratin nodes in an XML document.

=head1 OPTIONS

=over 4

=item B<-D>

Debug.

=item B<-d> I<domain>

The current domain. This is made available to type-specific modules.

=item B<-f> I<format>

Set file format. This is normally detected automatically and may be
B<xml>, B<text>, B<dbm>, or B<html>.

=item B<-i>

Interactive mode. If the files are diferent, then a GUI interface is
presented showing the differences and allowing several options.

=item B<-o>

Ignore differences in XML/XHTML element order.

=item B<-q>

Quiet mode - report difference by exit status only.

=item B<-s>

Strict string comparisons. Do not process delimiters.

=item B<-t> I<type>

The file I<type>. The module B<LCFG::Utils::Diff::>I<type> is used to
control comparisons. This must be a subclass of
B<LCFG::Utils::Diff::Module>.

=item B<-T> I<title>

Window title for interactive mode.

=item B<-u>

Force the destination file to be updated to match the source file
withoout prompting. This can be used to update the "known" good copies
of the test files when a tested change has been made.

=item B<-v>

Verbose.

=item B<-V>

Print usage mesage and exit.

=item B<-w>

Ignore differences in whitespace.

=item B<-v>

Verbose.

=back

=head1 VARIABLES

=over 4

=item XEDITOR

An X-aware editor to be used when the B<Edit> button is pressed in
interactive mode.

=item VDIFF

An X-aware I<diff> program to be used when the B<Diff> button is
pressed in interactive mode.

=item BROWSER

An X-aware browser program to be used when the B<View> button is
pressed for HTML files.

=back

=head1 PLATFORMS

This is the list of platforms on which we have tested this
software. We expect this software to work on any Unix-like platform
which is supported by Perl.

ScientificLinux6, EnterpriseLinux7, Debian

=head1 BUGS AND LIMITATIONS

Please report any bugs or problems (or praise!) to bugs@lcfg.org,
feedback and patches are also always very welcome.

=head1 AUTHOR

    Stephen Quinney <squinney@inf.ed.ac.uk>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2009-2019 University of Edinburgh. All rights reserved.

This library is free software; you can redistribute it and/or modify
it under the terms of the GPL, version 2 or later.

=cut
