File Coverage

blib/lib/Data/Beacon.pm

Criterion	Covered	Total	%
statement	80	373	21.4
branch	20	240	8.3
condition	5	65	7.6
subroutine	16	35	45.7
pod	17	17	100.0
total	138	730	18.9

use strict;
use warnings;
package Data::Beacon;
#ABSTRACT: BEACON format validating parser and serializer
our $VERSION = '0.3.1'; #VERSION

use 5.008;
use Time::Piece;
use Scalar::Util qw(blessed);
use URI::Escape;
use Carp;

use base 'Exporter';
our @EXPORT = qw(plainbeaconlink beacon);


sub new {
    my $class = shift;
    my $self = bless { }, $class;
    $self->_initparams( @_ );
    $self->_startparsing;
    return $self;
}


sub meta { # TODO: document meta fields
    my $self = shift;
    return %{$self->{meta}} unless @_;

    if (@_ == 1) {
        my $key = uc(shift @_);
        $key =~ s/^\s+|\s+$//g;
        return $self->{meta}->{$key};
    }

    croak('Wrong number of arguments in SeeAlso::Beacon->meta') if @_ % 2;

    my %list = (@_);
    foreach my $key (keys %list) {
        croak('invalid meta name: "'.$key.'"')
            unless $key =~ /^\s*([a-zA-Z_-]+)\s*$/;
        my $value = $list{$key};
        $key = uc($1);
        if ( defined $value ) {
            $value =~ s/^\s+|\s+$|\n//g;
        } else {
            $value = '';
        }
        if ($value eq '') { # empty field: unset
            croak 'You cannot unset meta field #FORMAT' if $key eq 'FORMAT';
            delete $self->{meta}->{$key};
        } else { # check format of known meta fields
            if ($key eq 'TARGET') {
                $value =~ s/{id}/{ID}/g;
                # TODO: document that {ID} in target is optional (will be appended)
                $value .= '{ID}' unless $value =~ /{ID}}/;
                my $uri = $value;
                $uri =~ s/{ID}//g;
                croak 'Invalid #TARGET field: must be an URI pattern'
                    unless _is_uri($uri);
            } elsif ($key eq 'FEED') {
                croak 'FEED meta value must be a HTTP/HTTPS URL'
                    unless $value =~
  /^http(s)?:\/\/[a-z0-9-]+(.[a-z0-9-]+)*(:[0-9]+)?(\/[^#|]*)?(\?[^#|]*)?$/i;
            } elsif ($key eq 'PREFIX') {
                croak 'PREFIX meta value must be a URI'
                    unless _is_uri($value);
            } elsif ( $key =~ /^(REVISIT|TIMESTAMP)$/) {
                if ($value =~ /^[0-9]+$/) { # seconds since epoch
                    $value = gmtime($value)->datetime() . 'Z';
                    # Note that this conversion does not trigger an error
                    # or warning, but may be dropped in a future version
                } else {
                    # ISO 8601 combined date and time in UTC
                    $value =~ s/Z$//;
                    croak $key . ' meta value must be of form YYYY-MM-DDTHH:MM:SSZ'
                        unless $value = Time::Piece->strptime(
                            $value, '%Y-%m-%dT%T' );
                    $value = $value->datetime();
                }
            } elsif ( $key eq 'FORMAT' ) {
                croak 'Invalid FORMAT, must be BEACON or end with -BEACON'
                    unless $value =~ /^([A-Z]+-)?BEACON$/;
            } elsif ( $key eq 'EXAMPLES' ) {
                my @examples = map { s/^\s+|\s+$//g; $_ } split '\|', $value;
                $self->{examples} = [ grep { $_ ne '' } @examples ];
                %{$self->{expected_examples}} =
                    map { $_ => 1 } @{$self->{examples}};
                $value = join '|', @{$self->{examples}};
                if ($value eq '') { # yet another edge case: "EXAMPLES: |" etc.
                    delete $self->{meta}->{EXAMPLES};
                    $self->{expected_examples} = undef;
                    next;
                }
                # Note that examples are not checked for validity,
                # because PREFIX may not be set yet.
            }
            $self->{meta}->{$key} = $value;
        }
    }
}


sub count {
    my $count = $_[0]->meta('COUNT');
    return defined $count ? $count : 0;
}


sub line {
    return $_[0]->{line};
}


sub lasterror {
    return wantarray ? @{$_[0]->{lasterror}} : $_[0]->{lasterror}->[0];
}


sub errors {
    return $_[0]->{errors};
}


sub metafields {
    my $self = shift;
    my %meta = $self->meta();
    my %fields = %meta;

    # determine default order
    my @order = (qw(FORMAT PREFIX TARGET MESSAGE RELATION ANNOTATION),
        qw(DESCRIPTION CREATOR CONTACT HOMEPAGE FEED TIMESTAMP UPDATE),
        qw(SOURCESET TARGETSET NAME INSTITUTION));

    my @lines = map { "#$_: " . $meta{$_} } grep { defined $meta{$_} } @order;
    return @lines ? join ("\n", @lines) . "\n" : "";
}


sub parse {
    my $self = shift;

    $self->_initparams( @_ );
    $self->_startparsing if defined $self->{from}; # start from new source

    my $line = $self->{lookaheadline};
    $line = $self->_readline() unless defined $line;

    while (defined $line) {
        $self->appendline( $line );
        $line = $self->_readline();
    }

    return $self->errors == 0;
}


sub nextlink {
    my $self = shift;

    my $line = $self->{lookaheadline};
    if (defined $line) {
        $self->{lookaheadline} = undef;
    } else {
        $line = $self->_readline();
        return unless defined $line; # undef => EOF
    }

    do {
        my @link = $self->appendline( $line );
        return @link if @link; # proceed on empty lines or errors
    } while($line = $self->_readline());

    return; # EOF
}


sub link {
    my $self = shift;
    return @{$self->{link}} if $self->{link};
}


sub expanded {
    my $self = shift;
    if ( $self->{link} ) {
        unless ( $self->{expanded} ) {
            @{$self->{expanded}} = @{$self->{link}};
            $self->_expandlink( $self->{expanded} )
        }
        return @{$self->{expanded}};
    }
}


sub expand {
    my $self = shift;

    my @fields = @_ > 0 ? @_ : '';
    @fields = map { s/^\s+|\s+$//g; $_ }
              map { defined $_ ? $_ : '' } @fields;

    return if $fields[0] eq '' or (grep { $_ =~ /\||\n|\r/ } @fields);

    $self->_expandlink( \@fields );

    return unless _is_uri($fields[0]) && _is_uri($fields[3]);

    return @fields;
}


sub expandsource {
    my ($self, $source) = @_;
    return '' unless defined $source;
    $source =~ s/^\s+|\s+$//g;
    return '' if $source eq '';

    $source = $self->{meta}->{PREFIX} . $source
        if defined $self->{meta}->{PREFIX};

    return _is_uri($source) ? $source : '';
}


sub appendline {
    my ($self, $line) = @_;
    return unless defined $line;
    chomp $line;

    $self->{line}++;
    $self->{currentline} = $line;
    my @parts = split ('\|',$line);

    return if (@parts < 1 || $parts[0] =~ /^\s*$/ );
    my $link = $self->_fields( @parts );

    my $has_link = $self->appendlink( @$link );

    $self->{currentline} = undef;

    if ( $has_link ) {
        return wantarray ? @{ $self->{link} } : 1;
    }

    return;
}


sub appendlink {
    my $self = shift;

    my @fields = map { defined $_ ? $_ : '' } @_[0..3];
    @fields = map { s/^\s+|\s+$//g; $_ } @fields;

    if ( $fields[0] eq '' ) {
        $self->_handle_error( 'missing source' );
        return;
    } elsif ( grep { $_ =~ /\|/ } @fields ) {
        $self->_handle_error( 'link fields must not contain \'|\'' );
        return;
    } elsif ( grep { $_ =~ /[\n\r]/ } @fields ) {
        $self->_handle_error( 'link fields must not contain line breaks' );
        return;
    }

    my $msg = $self->_checklink( @fields );
    if ( $msg ) {
        $self->_handle_error( $msg );
        return;
    }

    # finally got a valid link
    $self->{link} = \@fields;
    $self->{expanded} = undef;
    $self->{meta}->{COUNT}++;

    if ( defined $self->{expected_examples} ) { # examples may contain prefix
        my @idforms = $fields[0];
        my $prefix = $self->{meta}->{PREFIX};
        push @idforms, $prefix . $fields[0] if defined $prefix;
        foreach my $source (@idforms) {
            if ( $self->{expected_examples}->{$source} ) {
                delete $self->{expected_examples}->{$source};
                $self->{expected_examples} = undef
                    unless keys %{ $self->{expected_examples} };
            }
        }
    }

    if ( $self->{link_handler} ) {
        if ( $self->{link_handler} eq 'print' ) {
            print plainbeaconlink( @fields ) . "\n";
         } elsif ( $self->{link_handler} eq 'expand' ) {
            print join('|',$self->expanded) . "\n";
         } else {
            # TODO: call with expanded link on request
            eval { $self->{link_handler}->( @fields ); };
            if ( $@ ) {
                $self->_handle_error( "link handler died: $@" );
                return;
            }
        }
    }

    return @fields; # TODO: return expanded on request
}


sub beacon {
    return Data::Beacon->new( @_ );
}


sub plainbeaconlink {
    shift if ref($_[0]) and UNIVERSAL::isa($_[0],'Data::Beacon');
    return '' unless @_;
    my @link = map { defined $_ ? $_ : '' } @_[0..3];
    @link = map { s/^\s+|\s+$//g; $_; } @link;
    return '' if $link[0] eq '';

    if ( $link[3] eq '' ){
        pop @link;
        if ($link[2] eq '') {
            pop @link;
            pop @link if ($link[1] eq '');
        }
    } elsif ( _is_uri($link[3]) ) { # only position of _is_uri where argument may be undefined
        my $uri = pop @link;
        if ($link[2] eq '') {
           pop @link;
           pop @link if ($link[1] eq '');
        }
        push @link, $uri;
    }

    return join('|', @link);
}


sub _initparams {
    my $self = shift;
    my %param;

    if ( @_ % 2 && !blessed($_[0]) && ref($_[0]) && ref($_[0]) eq 'HASH' ) {
        my $pre = shift;
        %param = @_;
        $param{pre} = $pre;
    } else {
        $self->{from} = (@_ % 2) ? shift(@_) : undef;
        %param = @_;
    }

    $self->{from} = $param{from}
        if exists $param{from};

    if ( $param{errors} ) {
        my $handler = $param{errors};
        $handler = $Data::Beacon::ERROR_HANDLERS{lc($handler)}
        unless ref($handler);
        unless ( ref($handler) and ref($handler) eq 'CODE' ) {
            my $msg = 'error handler must be code or '
                    . join('/',keys %Data::Beacon::ERROR_HANDLERS)
                    . ', got '
                    . (defined $handler ? $handler : 'undef');
            croak $msg;
        }
        $self->{error_handler} = $handler;
    }

    if ( $param{links} ) {
        my $handler = $param{links};
        croak 'link handler must be code or \'print\' or \'expand\''
            unless $handler =~ /^(print|expand)$/
                or (ref($handler) and ref($handler) eq 'CODE');
        $self->{link_handler} = $handler;
    }

    if ( defined $param{pre} ) {
        croak "pre option must be a hash reference"
            unless ref($param{pre}) and ref($param{pre}) eq 'HASH';
        $self->{pre} = $param{pre};
    } elsif ( exists $param{pre} ) {
        $self->{pre} = undef;
    }

    $self->{mtime} = $param{mtime};
}


sub _startparsing {
    my $self = shift;

    # we do not init $self->{meta} because it is set in initparams;
    $self->{meta} = { 'FORMAT' => 'BEACON' };
    $self->meta( %{ $self->{pre} } ) if $self->{pre};
    $self->{line} = 0;
    $self->{link} = undef;
    $self->{expanded} = undef;
    $self->{errors} = 0;
    $self->{lasterror} = [];
    $self->{lookaheadline} = undef;
    $self->{fh} = undef;
    $self->{inputlines} = [];
    $self->{examples} = [];

    return unless defined $self->{from};

    # decide where to parse from
    my $type = ref($self->{from});
    if ($type) {
        if ($type eq 'SCALAR') {
            $self->{inputlines} = [ split("\n",${$self->{from}}) ];
        } elsif ($type ne 'CODE') {
            $self->_handle_error( "Unknown input $type" );
            return;
        }
    } elsif( $self->{from} eq '-' ) {
        $self->{fh} = \*STDIN;
    } else {
        if(!(open $self->{fh}, $self->{from})) {
            $self->_handle_error( 'Failed to open ' . $self->{from} );
            return;
        }
    }

    # initlialize TIMESTAMP
    if ($self->{mtime}) {
        my @stat = stat( $self->{from} );
        $self->meta('TIMESTAMP', gmtime( $stat[9] )->datetime() . 'Z' );
    }

    # start parsing
    my $line = $self->_readline();
    return unless defined $line;
    $line =~ s/^\xEF\xBB\xBF//; # UTF-8 BOM (optional)

    do {
        $line =~ s/^\s+|\s*\n?$//g;
        if ($line eq '') {
            $self->{line}++;
        } elsif ($line =~ /^#([^:=\s]+)(\s*[:=]?\s*|\s+)(.*)$/) {
            $self->{line}++;
            eval { $self->meta($1,$3); };
            if ($@) {
                my $msg = $@; $msg =~ s/ at .*$//;
                $self->_handle_error( $msg, $line );
            }
        } else {
            $self->{lookaheadline} = $line;
            return;
        }
        $line = $self->_readline();
    } while (defined $line);
}


sub _handle_error {
    my $self = shift;
    my $msg = shift;
    my $line = shift || $self->{currentline} || '';
    chomp $line;
    $self->{lasterror} = [ $msg, $self->{line}, $line ];
    $self->{errors}++;
    $self->{error_handler}->( $msg, $self->{line}, $line ) if $self->{error_handler};
}

our %ERROR_HANDLERS = (
    'print' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno ;
        print STDERR "$msg\n";
    },
    'warn' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno;
        carp $msg;
    },
    'die' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno;
        croak $msg;
    }
);


sub _readline {
    my $self = shift;
    if ($self->{fh}) {
        return eval { no warnings; readline $self->{fh} };
    } elsif (ref($self->{from}) && ref($self->{from}) eq 'CODE') {
        my $line = eval { $self->{from}->(); };
        if ($@) { # input handler died
            $self->_handle_error( $@, '' );
            $self->{from} = undef;
        }
        return $line;
    } else {
        return @{$self->{inputlines}} ? shift(@{$self->{inputlines}}) : undef;
    }
}


sub _fields {
    my $self = shift;
    my @parts = @_;

    my $n = scalar @parts;

    my $link = [shift @parts,"","",""];

    my $target = $self->{meta}->{TARGET};
    my $targetprefix = $self->{meta}->{TARGETPREFIX};
    if ($target or $targetprefix) {
        $link->[1] = shift @parts if @parts;
        $link->[2] = shift @parts if @parts;
        # TODO: do we want both #TARGET links and explicit links in one file?
        $link->[3] = shift @parts if @parts;
    } else {
        $link->[3] = pop @parts
            if ($n > 1 && _is_uri($parts[$n-2]));
        $link->[1] = shift @parts if @parts;
        $link->[2] = shift @parts if @parts;
    }

     return $link
}

sub _checklink {
    my ($self, @fields) = @_;

    my @exp = @fields;
    # TODO: check only - we don't need full expansion
    $self->_expandlink( \@exp );

    return "source is no URI: ".$exp[0]
        unless _is_uri($exp[0]);

    # TODO: we could encode bad characters etc.
    return "target is no URI: ".$exp[3]
        unless _is_uri($exp[3]);

    return undef;
}


sub _expandlink {
    my ($self, $link) = @_;

    my $prefix = $self->{meta}->{PREFIX};

    my $source = $link->[0];

    # TODO: document this expansion
    if ( $link->[1] =~ /^[0-9]*$/ ) { # if label is number (of hits) or empty
        my $label = $link->[1];
        my $descr = $link->[2];

        # TODO: handle zero hits
        my $msg = $self->{meta}->{$label eq '1' ? 'ONEMESSAGE' : 'SOMEMESSAGE'}
                || $self->{meta}->{'MESSAGE'};

        if ( defined $msg ) {
            _str_replace( $msg, '{id}', $link->[0] ); # unexpanded
            _str_replace( $msg, '{hits}', $link->[1] );
            _str_replace( $msg, '{label}', $link->[1] );
            _str_replace( $msg, '{description}', $link->[2] );
            _str_replace( $msg, '{target}', $link->[3] ); # unexpanded
        } else {
            $msg = $self->{meta}->{'NAME'} || $self->{meta}->{'INSTITUTION'};
        }
        if ( defined $msg && $msg ne '' ) {
            # if ( $link->[1] == "") $descr = $label;
            $link->[1] = $msg;
            $link->[1] =~ s/^\s+|\s+$//g;
            $link->[1] =~ s/\s+/ /g;
        }
    } else {
        _str_replace( $link->[1], '{id}', $link->[0] ); # unexpanded
        _str_replace( $link->[1], '{description}', $link->[2] );
        _str_replace( $link->[1], '{target}', $link->[3] ); # unexpanded
        # trim label, because it may have changed
        $link->[1] =~ s/^\s+|\s+$//g;
        $link->[1] =~ s/\s+/ /g;
    }

    # expand source
    $link->[0] = $prefix . $link->[0] if defined $prefix;

    # expand target
    my $target = $self->{meta}->{TARGET};
    my $targetprefix = $self->{meta}->{TARGETPREFIX};
    if (defined $target) {
        $link->[3] = $target;
        my $label = $link->[1];
        $link->[3] =~ s/{ID}/$source/g;
    } elsif( defined $targetprefix ) {
        $link->[3] = $targetprefix . $link->[3];
    }

    return @$link;
}

sub _str_replace {
    $_[0] =~ s/\Q$_[1]\E/$_[2]/g;
}


sub _is_uri {
    my $value = $_[0];

    return unless defined($value);

    # check for illegal characters
    return if $value =~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~\%]/i;

    # check for hex escapes that aren't complete
    return if $value =~ /%[^0-9a-f]/i;
    return if $value =~ /%[0-9a-f](:?[^0-9a-f]|$)/i;

    # split uri (from RFC 3986)
    my($scheme, $authority, $path, $query, $fragment)
      = $value =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;

    # scheme and path are required, though the path can be empty
    return unless (defined($scheme) && length($scheme) && defined($path));

    # if authority is present, the path must be empty or begin with a /
    if(defined($authority) && length($authority)){
        return unless(length($path) == 0 || $path =~ m!^/!);
    } else {
        # if authority is not present, the path must not start with //
        return if $path =~ m!^//!;
    }

    # scheme must begin with a letter, then consist of letters, digits, +, ., or -
    return unless lc($scheme) =~ m!^[a-z][a-z0-9\+\-\.]*$!;

    return 1;
}

1;

__END__