File Coverage

blib/lib/XML/Parser/Expat/Dispatched.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package XML::Parser::Expat::Dispatched;
use strict;
# ABSTRACT: Automagically dispatches subs to XML::Parser::Expat handlers
use true;
use parent 'XML::Parser::Expat';
use Carp;

our $VERSION = 0.951;


sub new {
  my($package) = shift;
  my ($opts, %dispatch, $s);
  { $opts =
      {Start         => 'Start',
       End           => 'End',
       handler       => 'handler',
       #transform_tag,
       #transform_suffix,
       #transform,
      };
    if ($package->can('config_dispatched')) {
      my $config_opts = $package->config_dispatched;
      $opts->{$_} = $config_opts->{$_} foreach keys %$config_opts;
      if (exists $opts->{transform}) {
	foreach (qw|transform_tag transform_suffix|) {
	  carp "both $_ and transform defined in config_dispatched, taking transform"
	    if exists $opts->{$_};
	  $opts->{$_} = $opts->{transform} unless defined $opts->{$_};
	  # since this is the only place where i would need 5.01 syntax i don't use it.
	}
      }
    }
  }

  {
    my %opt_reversed = (map {$opts->{$_}, $_} qw|Start End handler|);
    no strict 'refs';		# perlcritic doesn't like this
    while (my ($symbol_table_key, $val) = each %{ *{ "$package\::" } }) {
      local *ENTRY = $val;
      if (defined $val
	  and defined *ENTRY{ CODE }
	  and $symbol_table_key =~ /^(?:(?'what'$opts->{Start}|$opts->{End})_?(?'who'.*)
				    |(?'who'.*?)_?(?'what'$opts->{handler}))$/x) {
	my $what = $opt_reversed{$+{what}};
	carp "the sub $symbol_table_key overrides the handler for $dispatch{$what}{$+{who}}[1]"
	  if exists $dispatch{$what}{$+{who}};
	$dispatch{$what}{$+{who}}= [*ENTRY{ CODE }, $symbol_table_key];
      }
    }
  }
  $s = bless(XML::Parser::Expat->new(@_),$package);
  {# generating the dispatche from the methods
    my %real_dispatch;
    foreach my $se (qw|Start End|) {
      if (exists $dispatch{$se}){
	if (exists $opts->{transform_suffix}){
	  foreach (keys %{$dispatch{$se}}) {
	    my $new_key= $opts->{transform_suffix}($s, $_);
	    if ($_ ne $new_key) {
	      carp "$dispatch{$se}{$new_key}[1] and $dispatch{$se}{$_}[1] translate to the same handler"
		if exists $dispatch{$se}{$new_key};
	      $dispatch{$se}{$new_key} = $dispatch{$se}{$_};
	      delete $dispatch{$se}{$_};
	    }
	  }
	}
	if (exists $opts->{transform_tag}) {
	  $real_dispatch{$se} = sub {
	    my $new_tagname = $opts->{transform_tag}(@_[0,1]);
	    if ($dispatch{$se}{$new_tagname}) {
	      $dispatch{$se}{$new_tagname}[0](@_);
	    } elsif (exists $dispatch{$se}{''}) {
	      $dispatch{$se}{''}[0](@_);
	    }
	  };
	} else {
	  $real_dispatch{$se} = sub {
	    if ($dispatch{$se}{$_[1]}) {
	      $dispatch{$se}{$_[1]}[0](@_);
	    } elsif (exists $dispatch{$se}{''}) {
	      $dispatch{$se}{''}[0](@_);
	    }
	  };
	}
      }
    }

    foreach (keys %{$dispatch{handler}}) {
      $real_dispatch{$_} = $dispatch{handler}{$_}[0];
    }

    $s->setHandlers(%real_dispatch);
  }
  return $s;
}

__END__