File Coverage

blib/lib/DAIA/Availability.pm

Criterion	Covered	Total	%
statement	45	125	36.0
branch	6	86	6.9
condition	1	46	2.1
subroutine	10	15	66.6
pod	5	5	100.0
total	67	277	24.1

use strict;
use warnings;
package DAIA::Availability;
#ABSTRACT: Abstract base class of availability information
our $VERSION = '0.43'; #VERSION

use base 'DAIA::Object';

use Carp::Clan;
use Data::Validate::URI qw(is_uri);
use DateTime::Duration;
use DateTime::Format::Duration;

use DateTime;
use base 'Exporter';
our @EXPORT_OK = qw(parse_duration normalize_duration date_or_datetime);


our %PROPERTIES = (
    service => {
        # default => sub { croak 'DAIA::Availability->service is required'  },
        default => sub { undef }, # TODO: configure whether mandatory
        filter => sub {
            my $s = $_[0];
            return $s if $DAIA::Availability::SERVICES{$s};
            return $DAIA::Availability::SECIVRES{$s} if $DAIA::Availability::SECIVRES{$s};
            return $s if is_uri($s); return;
        }
    },
    href    => $DAIA::Object::COMMON_PROPERTIES{href},
    message => $DAIA::Object::COMMON_PROPERTIES{message},
    limitation => {
        type => 'DAIA::Limitation',
        repeatable => 1,
    }
);

# known services
our %SERVICES = (
    'presentation' => 'http://purl.org/ontology/daia/Service/Presentation',
    'loan'         => 'http://purl.org/ontology/daia/Service/Loan',
    'interloan'    => 'http://purl.org/ontology/daia/Service/Interloan',
    'openaccess'   => 'http://purl.org/ontology/daia/Service/Openaccess',
);

our %SECIVRES = (
    map { $SERVICES{$_} => $_ } keys %SERVICES
);


sub _buildargs {
    my $self = shift;
    my %args = ();

    if ( not (@_ % 2) ) { # even number
        %args = @_;
        if ( not defined $args{status} ) { # $service => $status
            foreach ( keys %DAIA::Availability::SERVICES ) {
                if ( defined $args{$_} ) {
                    $args{status} = $args{$_};
                    $args{service} = $_;
                    delete $args{$_};
                }
            }
        }
    } elsif ( @_ ) { # non empty, uneven number
        if ( @_ == 1 and UNIVERSAL::isa( $_[0], 'DAIA::Availability' ) ) {
            %args = %{ $_[0]->struct };
            $self = $_[0];
        } elsif ( $DAIA::Availability::SERVICES{$_[0]} or is_uri($_[0]) ) {
            %args = ( service => @_ );
        } else {
            croak( "could not parse parameters to " . ref($self) );
        }
    }

    if ( not defined $args{status} ) {
      if ( ref($self) eq 'DAIA::Available' ) {
          $args{status} = 1;
      } elsif ( ref($self) eq 'DAIA::Unavailable' ) {
          $args{status} = 0;
      }
    }

    return %args;
}


sub status {
    my $self = shift;
    my $class = ref($self);
    my $status;

    if ( @_ > 0 ) {
        $status = shift;
        if ( $status ) {
            if ( $class eq 'DAIA::Unavailable' ) {
                $self->expected( undef );
                $self->queue( undef );
            }
            bless $self, 'DAIA::Available';

        } else {
            if ( $class eq 'DAIA::Available' ) {
                $self->delay( undef );
            }
            bless $self, 'DAIA::Unavailable';
        }
    } else {
        $status = $class eq 'DAIA::Available';
    }

    return $status;
}

sub rdfhash {
    my $self = shift;
    my $me = { };

    my $servicetype = $DAIA::Availability::SERVICES{ $self->{service} }
        || $self->{service};

    $me->{'http://www.w3.org/1999/02/22-rdf-syntax-ns#type'} = [{
        value => $servicetype, type  => "uri"
    }] if $servicetype;

    $me->{'http://xmlns.com/foaf/0.1/page'} = [{
        value => $self->{href}, type => "uri"
    }] if $self->{href};

    $me->{'http://purl.org/dc/terms/description'} = [
        map { $_->rdfhash } @{$self->{message}}
    ] if $self->{message};

    $me->{'http://purl.org/ontology/daia/expected'} = [{
        value => $self->{expected}, type => 'literal',
        # xsd:date or xsd:dateTime to 'unknown'
    }] if $self->{expected};

    $me->{'http://purl.org/ontology/daia/delay'} = [{
        value => $self->{delay}, type => 'literal',
        # TODO: how to treat delay = "unknown"?
        # datatype => 'http://www.w3.org/2001/XMLSchema#duration',
    }] if $self->{delay};

    $me->{'http://purl.org/ontology/daia/delay'} = [{
        value => $self->{queue}, type => 'literal',
        datatype => 'http://www.w3.org/2001/XMLSchema#integer',
    }] if defined $self->{queue};

    if ($self->{limitation}) {
        # TODO
        # some limitations may be literal, some may be uri/blank
        # 'limitedBy'
    }

    my $rdf = { };

    $rdf->{ $self->rdfuri } = $me;

    return $rdf;
}


sub parse_duration {
    return $_[0] if UNIVERSAL::isa( $_[0], 'DateTime::Duration' );
    my $duration = "$_[0]";

    my ($neg, $year, $mounth, $day, $hour, $min, $sec, $fsec);
    if ($duration =~ /^(-)?
                      P
                      ((\d+)Y)?
                      ((\d+)M)?
                      ((\d+)D)?
                      (
                      T
                      ((\d+)H)?
                      ((\d+)M)?
                      (((\d+)(\.(\d+))?)S)?
                      )?
                    $/x) {
        ($neg, $year, $mounth, $day, $hour, $min, $sec, $fsec) =
        ($1,   $3,    $5,      $7,   $10,   $12,  $15,  $17);
        return unless (grep {defined} ($year, $mounth, $day, $hour, $min, $sec));
    } else {
        return;
    }
    $duration = DateTime::Duration->new(
      years   => $year || 0,
      months  => $mounth || 0,
      days    => $day || 0,
      hours   => $hour || 0,
      minutes => $min || 0,
      seconds => $sec || 0,
      nanoseconds => ($fsec ? "0.$fsec" * 1E9  : 0),
    );
    $duration = $duration->inverse if $neg;
    return $duration;
}


sub normalize_duration {
    my $duration = $_[0];
    $duration = parse_duration( $duration )
        unless UNIVERSAL::isa( $duration, 'DateTime::Duration' );
    return unless defined $duration;

    return "P0D" if $duration->is_zero;

    # TODO: replace this
    my $fmt = DateTime::Format::Duration->new(
          pattern => '%PP%YY%mM%dDT%HH%MM%S.%NS',
          normalize => 1,
    );

    my %d = $fmt->normalize( $duration );
    if (exists $d{seconds} or exists $d{nanoseconds}) {
        $d{seconds} = ($d{seconds} || 0)
                    + (exists $d{nanoseconds} ? $d{nanoseconds} / 1E9 : 0);
    }
    my $str = $d{negative} ? "-P" : "P";
    $str .= "$d{years}Y" if exists $d{years} and $d{years} > 0;
    $str .= "$d{months}M" if exists $d{months} and $d{months} > 0;
    $str .= "$d{days}D" if exists $d{days} and $d{days} > 0;
    $str .= "T" if grep {exists $d{$_} and $d{$_} > 0} qw(hours minutes seconds);
    $str .= "$d{hours}H" if exists $d{hours} and $d{hours} > 0;
    $str .= "$d{minutes}M" if exists $d{minutes} and $d{minutes} > 0;
    $str .= "$d{seconds}S" if exists $d{seconds} and $d{seconds} > 0;

    return $str;
}


sub date_or_datetime {
    my $dt = $_[0];
    if ( not UNIVERSAL::isa( $dt, 'DateTime' ) ) {
        return unless
            $dt =~ /^(-?\d\d\d\d+-\d\d-\d\d)(T\d\d:\d\d:\d\d(\.\d+)?)?([+-]\d\d:\d\d|Z)?$/;
        my ($date,$time,$tz) = ($1,$2,$4);
        $date =~ /(-?\d\d\d\d+)-(\d\d)-(\d\d)/;
        my %p = (year=>$1,month=>$2,day=>$3);
        if ($time) {
            $time =~ /T(\d\d):(\d\d):(\d\d)(\.\d+)?/;
            ($p{hour},$p{minute},$p{second})=($1,$2,$3);
        }
        if ($tz) {
            $tz =~ s/://; $tz =~ s/Z/UTC/;
            $p{time_zone} = $tz;
        }
        $dt = eval { DateTime->new(%p) } || return;
    }
    $dt->set_time_zone('floating');

    my $date = $dt->strftime("%FT%T");
    $dt =~ s/T00:00:00$//; # remove time part if is zero
    return $dt;
}

1;

__END__