File Coverage

blib/lib/RDF/NS.pm

Criterion	Covered	Total	%
statement	125	148	84.4
branch	57	88	64.7
condition	14	20	70.0
subroutine	35	36	97.2
pod	14	20	70.0
total	245	312	78.5

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

our $VERSION = '20230619';

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", $_;
        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__