File Coverage

blib/lib/RDF/NS.pm

Criterion	Covered	Total	%
statement	126	149	84.5
branch	59	90	65.5
condition	14	20	70.0
subroutine	35	36	97.2
pod	14	20	70.0
total	248	315	78.7

package RDF::NS;
use v5.10;
use strict;
use warnings;

our $VERSION = '20181102';

use Scalar::Util qw(blessed reftype);
use File::ShareDir;
use Carp;
use RDF::SN;

our $AUTOLOAD;
our $FORMATS = qr/ttl|n(otation)?3|sparql|xmlns|txt|beacon|json/;

our $DATE_REGEXP = qr/^([0-9]{4})-?([0-9][0-9])-?([0-9][0-9])$/;

sub new {
    my $class = ref($_[0]) ? ref(shift) : shift;
    my $from  = @_ % 2 ? shift : 1;
    my %options = @_;
    my $at   = $options{at} || 'any';
    my $warn = $options{'warn'};
    $from = $options{from} if exists $options{from};
    $from = 'any' if !$from or $from eq 1;

    if ((ref($from) || '') eq 'HASH') {
        my $self = bless $from, $class;
        foreach my $prefix (keys %$self) {
            unless( $self->SET( $prefix => $self->{$prefix}, $warn ) ) {
                delete $self->{$prefix};
            }
        }
        return $self;
    }

    if ( $from =~ $DATE_REGEXP ) {
        $at   = "$1$2$3";
        $from = 'any';
    } elsif( $at =~ $DATE_REGEXP ) {
        $at   = "$1$2$3";
    } elsif ( $at !~ 'any' ) {
        croak "RDF::NS expects 'any', '1' or a date as YYYY-MM-DD";
    }

    my $self = bless { }, $class;
    my $fh = $self->DATA($from);
    foreach (<$fh>) {
        chomp;
        next if /^#/;
        my ($prefix, $namespace, $date) = split "\t", $_;
		  next if ($namespace =~ m|^https?://example\.\w+?/|);
        last if $date and $at ne 'any' and $date > $at;

        $self->SET( $prefix => $namespace, $warn );
    }
    close($fh);

    $self;
}

sub DATA { # TODO: document
    my ($self, $from) = @_;
    $from = File::ShareDir::dist_file('RDF-NS', "prefix.cc" )
        if ($from // 'any') eq 'any';
    croak "prefix file or date not found: $from"
        unless -f $from;
    open (my $fh, '<', $from) or croak "failed to open $from";
    $fh;
}

sub SET {
    my ($self, $prefix, $namespace, $warn) = @_;

    if ( $prefix =~ /^(isa|can|new|uri)$/ ) {
        carp "Cannot support prefix '$prefix'" if $warn;
    } elsif ( $prefix =~ /^[a-z][a-z0-9]*$/ ) {
        if ( $namespace =~ /^[a-z][a-z0-9]*:[^"<>]*$/ ) {
            $self->{$prefix} = $namespace;
            return 1;
        } elsif( $warn ) {
            carp "Skipping invalid $prefix namespace $namespace";
        }
    } elsif ( $warn ) {
        carp "Skipping unusual prefix '$prefix'";
    }

    return;
}

*LOAD = *new;

sub COUNT {
    scalar keys %{$_[0]};
}

sub FORMAT {
    my $self = shift;
    my $format = shift || "";
    $format = 'TTL' if $format =~ /^n(otation)?3$/i;
    if (lc($format) =~ $FORMATS) {
        $format = uc($format);
        $self->$format( @_ );
    } elsif ($format eq "") {
        $self->MAP( sub { $self->{$_} } , @_ );
    }
}

sub PREFIX {
    my ($self, $uri) = @_;
    foreach my $prefix ( sort keys %$self ) {
        return $prefix if $uri eq $self->{$prefix};
    }
    return;
}

sub PREFIXES {
    my ($self, $uri) = @_;
    my @prefixes;
    while ( my ($prefix, $namespace) = each %$self ) {
        push @prefixes, $prefix if $uri eq $namespace;
    }
    return(sort(@prefixes));
}

sub REVERSE {
    RDF::SN->new($_[0]);
}

sub TTL {
    my $self = shift;
    $self->MAP( sub { "\@prefix $_: <".$self->{$_}."> ." } , @_ );
}

sub SPARQL {
    my $self = shift;
    $self->MAP( sub { "PREFIX $_: <".$self->{$_}.">" } , @_ );
}

sub XMLNS {
    my $self = shift;
    $self->MAP( sub { "xmlns:$_=\"".$self->{$_}."\"" } , @_ );
}

sub TXT {
    my $self = shift;
    $self->MAP( sub { "$_\t".$self->{$_} } , @_ );
}

sub JSON {
    my $self = shift;
    $self->MAP( sub { "\"$_\": \"".$self->{$_}."\"" } , @_ );
}

sub BEACON {
    my $self = shift;
    $self->MAP( sub { "#PREFIX: ".$self->{$_} } , @_ );
}

sub SELECT {
    my $self = shift;
    $self->MAP( sub { $_ => $self->{$_} } , @_ );
}

# functional programming rulez!
sub MAP {
    my $self = shift;
    my $code = shift;
    my @ns = @_ ? (grep { $self->{$_} } map { split /[|, ]+/ } @_)
        : keys %$self;
    if (wantarray) {
        return map { $code->() } sort @ns;
    } else {
        local $_ = $ns[0];
        return $code->();
    }
}

sub GET {
    $_[1];
}

sub BLANK {
}

*URI = *uri;

sub uri {
    my $self = shift;
    return $1 if $_[0] =~ /^<([a-zA-Z][a-zA-Z+.-]*:.+)>$/;
    return $self->BLANK($_[0]) if $_[0] =~ /^_(:.*)?$/;
    return unless shift =~ /^([a-z][a-z0-9]*)?([:_]([^:]+))?$/;
    my $ns = $self->{ defined $1 ? $1 : '' };
    return unless defined $ns;
    return $self->GET($ns) unless $3;
    return $self->GET($ns.$3);
}

sub AUTOLOAD {
    my $self = shift;
    return unless $AUTOLOAD =~ /^.*::([a-z][a-z0-9]*)?(_([^:]+)?)?$/;
    return $self->BLANK( defined $3 ? "_:$3" : '_' ) unless $1;
    my $ns = $self->{$1} or return;
    my $local = defined $3 ? $3 : shift;
    return $self->GET($ns) unless defined $local;
    return $self->GET($ns.$local);
}

sub UPDATE {
    my ($self, $file, $date) = @_;

    croak "RDF::NS expects a date as YYYY-MM-DD"
        unless $date and $date =~ $DATE_REGEXP;
    $date = "$1$2$3";

    my $old = RDF::NS->new($file);
    my (@create,@update,@delete);

    open (my $fh, '>>', $file) or croak "failed to open $file";
    my @lines;

    while( my ($prefix,$namespace) = each %$self ) {
        if (!exists $old->{$prefix}) {
            push @create, $prefix;
        } elsif ( $old->{$prefix} ne $namespace ) {
            push @update, $prefix;
        } else {
            next;
        }
        push @lines, "$prefix\t$namespace";
    }
    while( my ($prefix,$namespace) = each %$old ) {
        if (!exists $self->{$prefix}) {
            push @delete, $prefix;
        }
    }

    print $fh "$_\t$date\n" for sort @lines;
    close $fh;

    return {
        create => [ sort @create ],
        update => [ sort @update ],
        delete => [ sort @delete ],
    };
}

1;
__END__