File Coverage

blib/lib/XML/Loy/XRD.pm

Criterion	Covered	Total	%
statement	168	172	97.6
branch	70	90	77.7
condition	13	16	81.2
subroutine	27	27	100.0
pod	9	9	100.0
total	287	314	91.4

package XML::Loy::XRD;
use strict;
use warnings;

use Mojo::JSON qw/encode_json decode_json/;
use Mojo::Util 'quote';
use Carp qw/carp/;
use XML::Loy::Date::RFC3339;

use XML::Loy with => (
  mime      => 'application/xrd+xml',
  namespace => 'http://docs.oasis-open.org/ns/xri/xrd-1.0',
  prefix    => 'xrd',
  on_init   => sub {
    shift->namespace(
      xsi => 'http://www.w3.org/2001/XMLSchema-instance'
    );
  }
);

our @CARP_NOT;

# Constructor
sub new {
  my $class = shift;

  my $xrd;

  # Empty
  unless ($_[0]) {
    unshift(@_, 'XRD');
    $xrd = $class->SUPER::new(@_);
  }

  # JRD
  elsif ($_[0] =~ /^\s*\{/) {
    $xrd = $class->SUPER::new('XRD');
    $xrd->_to_xml($_[0]);
  }

  # Whatever
  else {
    $xrd = $class->SUPER::new(@_);
  };

  return $xrd;
};


# Set subject
sub subject {
  my $self = $_[0]->type eq 'root' ?
    shift : shift->root;

  # Return subject
  unless ($_[0]) {

    # Subject found
    my $sub = $self->at('Subject') or return;
    return $sub->text;
  };

  my $new_node = $self->set(Subject => @_);

  # Set subject (only once)
  if (my $np = $self->at('*:root > *')) {

    # Put in correct order - maybe not effective
    my $clone = $self->at('Subject');

    $self->at('Subject')->remove;

    # return $np->prepend($clone);
    return $np->prepend($clone->to_string);
  };

  # Set subject
  return $new_node;
};


# Add alias
sub alias {
  my $self = $_[0]->type eq 'root' ?
    shift : shift->root;

  # Return subject
  unless ($_[0]) {

    # Subject found
    my $sub = $self->find('Alias') or return;
    return @{ $sub->map('text') };
  };

  # Add new alias
  $self->add(Alias => $_) foreach @_;

  return 1;
};


# Add Property
sub property {
  my $self = shift;

  return unless $_[0];

  my $type = shift;

  # Returns the first match
  return $self->at( qq{Property[type="$type"]} ) unless scalar @_ >= 1;

  # Get possible attributes
  my %hash = ($_[0] && ref $_[0] && ref $_[0] eq 'HASH') ? %{ shift(@_) } : ();

  # Set type
  $hash{type} = $type;

  # Set xsi:nil unless there is content
  $hash{'xsi:nil'} = 'true' unless $_[0];

  # Return element
  return $self->add(Property => \%hash => @_ );
};


# Add Link
sub link {
  my $self = shift;

  # No rel given
  return unless $_[0];

  my $rel = shift;

  # Get link
  unless ($_[0]) {
    return $self->at( qq{Link[rel="$rel"]} );
  };

  my %hash;

  # Accept hash reference
  if (ref $_[0] && ref $_[0] eq 'HASH') {
    %hash = %{ $_[0] };
  }

  # Accept string
  else {
    $hash{href} = shift;
  };

  # Set relation
  $hash{rel} = $rel;

  # Return link object
  return $self->add(Link => \%hash);
};


# Set or get expiration date
sub expires {
  my $self = shift;

  # Return subject
  unless ($_[0]) {

    # Subject found
    my $exp = $self->at('Expires');

    # Return
    return unless $exp;

    # Return RFC3339 object
    return XML::Loy::Date::RFC3339->new($exp->text);
  };

  # New RFC3339 object
  my $new_time = XML::Loy::Date::RFC3339->new($_[0])->to_string(0);

  # RFC3339 obect undefined
  return unless $new_time;

  my $new_node = $self->set(Expires => $new_time);

  # Set subject (only once)
  if (my $np = $self->at('Link, Alias, Property')) {

    # Put in correct order - maybe not effective
    my $clone = $self->at('Expires');
    $self->at('Expires')->remove;
    return $np->prepend($clone->to_string);
  };

  # Return new node
  return $new_node;
};


# Check for expiration
sub expired {
  my $self = $_[0]->type eq 'root' ?
    shift : shift->root;

  # No expiration date given
  my $exp = $self->expires or return;

  # Document is expired
  return 1 if $exp->epoch < time;

  # Document is still current
  return;
};


# Filter link relations
sub filter_rel {
  my $self = shift;
  my $xrd = $self->new( $self->to_string );

  # No xrd
  return unless $xrd;

  my @rel;

  # Push valid relations
  if (@_ == 1) {

    # Based on array reference
    if (ref $_[0] && ref $_[0] eq 'ARRAY') {
      @rel = @{ shift() };
    }

    # Based on string
    else {
      @rel = split /\s+/, shift;
    }
  }

  # As array
  else {
    @rel = @_;
  };

  # Create unwanted link relation query
  my $rel = scalar @rel ? 'Link:' . join(':', map {
    'not([rel=' . quote($_) . '])'
  } @rel) : 'Link';

  # Remove unwanted link relations
  $xrd->find($rel)->map('remove');
  return $xrd;
};


# Convert to xml
sub _to_xml {
  my $xrd = shift;

  # Parse json document
  my $jrd;

  # There may be a parsing error
  eval {
    $jrd = decode_json $_[0];
  } or carp $@;

  # Itterate over all XRD elements
  foreach my $key (keys %$jrd) {
    $key = lc $key;

      # Properties
    if ($key eq 'properties') {
      _to_xml_properties($xrd, $jrd->{$key});
    }

    # Links
    elsif ($key eq 'links') {
      _to_xml_links($xrd, $jrd->{$key});
    }

    # Subject or Expires
    elsif ($key eq 'subject' || $key eq 'expires') {
      $xrd->set(ucfirst($key), $jrd->{$key});
    }

    # Aliases
    elsif ($key eq 'aliases') {
      $xrd->alias($_) foreach (@{$jrd->{$key}});
    }

    # Titles
    elsif ($key eq 'titles') {
      _to_xml_titles($xrd, $jrd->{$key});
    };
  };
};


# Convert From JSON to XML
sub _to_xml_titles {
  my ($node, $hash) = @_;
  foreach (keys %$hash) {

    # Default
    if ($_ eq 'default') {
      $node->add(Title => $hash->{$_});
    }

    # Language
    else {
      $node->add(Title => { 'xml:lang' => $_ } => $hash->{$_});
    };
  };
};


# Convert from JSON to XML
sub _to_xml_links {
  my ($node, $array) = @_;

  # All link objects
  foreach (@$array) {

    # titles and properties
    my $titles     = delete $_->{titles};
    my $properties = delete $_->{properties};

    # Add new link object
    my $link = $node->link(delete $_->{rel}, $_);

    # Add titles and properties
    _to_xml_titles($link, $titles)         if $titles;
    _to_xml_properties($link, $properties) if $properties;
  };
};


# Convert from JSON to XML
sub _to_xml_properties {
  my ($node, $hash) = @_;

  $node->property($_ => $hash->{$_}) foreach keys %$hash;
};


# Render JRD
sub to_json {
  my $self = shift;

  my $root = $self->type eq 'root' ?
    $self : $self->root;

  my %object;

  # Serialize Subject and Expires
  foreach (qw/Subject Expires/) {
    my $obj = $root->at($_);
    $object{lc($_)} = $obj->text if $obj;
  };

  # Serialize aliases
  my @aliases;
  $root->children('Alias')->each(
    sub {
      push(@aliases, shift->text );
    });
  $object{'aliases'} = \@aliases if @aliases;

  # Serialize titles
  my $titles = _to_json_titles($root);
  $object{'titles'} = $titles if keys %$titles;

  # Serialize properties
  my $properties = _to_json_properties($root);
  $object{'properties'} = $properties if keys %$properties;

  # Serialize links
  my @links;
  $root->children('Link')->each(
    sub {
      my $link = shift;
      my $link_att = $link->attr;

      my %link_prop;
      foreach (qw/rel template href type/) {
	if (exists $link_att->{$_}) {
	  $link_prop{$_} = $link_att->{$_};
	};
      };

      # Serialize link titles
      my $link_titles = _to_json_titles($link);
      $link_prop{'titles'} = $link_titles if keys %$link_titles;

      # Serialize link properties
      my $link_properties = _to_json_properties($link);
      $link_prop{'properties'} = $link_properties
	if keys %$link_properties;

      push(@links, \%link_prop);
    });
  $object{'links'} = \@links if @links;
  return encode_json(\%object);
};


# Serialize node titles
sub _to_json_titles {
  my $node = shift;
  my %titles;
  $node->children('Title')->each(
    sub {
      my $val  = $_->text;
      my $lang = $_->attr->{'xml:lang'} || 'default';
      $titles{$lang} = $val;
    });
  return \%titles;
};


# Serialize node properties
sub _to_json_properties {
  my $node = shift;
  my %property = ();
  $node->children('Property')->each(
    sub {
      my $p = shift;
      my $val = $p->text || undef;
      my $type = $p->attr->{'type'};

      $property{$type} = $val;
    });
  return \%property;
};


1;


__END__