#!/usr/bin/perl

use strict;
use warnings;

use Benchmark    qw( cmpthese );
use Data::Dumper qw( Dumper );
use Encode       qw( encode );
use XML::Simple  qw( :strict );


my @KNOWN_SAX_PARSERS = qw(
   XML::LibXML::SAX
   XML::LibXML::SAX::Parser
   XML::SAX::ExpatXS
   XML::SAX::PurePerl
);


my $xml;


sub load_module {
   my ($mod) = @_;
   $mod =~ s{::}{/}g;
   $mod .= '.pm';
   return eval { require $mod };
}


sub get_parser_desc_name {
   my ($name) = @_;
   my $ver = $name->VERSION();
   return $name . ( defined($ver) ? " $ver" : '' );
}


my $xml_simple_desc_name = get_parser_desc_name('XML::Simple');

sub xml_simple_parser {
   my ($name) = @_;
   my $parser = XML::Simple->new( ForceArray => 1, KeyAttr => {} );
   return [
      $name,
      sprintf('%s (via %s)',
         get_parser_desc_name($name),
         $xml_simple_desc_name,
      ),
      sub {
         local $XML::Simple::PREFERRED_PARSER = $name;
         return $parser->XMLin($xml);
      },
   ];
}


sub find_parsers {
   my @parsers;

   if (!load_module('XML::LibXML')) {
      warn("warn: XML::LibXML not available\n");
   } else {
      my $parser = XML::LibXML->new();
      push @parsers, [
         'XML::LibXML',
         get_parser_desc_name('XML::LibXML'),
         sub { $parser->parse_string($xml) },
      ];
   }

   if (!load_module('XML::Parser')) {
      warn("warn: XML::Parser not available\n");
   } else {
      push @parsers, xml_simple_parser('XML::Parser');
   }

   if (!load_module('XML::SAX')) {
      warn("warn: XML::SAX not available\n");
   } else {
      my @sax = sort map { $_->{Name} } @{ XML::SAX->parsers() };
      my %sax   = map { $_ => 1 } @sax;
      my %known = map { $_ => 1 } @KNOWN_SAX_PARSERS;

      for my $sax (@sax) {
         warn("info: Discovered new SAX parser $sax\n")
            if !delete($known{$sax});

         load_module($sax)
            or do { warn("error: Can't load SAX parser $sax\n");
                    next;
                  };

         push @parsers, xml_simple_parser($sax);
      }

      for my $known (keys %known) {
         load_module($known)
            or do { warn("warn: Known parser $known not installed\n");
                    next;
                  };

         warn("warn: XML::SAX unaware of installed parser $known\n");
         push @parsers, xml_simple_parser($known);
      }
   }

   return \@parsers;
}


sub test_parser {
   my ($name, $desc_name, $parser) = @_;

   if (eval { $parser->() }) {
      print("info: Parsing with $desc_name appears successful\n");
      return 1;
   } else {
      print("error: Unable to parse with $desc_name! $@\n");
      return 0;
   }
}


sub benchmark {
   my ($parsers) = @_;
   cmpthese(-5, { map { $_->[0] => $_->[2] } @$parsers });
}


{
   my $xml_qfn = $ARGV[0]
      or die("Please supply XML file as argument\n");

   # Global
   $xml = do {
      local $/;
      open(my $fh, '<:raw:perlio', $xml_qfn)
         or die("Can't open XML file \"$xml_qfn\": $!\n");
      <$fh>
   };

   my $parsers = find_parsers();
   @$parsers = grep { test_parser(@$_) } @$parsers;

   print("\n");

   benchmark($parsers);
}