Парсинг XML - IV

xml-parser-tag.pl

#!/usr/bin/perl

# ------------------------------------------------------------------------------
# Напишите скрипт, получающий в качестве параметра путь к XML-файлу и выдающий
# на STDOUT следующее:
# * суммарное число букв внутри тегов, не включая пробельные символы 
#   (<aaa dd="ddd">text</aaa> - четыре буквы)
# * суммарное число букв нормализованного текста внутри тегов, включая пробелы
# * число внутренних ссылок (теги <a href="#id">)
# * число битых внутренних ссылок (ссылки на несуществующие ID элементов)
# ------------------------------------------------------------------------------
use Const::Fast;
use Modern::Perl;
use Number::Format qw/format_number/;
use XML::Parser;
use utf8;
use open qw/:std :utf8/;

# ------------------------------------------------------------------------------
const my %TEXT_TAGS => (
    p => 1,
);

my ( $chars, $all_chars, %id, @href ) = ( 0, 0 );

XML::Parser->new(
    Handlers => {
        Start => \&handle_start,
        End   => \&handle_end,
        Char  => \&handle_char,
    }
)->parsefile( @ARGV ? $ARGV[0] : 'test.xml' );;

say 'All characters            : ' . format_number($all_chars);
say 'Non-whitespace characters : ' . format_number($chars);
say 'Internal links            : ' . format_number( scalar @href );
my $errors = 0;
for (@href) {
    ++$errors unless exists $id{$_};
}
say 'Broken links              : ' . format_number($errors) if $errors;

my @current_tag;

# ------------------------------------------------------------------------------
sub handle_start {

    my ( undef, $tag, %attr ) = @_;

    push @current_tag, $tag;

    $id{ q{#}. $attr{id} } = 1 if exists $attr{id};

    if ( $tag eq 'a' ) {
        while ( my ( $key, $val ) = each %attr ) {
            $key =~ s/^[^:]*?://sm;
            if ( $key eq 'href' ) {
                if ( index( $val, q{#} ) == 0 ) {
                    push @href, $val;
                    last;
                }
            }
        }
    }
}

# ------------------------------------------------------------------------------
sub handle_end {

    pop @current_tag;
}

# ------------------------------------------------------------------------------
sub handle_char {

    my ( undef, $text ) = @_;

    if ( $text && $current_tag[-1] && exists $TEXT_TAGS{ $current_tag[-1] } ) {
        $all_chars += length $text;
        $text      =~ s/\s+//gsm;
        $chars     += length $text;
    }
}

# -----------------------------------------------------------------------------
# That's All, Folks!
# -----------------------------------------------------------------------------