File Coverage

blib/lib/SeeAlso/Response.pm

Criterion	Covered	Total	%
statement	153	191	80.1
branch	50	74	67.5
condition	23	45	51.1
subroutine	27	31	87.1
pod	18	19	94.7
total	271	360	75.2

use strict;
use warnings;
package SeeAlso::Response;
{
  $SeeAlso::Response::VERSION = '0.71';
}
#ABSTRACT: SeeAlso Simple Response

use JSON::XS qw(encode_json);
use Data::Validate::URI qw(is_uri);
use Text::CSV;
use SeeAlso::Identifier;
use Carp;

use overload (
    '""'   => sub { $_[0]->as_string },
    'bool' => sub { $_[0]->size or $_[0]->query }
);


sub new {
    my $this = shift;

    my $class = ref($this) || $this;
    my $self = bless {
        'labels' => [],
        'descriptions' => [],
        'uris' => []
    }, $class;

    $self->set( @_ );

    return $self;
}


sub set {
    my ($self, $query, $labels, $descriptions, $uris) = @_;

    $self->query( $query );

    if (defined $labels) {
        croak ("four parameters expected in SeeAlso::Response->new")
            unless ref($labels) eq "ARRAY"
                and defined $descriptions and ref($descriptions) eq "ARRAY"
                and defined $uris and ref($uris) eq "ARRAY";
        my $l = @{$labels};
        croak ("length of arguments to SeeAlso::Response->new differ")
            unless @{$descriptions} == $l and @{$uris} == $l;

        $self->{labels} = [];
        $self->{descriptions} = [];
        $self->{uris} = [];

        for (my $i=0; $i < @{$labels}; $i++) {
            $self->add($$labels[$i], $$descriptions[$i], $$uris[$i]);
        }
    }

    return $self;
}


sub add {
    my ($self, $label, $description, $uri) = @_;

    $label = defined $label ? "$label" : "";
    $description = defined $description ? "$description" : "";
    $uri = defined $uri ? "$uri" : "";
    if ( $uri ne "" ) {
      croak("irregular response URI")
          unless $uri =~ /^[a-z][a-z0-9.+\-]*:/i;
    }

    return $self unless $label ne "" or $description ne "" or $uri ne "";

    push @{ $self->{labels} }, $label;
    push @{ $self->{descriptions} }, $description;
    push @{ $self->{uris} }, $uri;

    return $self;
}


sub size {
    my $self = shift;
    return scalar @{$self->{labels}};
}


sub get {
    my ($self, $index) = @_;
    return unless defined $index and $index >= 0 and $index < $self->size();

    my $label =       $self->{labels}->[$index];
    my $description = $self->{descriptions}->[$index];
    my $uri =         $self->{uris}->[$index];

    return ($label, $description, $uri);
}


sub query {
    my $self = shift;
    if ( scalar @_ ) {
        my $query = shift;
        $query = SeeAlso::Identifier->new( $query )
            unless UNIVERSAL::isa( $query, 'SeeAlso::Identifier' );
        $self->{query} = $query;
    }
    return $self->{query};
}


*identifier = *query;


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


sub descriptions {
    my $self = shift;
    return ( @{ $self->{descriptions} } );
}


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


sub toJSON {
    my ($self, $callback, $json) = @_;

    my $response = [
        $self->{query}->as_string,
        $self->{labels},
        $self->{descriptions},
        $self->{uris}
    ];

    return _JSON( $response, $callback, $json );
}


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


sub fromJSON {
    my ($self, $jsonstring) = @_;
    my $json = JSON::XS->new->decode($jsonstring);

    croak("SeeAlso response format must be array of size 4")
        unless ref($json) eq "ARRAY" and @{$json} == 4;

    if (ref($self)) { # call as method
        $self->set( @{$json} );
        return $self;
    } else { # call as constructor
        return SeeAlso::Response->new( @{$json} );
    }
}


sub toCSV {
    my ($self, $headers) = @_;
    my $csv = Text::CSV->new( { binary => 1, always_quote => 1 } );
    my @lines;
    for(my $i=0; $i<$self->size(); $i++) {
        my $status = $csv->combine ( $self->get($i) ); # TODO: handle error status
        push @lines, $csv->string();
    }
    return join ("\n", @lines);
}


sub toBEACON {
    my ($self, $beacon) = @_;
    my @lines;
    my $query = $self->query;
    $query =~ s/[|\n]//g;

    #$this->meta('TARGET')

    for(my $i=0; $i<$self->size(); $i++) {
        ## no critic
        my ($label, $description, $url) = map { s/[|\n]//g; $_; } $self->get($i);
        ## use critic
        my @line = ($query);

        # TODO: remove url, if #TARGET is given

        if ( is_uri( $url ) ) { # may skip label/description
            push @line, $label unless $label eq "" and $description eq "";
            push @line, $description unless $description eq "";
            push @line, $url;
        } else { # no uri
        #if ($url eq "") {
            # TODO: add only if no empty
            push @line, $label;
        #} else {
           # TODO
          # push @line, $label, $description, $url;
            push @line, $description unless $description eq "" and $url eq "";
            push @line, $url unless $url eq "";
        }
        #if ($label != "")
        push @lines, join('|',@line);
    }
    return join ("\n", @lines);
}


sub toRDF {
    my ($self) = @_;
    my $subject = $self->query;
    return { } unless is_uri( $subject->as_string );
    my $values = { };

    for(my $i=0; $i<$self->size(); $i++) {
        my ($label, $predicate, $object) = $self->get($i);
        next unless is_uri($predicate); # TODO: use rdfs:label as default?

        if ($object) {
            next unless is_uri($object);
            $object = { "value" => $object, 'type' => 'uri' };
        } else {
            $object = { "value" => $label, 'type' => 'literal' };
        }

        if ($values->{$predicate}) {
            push @{ $values->{$predicate} }, $object;
        } else {
            $values->{$predicate} = [ $object ];
        }
    }

    return {
        $subject => $values
    };
}


sub toRDFJSON {
    my ($self, $callback, $json) = @_;
    return _JSON( $self->toRDF, $callback, $json );
}


sub toRDFXML {
    my ($self) = @_;
    my ($subject, $values) = %{$self->toRDF};

    my @xml = ('');
    # TODO: $subject => $values
    push @xml, '';
    push @xml, '';
    foreach my $predicate (%{$values}) {
        # TODO
        #
        # $literal
    }
    push @xml, '';
    push @xml, '';

    return join("\n", @xml) . "\n";
}


sub toN3 {
    my ($self) = @_;
    return "" unless $self->size();
    my $rdf = $self->toRDF();
    my ($subject, $values) = %$rdf;
    return "" unless $subject && %$values;
    my @lines;

    foreach my $predicate (keys %$values) {
        my @objects = @{$values->{$predicate}};
        if ($predicate eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#type') {
            $predicate = 'a';
        } elsif ($predicate eq 'http://www.w3.org/2002/07/owl#sameAs') {
            $predicate = '=';
        } else {
            $predicate =  "<$predicate>";
        }
        @objects = map {
            my $object = $_;
            if ($object->{type} eq 'uri') {
                '<' . $object->{value} . '>';
            } else {
                _escape( $object->{value} );
            }
        } @objects;
        if (@objects > 1) {
            push @lines, (" $predicate\n    " . join(" ,\n    ", @objects) );
        } else {
            push @lines, " $predicate " . $objects[0];
        }
    }

    my $n3 = "<$subject>";
    if (@lines > 1) {
        return "$n3\n " . join(" ;\n ",@lines) . " .";
    } else {
        return $n3 . $lines[0] . " .";
    }
}


sub toRedirect {
    my ($self, $default) = @_;
    my ($a,$b,$url) = $self->get(0);
    $url = $default unless $url;
    return unless $url;

    return <
Status: 302 Found
Location: $url
URI: <$url>
Content-type: text/html


HTTP
}


my %ESCAPED = (
    "\t" => 't',
    "\n" => 'n',
    "\r" => 'r',
    "\"" => '"',
    "\\" => '\\',
);


sub _escape {
    local $_ = $_[0];
    s/([\t\n\r\"\\])/\\$ESCAPED{$1}/sg;
    return '"' . $_  . '"';
}


sub _JSON {
    my ($object, $callback, $JSON) = @_;

    croak ("Invalid callback name")
        if ( $callback and !($callback =~ /^[a-z][a-z0-9._\[\]]*$/i));

    # TODO: change this behaviour (no UTF-8) ?
    $JSON = JSON::XS->new->utf8(0) unless $JSON;

    my $jsonstring = $JSON->encode($object);

    return $callback ? "$callback($jsonstring);" : $jsonstring;
}

1;

__END__