File Coverage

blib/lib/TBX/Min.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#
# This file is part of TBX-Min
#
# This software is copyright (c) 2016 by Alan Melby.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package TBX::Min;
use strict;
use warnings;
our $VERSION = '0.08'; # VERSION
# ABSTRACT: Read, write and edit TBX-Min files
use subs qw(date_created directionality entries);
use Class::Tiny qw(
    id
    description
    creator
    license
    source_lang
    target_lang
    date_created
    directionality
    entries
);
use XML::Twig;
use autodie;
use Path::Tiny;
use Carp;
use Import::Into;
use DateTime::Format::ISO8601;
use Try::Tiny;
use TBX::Min::TermEntry;
use TBX::Min::LangSet;
use TBX::Min::TIG;
use TBX::Min::NoteGrp;
use TBX::Min::Note;

# Use Import::Into to export subclasses into caller
sub import {
    my $target = caller;
    TBX::Min::TermEntry->import::into($target);
    TBX::Min::LangSet->import::into($target);
    TBX::Min::TIG->import::into($target);
    TBX::Min::NoteGrp->import::into($target);
    TBX::Min::Note->import::into($target);
    return;
}

sub new_from_xml {
    my ($class, $data) = @_;

    if(!$data){
        croak 'missing required data argument';
    }

    my $fh = _get_handle($data);

    # build a twig out of the input document
    my $twig = XML::Twig->new(
        output_encoding => 'UTF-8',
        # do_not_chain_handlers => 1, #can be important when things get complicated
        keep_spaces     => 0,

        # these store new entries, langSets and tigs
        start_tag_handlers => {
            termEntry => \&_termEntryStart,
            langSet => \&_langStart,	#langset
            tig => \&_termGrpStart, #tig
            noteGrp => \&_noteGrpStart, #note group
            note => \&_noteStart, #note
        },

        TwigHandlers    => {
            TBX => \&_check_dialect,
            # header attributes become attributes of the TBX::Min object
            id => \&_headerAtt,
            description => \&_headerAtt,
            dateCreated => \&_date_created,
            creator => \&_headerAtt,
            license => \&_headerAtt,
            directionality => \&_directionality,
            languages => \&_languages,

            # becomes part of the current TBX::Min::TermEntry object
            subjectField => sub {
                shift->{tbx_min_entries}->[-1]->subject_field($_->text)},

            # these become attributes of the current TBX::Min::TIG object
            term => sub {shift->{tbx_min_current_term_grp}->term($_->text)},
            partOfSpeech => sub {
                shift->{tbx_min_current_term_grp}->part_of_speech($_->text)},
            customer => sub {
                shift->{tbx_min_current_term_grp}->customer($_->text)},
            termStatus => sub {
                shift->{tbx_min_current_term_grp}->status($_->text)},

            # these become attributes of the current TBX::Min::Note object
			noteKey => sub {shift->{tbx_min_current_note}->noteKey($_->text)},
			noteValue => sub {shift->{tbx_min_current_note}->noteValue($_->text)},

            # delete the termEntry twig when finished to free up memory
            termEntry => sub {$_[0]->purge},
        }
    );

    # use handlers to process individual tags, then grab the result
    $twig->parse($fh);
    my $self = $twig->{tbx_min_att};
    $self->{entries} = $twig->{tbx_min_entries} || [];
    bless $self, $class;
    return $self;
}

sub _get_handle {
    my ($data) = @_;
    my $fh;
    if((ref $data) eq 'SCALAR'){
        open $fh, '<', $data; ## no critic(RequireBriefOpen)
    }else{
        $fh = path($data)->filehandle('<');
    }
    return $fh;
}


my %valid = map {+($_=>1)} Class::Tiny->get_all_attributes_for(__PACKAGE__);
sub new {
    my ($class, $args) = @_;
    my $self;
    if((ref $args) eq 'HASH'){

        # validate arguments
        if(my @invalids = grep {!$valid{$_}} sort keys %$args){
            croak 'Invalid attributes for class: ' .
                join ' ', @invalids
        }
        if($args->{entries} && ref $args->{entries} ne 'ARRAY'){
            croak q{Attribute 'entries' should be an array reference};
        }
        if(exists $args->{directionality}){
            _validate_dir($args->{directionality});
        }

        # validate datetime and store object, not string
        if(my $dt_string = $args->{date_created}){
            $args->{date_created} = _parse_datetime($dt_string);
        }

        $self = $args;
    }else{
        $self = {};
    }
    $self->{entries} ||= [];
    return bless $self, $class;
}

sub date_created {
    my ($self, $date_created) = @_;
    if($date_created) {
        return $self->{date_created} =
            _parse_datetime($date_created);
    }
    if(my $dt = $self->{date_created}){
        return $dt->iso8601;
    }
    return;
}

sub _parse_datetime {
    my ($dt_string) = @_;
    my $dt;
    try{
        $dt = DateTime::Format::ISO8601->parse_datetime($dt_string);
    }catch{
        croak 'date is not in ISO8601 format';
    };
    return $dt;
}

sub directionality {
    my ($self, $directionality) = @_;
    if(defined $directionality) {
        _validate_dir($directionality);
        return $self->{directionality} = $directionality;
    }
    return $self->{directionality};
}

sub _validate_dir {
    my ($dir) = @_;
    if($dir ne 'bidirectional' and $dir ne 'monodirectional'){
        croak "Illegal directionality '$dir'";
    }
    return;
}

sub entries { ## no critic(RequireArgUnpacking)
    my ($self) = @_;
    if (@_ > 1){
        croak 'extra argument found (entries is a getter only)';
    }
    return $self->{entries};
}

sub add_entry {
    my ($self, $termEntry) = @_;
    if( !$termEntry || !$termEntry->isa('TBX::Min::TermEntry') ){
        croak 'argument to add_entry should be a TBx::Min::TermEntry';
    }
    push @{$self->{entries}}, $termEntry;
    return;
}

sub as_xml {
    my ($self) = @_;

    # construct the whole document using XML::Twig::El's
    my $root = XML::Twig::Elt->new(TBX => {dialect => 'TBX-Min'});
    my $header = XML::Twig::Elt->new('header')->paste($root);

    # each of these header elements is a simple element with text
    for my $header_att (
            qw(id creator license directionality description)){
        next unless $self->{$header_att};
        XML::Twig::Elt->new($header_att,
            $self->{$header_att})->paste(last_child => $header);
    }
    if($self->source_lang || $self->target_lang){
        my @atts;
        push @atts, (source => $self->source_lang) if $self->source_lang;
        push @atts, (target => $self->target_lang) if $self->target_lang;
        XML::Twig::Elt->new(languages => {@atts})->paste(
            last_child => $header)
    }
    if(my $dt = $self->{date_created}){
        XML::Twig::Elt->new(dateCreated => $dt->iso8601)->paste(
            last_child => $header);
    }

    my $body = XML::Twig::Elt->new('body')->paste(last_child => $root);
    for my $termEntry (@{$self->entries}){
        my $entry_el = XML::Twig::Elt->new(
            termEntry => {$termEntry->id ? (id => $termEntry->id) : ()})->
            paste(last_child => $body);
        XML::Twig::Elt->new( '#COMMENT', 'terminological entry')->
            paste(last_child => $entry_el);
        if(my $sf = $termEntry->subject_field){
            XML::Twig::Elt->new(subjectField => $sf)->paste(
                last_child => $entry_el);
        }
        for my $langGrp (@{$termEntry->lang_groups}){
            my $lang_el = XML::Twig::Elt->new(langSet =>
                {$langGrp->code ? ('xml:lang' => $langGrp->code) : ()}
            )->paste(last_child => $entry_el);
            for my $termGrp (@{$langGrp->term_groups}){
                my $term_el = XML::Twig::Elt->new('tig')->paste(
                    last_child => $lang_el);
                XML::Twig::Elt->new( '#COMMENT', 'terminological information group')->
					paste(last_child => $term_el);
                if (my $term = $termGrp->term){
                    XML::Twig::Elt->new(term => $term)->paste(
                        last_child => $term_el);
                }

                if (my $customer = $termGrp->customer){
                    XML::Twig::Elt->new(customer => $customer)->paste(
                        last_child => $term_el);
                }

				for my $noteGrp (@{$termGrp->note_groups}){
					my $note_grp_el = XML::Twig::Elt->new('noteGrp')->paste(
                    last_child => $term_el);

					for my $note (@{$noteGrp->notes}){
						my $note_el = XML::Twig::Elt->new('note')->paste(
                    last_child => $note_grp_el);

						if (my $noteKey = $note->noteKey){
							XML::Twig::Elt->new(noteKey => $noteKey)->paste(
								last_child => $note_el);
						}

						if (my $noteValue = $note->noteValue){
							XML::Twig::Elt->new(noteValue => $noteValue)->paste(
								last_child => $note_el);
						}

					}
                }

                if (my $status = $termGrp->status){
                    XML::Twig::Elt->new(termStatus => $status )->paste(
                        last_child => $term_el);
                }

                if (my $pos = $termGrp->part_of_speech){
                    XML::Twig::Elt->new(partOfSpeech => $pos)->paste(
                        last_child => $term_el);
                }

            } # end tig
        } # end langSet
    } # end termEntry

    # return pretty-printed string
    XML::Twig->set_pretty_print('indented');
    my $TBXmin = \$root->sprint;
	$$TBXmin =~ s/>[\s\t\n]*