File Coverage

blib/lib/Data/Rx.pm

Criterion	Covered	Total	%
statement	67	72	93.0
branch	23	32	71.8
condition	2	4	50.0
subroutine	12	13	92.3
pod	6	8	75.0
total	110	129	85.2

use strict;
use warnings;
package Data::Rx;
# ABSTRACT: perl implementation of Rx schema system
$Data::Rx::VERSION = '0.200006';
use Data::Rx::Util;
use Data::Rx::TypeBundle::Core;

#pod =head1 SYNOPSIS
#pod
#pod   my $rx = Data::Rx->new;
#pod
#pod   my $success = {
#pod     type     => '//rec',
#pod     required => {
#pod       location => '//str',
#pod       status   => { type => '//int', value => 201 },
#pod     },
#pod     optional => {
#pod       comments => {
#pod         type     => '//arr',
#pod         contents => '//str',
#pod       },
#pod     },
#pod   };
#pod
#pod   my $schema = $rx->make_schema($success);
#pod
#pod   my $reply = $json->decode( $agent->get($http_request) );
#pod
#pod   die "invalid reply" unless $schema->check($reply);
#pod
#pod =head1 COMPLEX CHECKS
#pod
#pod Note that a "schema" can be represented either as a name or as a definition.
#pod In the L above, note that we have both, '//str' and
#pod C<{ type =E '//int', value =E 201 }>.
#pod With the L
#pod provided by Rx, you can validate many complex structures.  See L
#pod for how to teach your Rx schema object about the new types you create.
#pod
#pod When required, see L for details on creating a
#pod custom type plugin as a Perl module.
#pod
#pod =head1 SEE ALSO
#pod
#pod L
#pod
#pod =cut

sub _expand_uri {
  my ($self, $str) = @_;
  return $str if $str =~ /\A\w+:/;

  if ($str =~ m{\A/(.*?)/(.+)\z}) {
    my ($prefix, $rest) = ($1, $2);

    my $lookup = $self->{prefix};
    Carp::croak "unknown prefix '$prefix' in type name '$str'"
      unless exists $lookup->{$prefix};

    return "$lookup->{$prefix}$rest";
  }

  Carp::croak "couldn't understand Rx type name '$str'";
}

#pod =method new
#pod
#pod   my $rx = Data::Rx->new(\%arg);
#pod
#pod This returns a new Data::Rx object.
#pod
#pod Valid arguments are:
#pod
#pod   prefix        - optional; a hashref of prefix pairs for type shorthand
#pod   type_plugins  - optional; an arrayref of type or type bundle plugins
#pod   no_core_types - optional; if true, core type bundle is not loaded
#pod   sort_keys     - optional; see the sort_keys section.
#pod
#pod The prefix hashref should look something like this:
#pod
#pod   {
#pod     'pobox'  => 'tag:pobox.com,1995:rx/core/',
#pod     'skynet' => 'tag:skynet.mil,1997-08-29:types/rx/',
#pod   }
#pod
#pod =cut

sub new {
  my ($class, $arg) = @_;
  $arg ||= {};
  $arg->{prefix} ||= {};

  my @plugins = @{ $arg->{type_plugins} || [] };
  unshift @plugins, $class->core_bundle unless $arg->{no_core_bundle};

  my $self = {
    prefix    => { },
    handler   => { },
    sort_keys => !!$arg->{sort_keys},
  };

  bless $self => $class;

  $self->register_type_plugin($_) for @plugins;

  $self->add_prefix($_ => $arg->{prefix}{ $_ }) for keys %{ $arg->{prefix} };

  return $self;
}

#pod =method make_schema
#pod
#pod   my $schema = $rx->make_schema($schema);
#pod
#pod This returns a new schema checker method for the given Rx input. This object
#pod will have C and C methods to test data with.
#pod
#pod =cut

sub make_schema {
  my ($self, $schema) = @_;

  $schema = { type => "$schema" } unless ref $schema;

  Carp::croak("no type name given") unless my $type = $schema->{type};

  my $type_uri = $self->_expand_uri($type);
  die "unknown type uri: $type_uri" unless exists $self->{handler}{$type_uri};

  my $handler = $self->{handler}{$type_uri};

  my $schema_arg = {%$schema};
  delete $schema_arg->{type};

  my $checker;

  if (ref $handler) {
    if (keys %$schema_arg) {
      Carp::croak("composed type does not take check arguments");
    }
    $checker = $self->make_schema($handler->{'schema'});
  } else {
    $checker = $handler->new_checker($schema_arg, $self, $type);
  }

  return $checker;
}

#pod =method register_type_plugin
#pod
#pod   $rx->register_type_plugin($type_or_bundle);
#pod
#pod Given a type plugin, this registers the plugin with the Data::Rx object.
#pod Bundles are expanded recursively and all their plugins are registered.
#pod
#pod Type plugins must have a C method and a C method.
#pod See L for details.
#pod
#pod =cut

sub register_type_plugin {
  my ($self, $starting_plugin) = @_;

  my @plugins = ($starting_plugin);
  PLUGIN: while (my $plugin = shift @plugins) {
    if ($plugin->isa('Data::Rx::TypeBundle')) {
      my %pairs = $plugin->prefix_pairs;
      $self->add_prefix($_ => $pairs{ $_ }) for keys %pairs;

      unshift @plugins, $plugin->type_plugins;
    } else {
      my $uri = $plugin->type_uri;

      Carp::confess("a type plugin is already registered for $uri")
        if $self->{handler}{ $uri };

      $self->{handler}{ $uri } = $plugin;
    }
  }
}

#pod =method learn_type
#pod
#pod   $rx->learn_type($uri, $schema);
#pod
#pod This defines a new type as a schema composed of other types.
#pod
#pod For example:
#pod
#pod   $rx->learn_type('tag:www.example.com:rx/person',
#pod                   { type     => '//rec',
#pod                     required => {
#pod                       firstname => '//str',
#pod                       lastname  => '//str',
#pod                     },
#pod                     optional => {
#pod                       middlename => '//str',
#pod                     },
#pod                   },
#pod                  );
#pod
#pod =cut

sub learn_type {
  my ($self, $uri, $schema) = @_;

  Carp::confess("a type handler is already registered for $uri")
    if $self->{handler}{ $uri };

  die "invalid schema for '$uri': $@"
    unless eval { $self->make_schema($schema) };

  $self->{handler}{ $uri } = { schema => $schema };
}

#pod =method add_prefix
#pod
#pod   $rx->add_prefix($name => $prefix_string);
#pod
#pod For example:
#pod
#pod   $rx->add_prefix('.meta' => 'tag:codesimply.com,2008:rx/meta/');
#pod
#pod =cut

sub add_prefix {
  my ($self, $name, $base) = @_;

  Carp::confess("the prefix $name is already registered")
    if $self->{prefix}{ $name };

  $self->{prefix}{ $name } = $base;
}

#pod =method sort_keys
#pod
#pod   $rx->sort_keys(1);
#pod
#pod When sort_keys is enabled, causes Rx checkers for //rec and //map to
#pod sort the keys before validating.  This results in failures being
#pod produced in a consistent order.
#pod
#pod =cut

sub sort_keys {
  my $self = shift;

  $self->{sort_keys} = !!$_[0] if @_;

  return $self->{sort_keys};
}

sub core_bundle {
  return 'Data::Rx::TypeBundle::Core';
}

sub core_type_plugins {
  my ($self) = @_;

  Carp::cluck("core_type_plugins deprecated; use Data::Rx::TypeBundle::Core");

  Data::Rx::TypeBundle::Core->type_plugins;
}

1;

__END__