File Coverage

blib/lib/Articulate/LocationSpecification.pm

Criterion	Covered	Total	%
statement	55	66	83.3
branch	23	42	54.7
condition	2	6	33.3
subroutine	15	16	93.7
pod	6	6	100.0
total	101	136	74.2

package Articulate::LocationSpecification;
use strict;
use warnings;

use Moo;
use Scalar::Util qw(blessed);
use overload '""' => sub { shift->to_file_path }, '@{}' => sub { shift->path };
use Articulate::Location;

use Exporter::Declare;
default_exports qw(new_location_specification);

=head1 NAME

Articulate::LocationSpecification - represent a specification

=cut

=head1 DESCRIPTION

  new_location_specification ['zone', '*', 'article', 'hello-world']
  new_location_specification 'zone/*/article/hello-world' # same thing

An object class which represents a specification - like a 'pattern' or
'glob', and provides methods so that it can be compared with locations.
It is similar to C, and stringifies to the 'file
path' representation.

The main use of this is to determine whether a user has access to a
resource based on rules (e.g.
L).

=cut

=head1 FUNCTIONS

=head3 new_location_specification

C is a constructor. It takes either a
string (in the form of a path) or an arrayref. Either will be stored as
an arrayref in the C attribute.

=cut

sub new_location_specification {
  if ( 1 == scalar @_ ) {
    if ( blessed $_[0] and $_[0]->isa('Articulate::LocationSpecification') ) {
      return $_[0];
    }
    elsif ( blessed $_[0] and $_[0]->isa('Articulate::Location') ) {
      my $path = $_[0]->path; # should this logic be in the coerce?
      if (@$path) {
        for my $i ( 1 .. $#$path ) {
          if ( 0 == ( $i % 2 ) ) {
            $path->[$i] = '*';
          }
        }
      }
      return __PACKAGE__->new( { path => $path } );
    }
    elsif ( ref $_[0] eq 'ARRAY' ) {
      return __PACKAGE__->new( { path => $_[0] } );
    }
    elsif ( !defined $_[0] ) {
      return __PACKAGE__->new;
    }
    elsif ( !ref $_[0] ) {
      return __PACKAGE__->new(
        { path => [ grep { $_ ne '' } split /\//, $_[0] ] } );
    }
    elsif ( ref $_[0] eq 'HASH' ) {
      return __PACKAGE__->new( $_[0] );
    }
  }
}

=head1 ATTRIBUTE

=head3 path

An arrayref representing the path to the location specification. This
is used for overloaded array dereferencing.

=cut

has path => (
  is      => 'rw',
  default => sub { []; },
);

=head1 METHODS

=head3 location

  $locspec->location->location # same as $locspec

This method always returns the object itself.

=cut

sub location {
  return shift;
}

=head3 to_file_path

Joins the contents of C on C and returns the result. This is
used for overloaded stringification.

=cut

sub to_file_path {
  return join '/', @{ $_[0]->path };
}

sub _step_matches {
  my ( $left, $right ) = @_;
  return 1 if ( $left eq '*' );
  return 1 if ( $right eq '*' );
  return 1 if ( $left eq $right );
  return 0;

}

=head3 matches

  new_location_specification('/zone/*')->matches(new_location('/zone/public')) # true
  new_location_specification('/zone/*')->matches(new_location('/')) # false
  new_location_specification('/zone/*')->matches(new_location('/zone/public/article/hello-world')) # false

Determines if the location given as the first argument matches the
locspec.

=cut

sub matches {
  my $self     = shift;
  my $location = new_location shift;
  return 0 unless $#$self == $#$location;
  return 1 if $#$self == -1; # go no further if both are empty
  for my $i ( 0 .. $#$self ) {
    return 0 unless _step_matches( $self->[$i], $location->[$i] );
  }
  return 1;
}

=head3 matches_ancestor_of

  new_location_specification('/zone/*')->matches_ancestor_of(new_location('/zone/public')) # true
  new_location_specification('/zone/*')->matches_ancestor_of(new_location('/')) # false
  new_location_specification('/zone/*')->matches_ancestor_of(new_location('/zone/public/article/hello-world')) # true

Determines if the location given as the first argument - or any
ancestor thereof - matches the new_location_specification.

=cut

sub matches_ancestor_of {
  my $self     = shift;
  my $location = new_location shift;
  return 0 unless $#$self <= $#$location;
  return 1 if $#$self == -1; # go no further if self is empty
  for my $i ( 0 .. $#$self ) {
    return 0 unless _step_matches( $self->[$i], $location->[$i] );
  }
  return 1;
}

=head3 matches_descendant_of

  new_location_specification('/zone/*')->matches_descendant_of(new_location('/zone/public')) # true
  new_location_specification('/zone/*')->matches_descendant_of(new_location('/')) # true
  new_location_specification('/zone/*')->matches_descendant_of(new_location('/zone/public/article/hello-world')) # false

Determines if the location given as the first argument - or any
descendant thereof - matches the new_location_specification.

=cut

sub matches_descendant_of {
  my $self     = shift;
  my $location = new_location shift;
  return 0 unless $#$self >= $#$location;
  return 1 if $#$location == -1; # go no further if self is empty
  for my $i ( 0 .. $#$location ) {
    return 0 unless _step_matches( $self->[$i], $location->[$i] );
  }
  return 1;
}

=head1 SEE ALSO

=over

=item * L

=item * L

=item * L

=back

=cut

1;