Парсинг XML - V

xml-fast.pl

#!/usr/bin/perl

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

# ------------------------------------------------------------------------------
const my %TEXT_TAGS => (
    emphasis => 1,
    strong   => 1,
    subtitle => 1,
    v        => 1,
    p        => 1,
    a        => 1,
);
const my $TEXT      => q{~};

my $fast = xml2hash( read_file( @ARGV ? $ARGV[0] : 'test.xml' ), text => $TEXT, trim => 0 );

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

walk_nodes($fast);

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;

# ------------------------------------------------------------------------------
sub walk_nodes {

    my ( $node, $nodename ) = @_;

    $nodename //= q{?};

    if ( ref $node eq 'ARRAY' ) {
        walk_nodes( $_, $nodename ) for @{$node};
        return;
    }

    if ( !ref $node ) {
        return _process_text( $nodename, $node );
    }

    return unless ref $node eq 'HASH';

    while ( my ( $tag, $data ) = each %{$node} ) {

        next unless $data;

        if( $tag eq $TEXT ) {
            _process_text( $nodename, $data );
            next;
        }

        if ( ref $data  ) {

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

            walk_nodes( $data, $tag );
            next;
        }

        if ( exists $TEXT_TAGS{$tag} ) {
            $all_chars += length $data;
            $data      =~ s/\s+//gsm;
            $chars     += length $data;
        }

        $id{ q{#} . $data } = 1 if $tag eq '-id';

        if( $nodename eq q{a} ) {
            $tag =~ s/^[^:]*://sm;
            if ( $tag eq 'href' ) {
                if ( index( $data, q{#} ) == 0 ) {
                    push @href, $data;
                }
            }
        }
    }
    return;
}

# -----------------------------------------------------------------------------
sub _process_text {

    my ( $nodename, $data ) = @_;

    if ( exists $TEXT_TAGS{$nodename} ) {

        my $text;
        if( ref $data eq 'ARRAY' ) {
            $text = join q{''}, @{$data};
        }
        else {
            $text = $data;
        }
        if ( $text ) {
            $all_chars += length $text;
            $text      =~ s/\s+//gsm;
            $chars     += length $text;
        }
    }
    return;
}

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