File Coverage

blib/lib/XML/SAX/EventMethodMaker.pm

Criterion	Covered	Total	%
statement	115	246	46.7
branch	51	218	23.3
condition	8	12	66.6
subroutine	23	46	50.0
pod	41	43	95.3
total	238	565	42.1

package XML::SAX::EventMethodMaker;
{
  $XML::SAX::EventMethodMaker::VERSION = '0.46';
}
# ABSTRACT: SAX event names, creation of methods from templates


@ISA = qw( Exporter );
@EXPORT_OK = qw(
    sax_event_names
    missing_methods
    compile_methods
    compile_missing_methods
);
%EXPORT_TAGS = ( all => \@EXPORT_OK );

use strict ;

## First, a table in easy to maintain format :)
##
## Key to flags field:
##       = SAX versions supported in.  We'll need to make this more
##              powerful (support ranges) if we get in to subversions.
my %event_flags = (
    Han      => "Handler",
    DTD      => "DTDHandler",
    Cnt      => "ContentHandler",
    Doc      => "DocumentHandler",
    Dec      => "DeclHandler",
    Err      => "ErrorHandler",
    Ent      => "EntityResolver",
    Lex      => "LexicalHandler",
);


my %parse_method_flags = (
    Parse    => "ParseMethods",
);


my %event_table = qw(
    start_document            Han;1Doc;Cnt
    end_document              Han;1Doc;Cnt
    start_element             Han;1Doc;Cnt
    end_element               Han;1Doc;Cnt
    characters                Han;1Doc;Cnt
    start_prefix_mapping      Han;----;Cnt
    end_prefix_mapping        Han;----;Cnt
    processing_instruction    Han;1Doc;Cnt
    ignorable_whitespace      Han;1Doc;Cnt
    skipped_entity            Han;----;Cnt
    set_document_locator      Han;1Doc;Cnt
    notation_decl             Han;----;----;DTD
    unparsed_entity_decl      Han;----;----;DTD
    element_decl              Han;----;----;----;----;Dec
    attribute_decl            Han;----;----;----;----;Dec
    internal_entity_decl      Han;----;----;----;----;Dec
    external_entity_decl      Han;----;----;----;----;Dec
    comment                   Han;----;----;----;Lex
    start_dtd                 Han;----;----;----;Lex
    end_dtd                   Han;----;----;----;Lex
    start_cdata               Han;----;----;----;Lex
    end_cdata                 Han;----;----;----;Lex
    start_entity              Han;----;----;----;Lex
    end_entity                Han;----;----;----;Lex
    warning                   Han;----;----;----;----;----;Err
    error                     Han;----;----;----;----;----;Err
    fatal_error               Han;----;----;----;----;----;Err
    resolve_entity            Han;----;----;----;----;----;----;Ent

    xml_decl                  1Han;----;----;1DTD
    attlist_decl              1Han;----;----;1DTD
    doctype_decl              1Han;----;----;1DTD
    entity_decl               1Han;----;----;1DTD
    entity_reference          1Han;1Doc
);

my %parse_methods_table = qw(
    parse                     1:2Parse
    parse_file                2Parse
    parse_string              2Parse
    parse_uri                 2Parse
);


use Carp;

## Now, tear that apart so it's queryable
my %events_db;

for my $event ( keys %event_table, keys %parse_methods_table ) {
    my $flags = exists $event_table{$event}
        ? $event_table{$event}
        : $parse_methods_table{$event};

    for ( split /[;-]+/, $flags ) {
        my ( $versions, $type ) = /^([\d:]*)(.*)/
            or die "Couldn't parse '$_'";

        my @versions = split /\D+/, $versions;

        die "Unknown flag '$_'"
            unless exists $event_flags{$type}
                || exists $parse_method_flags{$type};

        @versions = ( 1, 2 ) unless @versions;

        $type = exists $event_flags{$type}
            ? $event_flags{$type}
            : $parse_method_flags{$type};

        push @{$events_db{$type}}, $event;
        for my $version ( @versions ) {
            push @{$events_db{"$version,$type"}}, $event;
            $events_db{$version}->{$event} = undef
                unless $type eq "ParseMethods";
        }
    }
}

#use Data::Dumper; local $Data::Dumper::Indent=1; warn Dumper( \%events_db );


my %legal_query_terms = map {
    ( $_ => undef );
} ( 1, 2, values %event_flags, values %parse_method_flags );


sub sax_event_names {
    ## This should be really common
    return keys %event_table unless @_;

    {
        my @baduns  = grep ! exists $legal_query_terms{$_}, @_;
        croak "Illegal sax_event_name query term(s): ",
            join ", ", map "'$_'", @baduns
            if @baduns;
    }

    my @versions;
    my @types;
    while (@_) {
        $_[0] =~ /^\d+$/
            ? push @versions, shift
            : push @types,    shift;
    }

    ## These might be relatively common as well.
    return keys %{$events_db{$versions[0]}}
        if @versions == 1 && ! @types;

    return @{$events_db{$types[0]}}
        if ! @versions && @types == 1;

    @versions = (1,2)               unless @versions;
    @types    = values %event_flags unless @types;

    my @keys = map {
        my $version = $_;
        map {
            my $type = $_;
            "$version,$type";
        } @types
    } @versions ;

    return keys %{{
        map {
            map {
                ( $_ => undef );
            } @{$events_db{$_}}
        } @keys
    }};
}



sub missing_methods {
    my $where = shift;
    $where = ref $where || $where;
    no strict 'refs';
    return grep ! exists ${"${where}::"}{$_}, @_;
}



sub compile_methods {
    my ( $where, $template ) = ( shift, shift );
    $where = ref $where || $where;

    my @code;

    for ( @_ ) {
        push @code, $template;
        $code[-1] =~ s/|/$_/g;
    }

    eval join "", "package $where;", @code, "1" or die $@;
}



sub compile_missing_methods {
    my ( $where, $template ) = ( shift, shift );

    compile_methods $where, $template, missing_methods $where, @_;
}


1;

__END__