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


line stmt bran cond sub pod time code
1             package XML::Parser::Expat::Dispatched;
2 4     4   89046 use strict;
  4         5  
  4         92  
3             # ABSTRACT: Automagically dispatches subs to XML::Parser::Expat handlers
4 4     4   12 use true;
  4         5  
  4         13  
5 4     4   2649 use parent 'XML::Parser::Expat';
  4         9  
  4         36  
6             use Carp;
7              
8             our $VERSION = 0.951;
9              
10              
11             sub new {
12             my($package) = shift;
13             my ($opts, %dispatch, $s);
14             { $opts =
15             {Start => 'Start',
16             End => 'End',
17             handler => 'handler',
18             #transform_tag,
19             #transform_suffix,
20             #transform,
21             };
22             if ($package->can('config_dispatched')) {
23             my $config_opts = $package->config_dispatched;
24             $opts->{$_} = $config_opts->{$_} foreach keys %$config_opts;
25             if (exists $opts->{transform}) {
26             foreach (qw|transform_tag transform_suffix|) {
27             carp "both $_ and transform defined in config_dispatched, taking transform"
28             if exists $opts->{$_};
29             $opts->{$_} = $opts->{transform} unless defined $opts->{$_};
30             # since this is the only place where i would need 5.01 syntax i don't use it.
31             }
32             }
33             }
34             }
35              
36             {
37             my %opt_reversed = (map {$opts->{$_}, $_} qw|Start End handler|);
38             no strict 'refs'; # perlcritic doesn't like this
39             while (my ($symbol_table_key, $val) = each %{ *{ "$package\::" } }) {
40             local *ENTRY = $val;
41             if (defined $val
42             and defined *ENTRY{ CODE }
43             and $symbol_table_key =~ /^(?:(?'what'$opts->{Start}|$opts->{End})_?(?'who'.*)
44             |(?'who'.*?)_?(?'what'$opts->{handler}))$/x) {
45             my $what = $opt_reversed{$+{what}};
46             carp "the sub $symbol_table_key overrides the handler for $dispatch{$what}{$+{who}}[1]"
47             if exists $dispatch{$what}{$+{who}};
48             $dispatch{$what}{$+{who}}= [*ENTRY{ CODE }, $symbol_table_key];
49             }
50             }
51             }
52             $s = bless(XML::Parser::Expat->new(@_),$package);
53             {# generating the dispatche from the methods
54             my %real_dispatch;
55             foreach my $se (qw|Start End|) {
56             if (exists $dispatch{$se}){
57             if (exists $opts->{transform_suffix}){
58             foreach (keys %{$dispatch{$se}}) {
59             my $new_key= $opts->{transform_suffix}($s, $_);
60             if ($_ ne $new_key) {
61             carp "$dispatch{$se}{$new_key}[1] and $dispatch{$se}{$_}[1] translate to the same handler"
62             if exists $dispatch{$se}{$new_key};
63             $dispatch{$se}{$new_key} = $dispatch{$se}{$_};
64             delete $dispatch{$se}{$_};
65             }
66             }
67             }
68             if (exists $opts->{transform_tag}) {
69             $real_dispatch{$se} = sub {
70             my $new_tagname = $opts->{transform_tag}(@_[0,1]);
71             if ($dispatch{$se}{$new_tagname}) {
72             $dispatch{$se}{$new_tagname}[0](@_);
73             } elsif (exists $dispatch{$se}{''}) {
74             $dispatch{$se}{''}[0](@_);
75             }
76             };
77             } else {
78             $real_dispatch{$se} = sub {
79             if ($dispatch{$se}{$_[1]}) {
80             $dispatch{$se}{$_[1]}[0](@_);
81             } elsif (exists $dispatch{$se}{''}) {
82             $dispatch{$se}{''}[0](@_);
83             }
84             };
85             }
86             }
87             }
88              
89             foreach (keys %{$dispatch{handler}}) {
90             $real_dispatch{$_} = $dispatch{handler}{$_}[0];
91             }
92              
93             $s->setHandlers(%real_dispatch);
94             }
95             return $s;
96             }
97              
98             __END__