File Coverage

blib/lib/Data/Domain.pm

Criterion	Covered	Total	%
statement	751	800	93.8
branch	318	384	82.8
condition	110	157	70.0
subroutine	162	172	94.1
pod	11	11	100.0
total	1352	1524	88.7

use 5.010;
use utf8;

#======================================================================
package Data::Domain; # documentation at end of file
#======================================================================
use strict;
use warnings;
use Carp;
use Data::Dumper;
use Scalar::Does 0.007;
use Scalar::Util ();
use Try::Tiny;
use List::Util      qw/max uniq/;
use List::MoreUtils qw/part natatime any/;
use if $] < 5.037, experimental => 'smartmatch';      # smartmatch no longer experimental after 5.037
use overload '""' => \&_stringify,
             $] < 5.037 ? ('~~' => \&_matches) : ();  # fully deprecated, so cannot be overloaded
use match::simple ();

our $VERSION = "1.16";

our $MESSAGE;            # global var for last message from _matches()
our $MAX_DEEP = 100;     # limit for recursive calls to inspect()
our $GLOBAL_MSGS;        # table of default messages -- see below method messages()
our $USE_OLD_MSG_API;    # flag for backward compatibility

#----------------------------------------------------------------------
# exports
#----------------------------------------------------------------------

# lists of symbols to export
my @CONSTRUCTORS;
my %SHORTCUTS;

BEGIN {
  @CONSTRUCTORS = qw/Whatever Empty
                     Num Int Nat Date Time String Handle
                     Enum List Struct Struict One_of All_of/;
  %SHORTCUTS = (
    True      => [ -true    => 1        ],
    False     => [ -true    => 0        ],
    Defined   => [ -defined => 1        ],
    Undef     => [ -defined => 0        ],
    Blessed   => [ -blessed => 1        ],
    Unblessed => [ -blessed => 0        ],
    Ref       => [ -ref     => 1        ],
    Unref     => [ -ref     => 0        ],
    Regexp    => [ -does    => 'Regexp' ],
    Obj       => [ -blessed => 1        ],
    Class     => [ -package => 1        ],
    Coderef   => [ -does    => 'CODE'   ],
  );
}

# setup exports through Sub::Exporter API
use Sub::Exporter -setup => {
  exports    => [ 'node_from_path',                                          # no longer used, but still present for backwards compat
                  (map {$_ => \&_wrap_domain          } @CONSTRUCTORS  ),
                  (map {$_ => \&_wrap_shortcut_options} keys %SHORTCUTS) ],
  groups     => { constructors => \@CONSTRUCTORS,
                  shortcuts    => [keys %SHORTCUTS] },
  collectors => { INIT => \&_sub_exporter_init },
  installer  => \&_sub_exporter_installer,
};

# customize Sub::Exporter to support "bang-syntax" for excluding symbols
# see https://rt.cpan.org/Public/Bug/Display.html?id=80234
{ my @dont_export;

  # detect symbols prefixed by '!' and remember them in @dont_export
  sub _sub_exporter_init {
    my ($collection, $context) = @_;
    my $args = $context->{import_args};
    my ($exclude, $regular_args)
      = part {!ref $_->[0] && $_->[0] =~ /^!/ ? 0 : 1} @$args;
    @$args = @$regular_args;
    @dont_export = map {substr($_->[0], 1)} @$exclude;
    1;
  }

  # install symbols, except those that belong to @dont_export
  sub _sub_exporter_installer {
    my ($arg, $to_export) = @_;
    my %export_hash = @$to_export;
    delete @export_hash{@dont_export};
    Sub::Exporter::default_installer($arg, [%export_hash]);
  }
}

# constructors group : for each domain constructor, we export a closure
# that just calls new() on the corresponding subclass. For example,
# Num(@args) is just equivalent to Data::Domain::Num->new(@args).
sub _wrap_domain {
  my ($class, $name, $args, $coll) = @_;
  return sub {return "Data::Domain::$name"->new(@_)};
}


# # shortcuts group : calling 'Whatever' with various pre-built options
sub _wrap_shortcut_options {
  my ($class, $name, $args, $coll) = @_;
  return sub {return Data::Domain::Whatever->new(@{$SHORTCUTS{$name}}, @_)};
}



#----------------------------------------------------------------------
# messages
#----------------------------------------------------------------------

sub _msg_bool { # small closure generator for various messages below
  my ($must_be, $if_true, $if_false) = @_;
  return sub {my ($name, $msg_id, $expected) = @_;
              "$name: $must_be " . ($expected ? $if_true : $if_false)};
}


my $builtin_msgs = {
  english => {
    Generic => {
      UNDEFINED     => "undefined data",
      INVALID       => "invalid",
      TOO_SMALL     => "smaller than minimum '%s'",
      TOO_BIG       => "bigger than maximum '%s'",
      EXCLUSION_SET => "belongs to exclusion set",
      MATCH_TRUE    => _msg_bool("must be", "true", "false"),
      MATCH_ISA     => "is not a '%s'",
      MATCH_CAN     => "does not have method '%s'",
      MATCH_DOES    => "does not do '%s'",
      MATCH_BLESSED => _msg_bool("must be", "blessed", "unblessed"),
      MATCH_PACKAGE => _msg_bool("must be", "a package", "a non-package"),
      MATCH_REF     => _msg_bool("must be", "a reference", "a non-reference"),
      MATCH_SMART   => "does not smart-match '%s'",
      MATCH_ISWEAK  => _msg_bool("must be", "a weak reference", "a strong reference"),
      MATCH_READONLY=> _msg_bool("must be", "readonly", "non-readonly"),
      MATCH_TAINTED => _msg_bool("must be", "tainted", "untainted"),
    },
    Whatever => {
      MATCH_DEFINED => _msg_bool("must be", "defined", "undefined"),
    },
    Num    => {INVALID => "invalid number",},
    Date   => {INVALID => "invalid date",},
    String => {
      TOO_SHORT        => "less than %d characters",
      TOO_LONG         => "more than %d characters",
      SHOULD_MATCH     => "should match '%s'",
      SHOULD_NOT_MATCH => "should not match '%s'",
    },
    Handle => {INVALID     => "is not an open filehandle"},
    Enum   => {NOT_IN_LIST => "not in enumeration list",},
    List => {
      NOT_A_LIST => "is not an arrayref",
      TOO_SHORT  => "less than %d items",
      TOO_LONG   => "more than %d items",
      ANY        => "should have at least one '%s'",
    },
    Struct => {
      NOT_A_HASH      => "is not a hashref",
      FORBIDDEN_FIELD => "contains forbidden field(s): %s"
    },
  },

  "français" => {
    Generic => {
      UNDEFINED     => "donnée non définie",
      INVALID       => "incorrect",
      TOO_SMALL     => "plus petit que le minimum '%s'",
      TOO_BIG       => "plus grand que le maximum '%s'",
      EXCLUSION_SET => "fait partie des valeurs interdites",
      MATCH_TRUE    => _msg_bool("doit être", "vrai", "faux"),
      MATCH_ISA     => "n'est pas un  '%s'",
      MATCH_CAN     => "n'a pas la méthode '%s'",
      MATCH_DOES    => "ne se comporte pas comme un '%s'",
      MATCH_BLESSED => _msg_bool("doit être", "blessed", "unblessed"),
      MATCH_PACKAGE => _msg_bool("doit être", "un package", "un non-package"),
      MATCH_REF     => _msg_bool("doit être", "une référence", "une non-référence"),
      MATCH_SMART   => "n'obéit pas au smart-match '%s'",
      MATCH_ISWEAK  => _msg_bool("doit être", "une weak reference", "une strong reference"),
      MATCH_READONLY=> _msg_bool("doit être", "readonly", "non-readonly"),
      MATCH_TAINTED => _msg_bool("doit être", "tainted", "untainted"),
    },
    Whatever => {
      MATCH_DEFINED => _msg_bool("doit être", "défini", "non-défini"),
    },
    Num    => {INVALID => "nombre incorrect",},
    Date   => {INVALID => "date incorrecte",},
    String => {
      TOO_SHORT        => "moins de %d caractères",
      TOO_LONG         => "plus de %d caractères",
      SHOULD_MATCH     => "devrait être reconnu par la regex '%s'",
      SHOULD_NOT_MATCH => "ne devrait pas être reconnu par la regex '%s'",
    },
    Handle => {INVALID     => "n'est pas une filehandle ouverte"},
    Enum   => {NOT_IN_LIST => "n'appartient pas à la liste énumérée",},
    List => {
      NOT_A_LIST => "n'est pas une arrayref",
      TOO_SHORT  => "moins de %d éléments",
      TOO_LONG   => "plus de %d éléments",
      ANY        => "doit avoir au moins un '%s'",
    },
    Struct => {
      NOT_A_HASH      => "n'est pas une hashref",
      FORBIDDEN_FIELD => "contient le(s) champ(s) interdit(s): %s",
    },
  },
};

# some domains inherit messages from their parent domain
foreach my $language (keys %$builtin_msgs) {
  $builtin_msgs->{$language}{$_} = $builtin_msgs->{$language}{Num}
    for qw/Int Nat/;
  $builtin_msgs->{$language}{Struict} = $builtin_msgs->{$language}{Struct};
}

# default messages : english
$GLOBAL_MSGS = $builtin_msgs->{english};

#----------------------------------------------------------------------
# PUBLIC METHODS
#----------------------------------------------------------------------

sub new {
  croak "Data::Domain is an abstract class; use subclassses for instantiating domains";
}


sub messages { # class method
  my ($class, $new_messages) = @_;
  croak "messages() is a class method in Data::Domain"
    if ref $class or $class ne 'Data::Domain';

  $GLOBAL_MSGS = (ref $new_messages) ? $new_messages
                                     : $builtin_msgs->{$new_messages}
    or croak "no such builtin messages: $new_messages";
}


sub inspect {
  my ($self, $data, $context, $is_absent) = @_;
  no warnings 'recursion';

  # build a context if this is the top-level call
  $context ||= $self->_initial_inspect_context($data);

  if (!defined $data) {

    # in validation mode, insert the default value into the tree of valid data
    if (exists $context->{gather_valid_data}) {
      my $apply_default             = sub {my $default = $self->{$_[0]};
                                           does($default, 'CODE') ? $default->($context) : $default};
      $context->{gather_valid_data} = exists $self->{-default}                 ? $apply_default->('-default')
                                    : $is_absent && exists $self->{-if_absent} ? $apply_default->('-if_absent')
                                    :                                            undef;
    }

    # success if data was optional;
    return if $self->{-optional} or exists $self->{-default} or exists $self->{-if_absent};

    # otherwise fail, except for the 'Whatever' domain which is the only one to accept undef
    return $self->msg(UNDEFINED => '')
      unless $self->isa("Data::Domain::Whatever");
  }
  else { # if $data is defined

    # remember the value within the tree of valid data
    $context->{gather_valid_data} = $data if exists $context->{gather_valid_data};

    # check some general properties
    if (my $isa = $self->{-isa}) {
      try {$data->isa($isa)}
        or return $self->msg(MATCH_ISA => $isa);
    }
    if (my $role = $self->{-does}) {
      does($data, $role)
        or return $self->msg(MATCH_DOES => $role);
    }
    if (my $can = $self->{-can}) {
      $can = [$can] unless does($can, 'ARRAY');
      foreach my $method (@$can) {
        try {$data->can($method)}
          or return $self->msg(MATCH_CAN => $method);
      }
    }
    if (my $match_target = $self->{-matches}) {
      match::simple::match($data, $match_target)
        or return $self->msg(MATCH_SMART => $match_target);
    }
    if ($self->{-has}) {
      # EXPERIMENTAL: check methods results
      my @msgs = $self->_check_has($data, $context);
      return {HAS => \@msgs} if @msgs;
    }
    if (defined $self->{-blessed}) {
      return $self->msg(MATCH_BLESSED => $self->{-blessed})
        if Scalar::Util::blessed($data) xor $self->{-blessed};
    }
    if (defined $self->{-package}) {
      return $self->msg(MATCH_PACKAGE => $self->{-package})
        if (!ref($data) && $data->isa($data)) xor $self->{-package};
    }
    if (defined $self->{-isweak}) {
      return $self->msg(MATCH_ISWEAK => $self->{-isweak})
        if Scalar::Util::isweak($data) xor $self->{-isweak};
    }
    if (defined $self->{-readonly}) {
      return $self->msg(MATCH_READONLY => $self->{-readonly})
        if Scalar::Util::readonly($data) xor $self->{-readonly};
    }
    if (defined $self->{-tainted}) {
      return $self->msg(MATCH_TAINTED => $self->{-tainted})
        if Scalar::Util::tainted($data) xor $self->{-tainted};
    }
  }

  # properties that must be checked against both defined and undef data
  if (defined $self->{-true}) {
    return $self->msg(MATCH_TRUE => $self->{-true})
      if $data xor $self->{-true};
  }
  if (defined $self->{-ref}) {
    return $self->msg(MATCH_REF => $self->{-ref})
      if ref $data xor $self->{-ref};
  }

  # now call domain-specific _inspect()
  return $self->_inspect($data, $context)
}


sub validate {
  my ($self, $data) = @_;

  # inspect the data
  my $context = $self->_initial_inspect_context($data, gather_valid_data => 1);
  my $msg     = $self->inspect($data, $context);

  # return the validated data tree if there is no error message
  return $context->{gather_valid_data} if !$msg;

  # otherwise, die with the error message
  croak $self->name . ": invalid data because " . $self->stringify_msg($msg);
}


sub stringify_msg {
  my ($self, $msg) = @_;

  return does($msg, 'ARRAY') ? join ", ", map {$self->stringify_msg($_)} grep {$_} @$msg
       : does($msg, 'HASH')  ? join ", ", map {"$_:" . $self->stringify_msg($msg->{$_})} grep {$msg->{$_}} sort keys %$msg
       :                       $msg;
}



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

  # this method is overridden in List() and Struct() for dealing with arrays and hashes
  return sub {my $params = $self->validate(@_); $params};
}


sub meth_signature {
  my ($self) = @_;
  my $sig = $self->func_signature;

  # same as func_signature, but the first param is set apart since it is the invocant of the method
  return sub {my $obj = shift; return ($obj, &$sig)};          # note: &$sig is equivalent to $sig->(@_)
}




#----------------------------------------------------------------------
# METHODS FOR INTERNAL USE
#----------------------------------------------------------------------
# Note : methods without initial underscore could possibly be useful for subclasses, either through
# invocation or through subclassing. Methods with initial underscore are really internal mechanics;
# I doubt that anybody else would want to invoke or subclass them ... but nothing prevents you from
# doing so !



sub msg {
  my ($self, $msg_id, @args) = @_;
  my $msgs     = $self->{-messages};
  my $name     = $self->name;

  # if using a coderef, these args will be passed to it
  my @msgs_call_args = ($name, $msg_id, @args);
  shift @msgs_call_args if $USE_OLD_MSG_API; # because older versions did not pass the $name arg

  # perl v5.22 and above warns if there are too many @args for sprintf.
  # The line below prevents that warning
  no if $] ge '5.022000', warnings => 'redundant';

  # if there is a user-defined message, return it
  if (defined $msgs) {
    for (ref $msgs) {
      /^CODE/ and return $msgs->(@msgs_call_args);                # user function
      /^$/    and return "$name: $msgs";                          # user constant string
      /^HASH/ and do { if (my $msg_string =  $msgs->{$msg_id}) {  # user hash of msgs
                         return sprintf "$name: $msg_string", @args;
                       }
                       else {
                         last; # not found in this hash - revert to $GLOBAL_MSGS below
                       }
                     };
      # otherwise
      croak "-messages option should be a coderef, a hashref or a sprintf string";
    }
  }

  # there was no user-defined message, so use global messages
  if (ref $GLOBAL_MSGS eq 'CODE') {
    return $GLOBAL_MSGS->(@msgs_call_args);
  }
  else {
    my $msg_entry = $GLOBAL_MSGS->{$self->subclass}{$msg_id}
                  || $GLOBAL_MSGS->{Generic}{$msg_id}
     or croak "no error string for message $msg_id";
    return ref $msg_entry eq 'CODE' ? $msg_entry->(@msgs_call_args)
                                    : sprintf "$name: $msg_entry", @args;
  }
}


sub name {
  my ($self) = @_;
  return $self->{-name} || $self->subclass;
}


sub subclass { # returns the class name without initial 'Data::Domain::'
  my ($self) = @_;
  my $class = ref($self) || $self;
  (my $subclass = $class) =~ s/^Data::Domain:://;
  return $subclass;
}


sub _initial_inspect_context {
  my ($self, $data, %extra) = @_;

  return {root       => $data,
          flat       => {},
          path       => [],
          list       => [],
          %extra,
        };
}


sub _check_has {
  my ($self, $data, $context) = @_;

  my @msgs;
  my $iterator = natatime 2, @{$self->{-has}};
  while (my ($meth_to_call, $expectation) = $iterator->()) {
    my ($meth, @args) = does($meth_to_call, 'ARRAY') ? @$meth_to_call
                                                     : ($meth_to_call);
    my $msg;
    if (does($expectation, 'ARRAY')) {
      $msg = try   {my @result = $data->$meth(@args);
                    my $domain = List(@$expectation);
                    $domain->inspect(\@result)}
             catch {(my $error_msg = $_) =~ s/\bat\b.*//s; $error_msg};
    }
    else {
      $msg = try   {my $result = $data->$meth(@args);
                    $expectation->inspect($result)}
             catch {(my $error_msg = $_) =~ s/\bat\b.*//s; $error_msg};
    }
    push @msgs, $meth_to_call => $msg if $msg;
  }
  return @msgs;
}



sub _check_returns {
  my ($self, $data, $context) = @_;

  my @msgs;
  my $iterator = natatime 2, @{$self->{-returns}};
  while (my ($args, $expectation) = $iterator->()) {
    my $msg;
    if (does($expectation, 'ARRAY')) {
      $msg = try   {my @result = $data->(@$args);
                    my $domain = List(@$expectation);
                    $domain->inspect(\@result)}
             catch {(my $error_msg = $_) =~ s/\bat\b.*//s; $error_msg};
    }
    else {
      $msg = try   {my $result = $data->(@$args);
                    $expectation->inspect($result)}
             catch {(my $error_msg = $_) =~ s/\bat\b.*//s; $error_msg};
    }
    push @msgs, $args => $msg if $msg;
  }
  return @msgs;
}


sub _expand_range {
  my ($self, $range_field, $min_field, $max_field) = @_;
  my $name = $self->name;

  # the range field will be replaced by min and max fields
  if (my $range = delete $self->{$range_field}) {
    for ($min_field, $max_field) {
      not defined $self->{$_}
        or croak  "$name: incompatible options: $range_field / $_";
    }
    does($range, 'ARRAY') and @$range == 2
      or croak  "$name: invalid argument for $range";
    @{$self}{$min_field, $max_field} = @$range;
  }
}


sub _check_min_max {
  my ($self, $min_field, $max_field, $cmp_func) = @_;

  # choose the appropriate comparison function
  if    ($cmp_func eq '<=')       {$cmp_func = sub {$_[0] <= $_[1]}}
  elsif ($cmp_func eq 'le')       {$cmp_func = sub {$_[0] le $_[1]}}
  elsif (does($cmp_func, 'CODE')) {} # already a coderef, do nothing
  else                            {croak "inappropriate cmp_func for _check_min_max"}

  # check that min is smaller than max
  my ($min, $max) = @{$self}{$min_field, $max_field};
  if (defined $min && defined $max) {
    $cmp_func->($min, $max)
      or croak $self->subclass . ": incompatible min/max values ($min/$max)";
  }
}


sub _build_subdomain {
  my ($self, $domain, $context) = @_;
  no warnings 'recursion';

  # avoid infinite loop
  @{$context->{path}} < $MAX_DEEP
    or croak "inspect() deepness exceeded $MAX_DEEP; "
           . "modify \$Data::Domain::MAX_DEEP if you need more";

  if (does($domain, 'Data::Domain')) {
    # already a domain, nothing to do
  }
  elsif (does($domain, 'CODE')) {
    # this is a lazy domain, need to call the coderef to get a real domain
    $domain = try   {$domain->($context)}
              catch {(my $error_msg = $_) =~ s/\bat\b.*//s; # remove "at source_file, line ..." from error message
                     # return an empty domain that reports the error message
                     Data::Domain::Empty->new(-name     => "domain parameters",
                                              -messages => $error_msg);
                   };
    # did we really get a domain ?
    does($domain, "Data::Domain")
      or croak "lazy domain coderef returned an invalid domain";
  }
  elsif (!ref $domain) {
    # this is a scalar, build a constant domain with that single value
    my $subclass = Scalar::Util::looks_like_number($domain) ? 'Num' : 'String';
    $domain = "Data::Domain::$subclass"->new(-min  => $domain,
                                             -max  => $domain,
                                             -name => "constant $subclass");
  }
  else {
    croak "unknown subdomain : $domain";
  }

  return $domain;
}


sub _is_proper_subdomain {
  my ($self, $domain) = @_;
  return does($_, 'Data::Domain') || does($_, 'CODE') || !ref $_;
}





#----------------------------------------------------------------------
# UTILITY FUNCTIONS (NOT METHODS)
#----------------------------------------------------------------------

# valid options for all subclasses
my @common_options = qw/-optional -name -messages
                        -true -isa -can -does -matches -ref
                        -has -returns
                        -blessed -package -isweak -readonly -tainted
                        -default -if_absent/;

sub _parse_args {
  my ($args_ref, $options_ref, $default_option, $arg_type) = @_;

  my %parsed;

  # parse named arguments
  while (@$args_ref and $args_ref->[0] =~ /^-/) {
    any {$args_ref->[0] eq $_} (@$options_ref, @common_options)
      or croak "invalid argument: $args_ref->[0]";
    my ($key, $val) = (shift @$args_ref, shift @$args_ref);
    $parsed{$key}  = $val;
  }

  # remaining arguments are mapped to the default option
  if (@$args_ref) {
    $default_option or croak "too many args to new()";
    not exists $parsed{$default_option}
      or croak "can't have default args if $default_option is set";
    $parsed{$default_option}
      = $arg_type eq 'scalar'   ? $args_ref->[0]
      : $arg_type eq 'arrayref' ? $args_ref
      : croak "unknown type for default option: $arg_type";
  }

  return \%parsed;
}


sub node_from_path { # no longer used (replaced by Data::Reach); but still present for backwards compat
  my ($root, $path0, @path) = @_;
  return $root if not defined $path0;
  return undef if not defined $root;
  return node_from_path($root->{$path0}, @path)
    if does($root, 'HASH');
  return node_from_path($root->[$path0], @path)
    if does($root, 'ARRAY');

  # otherwise
  croak "node_from_path: incorrect root/path";
}

#----------------------------------------------------------------------
# implementation for overloaded operators
#----------------------------------------------------------------------
sub _matches {
  my ($self, $data, $call_order) = @_;
  $Data::Domain::MESSAGE = $self->inspect($data);
  return !$Data::Domain::MESSAGE; # smart match successful if no error message
}

sub _stringify {
  my ($self) = @_;
  my $dumper = Data::Dumper->new([$self])->Indent(0)->Terse(1);
  return $dumper->Dump;
}

#======================================================================
# END OF PARENT CLASS -- BELOW ARE IMPLEMENTATIONS FOR SPECIFIC DOMAINS
#======================================================================


#======================================================================
package Data::Domain::Whatever;
#======================================================================
use strict;
use warnings;
use Carp;
use Scalar::Does qw/does/;
our @ISA = 'Data::Domain';

sub new {
  my $class   = shift;
  my @options = qw/-defined/;
  my $self    = Data::Domain::_parse_args( \@_, \@options );
  bless $self, $class;

  not ($self->{-defined } && $self->{-optional})
    or croak "both -defined and -optional: meaningless!";

  return $self;
}

sub _inspect {
  my ($self, $data) = @_;

  if (defined $self->{-defined}) {
    return $self->msg(MATCH_DEFINED => $self->{-defined})
      if defined($data) xor $self->{-defined};
  }

  # otherwise, success
  return;
}


#======================================================================
package Data::Domain::Empty;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

sub new {
  my $class   = shift;
  my @options = ();
  my $self    = Data::Domain::_parse_args( \@_, \@options );
  bless $self, $class;
}

sub _inspect {
  my ($self, $data) = @_;

  return $self->msg(INVALID => ''); # always fails
}


#======================================================================
package Data::Domain::Num;
#======================================================================
use strict;
use warnings;
use Carp;
use Scalar::Util qw/looks_like_number/;
use Try::Tiny;

our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-range -min -max -not_in/;
  my $self = Data::Domain::_parse_args(\@_, \@options);
  bless $self, $class;

  $self->_expand_range(qw/-range -min -max/);
  $self->_check_min_max(qw/-min -max <=/);

  if ($self->{-not_in}) {
    try {my $vals = $self->{-not_in};
          @$vals > 0 and not grep {!looks_like_number($_)} @$vals}
      or croak "-not_in : needs an arrayref of numbers";
  }

  return $self;
}

sub _inspect {
  my ($self, $data) = @_;

  looks_like_number($data)
    or return $self->msg(INVALID => $data);

  if (defined $self->{-min}) {
    $data >= $self->{-min}
      or return $self->msg(TOO_SMALL => $self->{-min});
  }
  if (defined $self->{-max}) {
    $data <= $self->{-max}
      or return $self->msg(TOO_BIG => $self->{-max});
  }
  if (defined $self->{-not_in}) {
    grep {$data == $_} @{$self->{-not_in}}
      and return $self->msg(EXCLUSION_SET => $data);
  }

  return;
}


#======================================================================
package Data::Domain::Int;
#======================================================================
use strict;
use warnings;

our @ISA = 'Data::Domain::Num';

sub _inspect {
  my ($self, $data) = @_;

  defined($data) and $data =~ /^-?\d+$/
    or return $self->msg(INVALID => $data);
  return $self->SUPER::_inspect($data);
}


#======================================================================
package Data::Domain::Nat;
#======================================================================
use strict;
use warnings;

our @ISA = 'Data::Domain::Num';

sub _inspect {
  my ($self, $data) = @_;

  defined($data) and $data =~ /^\d+$/
    or return $self->msg(INVALID => $data);
  return $self->SUPER::_inspect($data);
}


#======================================================================
package Data::Domain::String;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-regex -antiregex
                   -range -min -max
                   -length -min_length -max_length
                   -not_in/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -regex => 'scalar');
  bless $self, $class;

  $self->_expand_range(qw/-range -min -max/);
  $self->_check_min_max(qw/-min -max le/);

  $self->_expand_range(qw/-length -min_length -max_length/);
  $self->_check_min_max(qw/-min_length -max_length <=/);

  return $self;
}

sub _inspect {
  my ($self, $data) = @_;

  # $data must be Unref or obj with a stringification method
  !ref($data) || overload::Method($data, '""')
    or return $self->msg(INVALID => $data);
  if ($self->{-min_length}) {
    length($data) >= $self->{-min_length}
      or return $self->msg(TOO_SHORT => $self->{-min_length});
  }
  if (defined $self->{-max_length}) {
    length($data) <= $self->{-max_length}
      or return $self->msg(TOO_LONG => $self->{-max_length});
  }
  if ($self->{-regex}) {
    $data =~ $self->{-regex}
      or return $self->msg(SHOULD_MATCH => $self->{-regex});
  }
  if ($self->{-antiregex}) {
    $data !~ $self->{-antiregex}
      or return $self->msg(SHOULD_NOT_MATCH => $self->{-antiregex});
  }
  if (defined $self->{-min}) {
    $data ge $self->{-min}
      or return $self->msg(TOO_SMALL => $self->{-min});
  }
  if (defined $self->{-max}) {
    $data le $self->{-max}
      or return $self->msg(TOO_BIG => $self->{-max});
  }
  if ($self->{-not_in}) {
    grep {$data eq $_} @{$self->{-not_in}}
      and return $self->msg(EXCLUSION_SET => $data);
  }

  return;
}


#======================================================================
package Data::Domain::Date;
#======================================================================
use strict;
use warnings;
use Carp;
use Try::Tiny;
our @ISA = 'Data::Domain';


use autouse 'Date::Calc' => qw/Decode_Date_EU Decode_Date_US Date_to_Text
                               Delta_Days  Add_Delta_Days Today check_date/;

my $date_parser = \&Decode_Date_EU;

#----------------------------------------------------------------------
# utility functions
#----------------------------------------------------------------------
sub _print_date {
  my $date = shift;
  $date = _expand_dynamic_date($date);
  return Date_to_Text(@$date);
}


my $dynamic_date = qr/^(today|yesterday|tomorrow)$/;

sub _expand_dynamic_date {
  my $date = shift;
  if (not ref $date) {
    $date = {
      today     => [Today],
      yesterday => [Add_Delta_Days(Today, -1)],
      tomorrow  => [Add_Delta_Days(Today, +1)]
     }->{$date} or croak "unexpected date : $date";
  }
  return $date;
}

sub _date_cmp {
  my ($d1, $d2) = map {_expand_dynamic_date($_)} @_;
  return -Delta_Days(@$d1, @$d2);
}


#----------------------------------------------------------------------
# public API
#----------------------------------------------------------------------

sub parser {
  my ($class, $new_parser) = @_;
  not ref $class or croak "Data::Domain::Date::parser is a class method";

  $date_parser =
    (ref $new_parser eq 'CODE')
    ? $new_parser
    : {US => \&Decode_Date_US,
       EU => \&Decode_Date_EU}->{$new_parser}
    or croak "unknown date parser : $new_parser";
  return $date_parser;
}


sub new {
  my $class   = shift;
  my @options = qw/-range -min -max -not_in/;
  my $self    = Data::Domain::_parse_args(\@_, \@options);
  bless $self, $class;

  $self->_expand_range(qw/-range -min -max/);

  # parse date boundaries into internal representation (arrayrefs)
  for my $bound (qw/-min -max/) {
    if ($self->{$bound} and $self->{$bound} !~ $dynamic_date) {
      my @date = $date_parser->($self->{$bound})
        or croak "invalid date ($bound): $self->{$bound}";
      $self->{$bound} = \@date;
    }
  }

  # check order of boundaries
  $self->_check_min_max(qw/-min -max/, sub {_date_cmp($_[0], $_[1]) <= 0});

  # parse dates in the exclusion set into internal representation
  if ($self->{-not_in}) {
    my @excl_dates;
    try {
      foreach my $date (@{$self->{-not_in}}) {
        if ($date =~ $dynamic_date) {
          push @excl_dates, $date;
        }
        else {
          my @parsed_date = $date_parser->($date) or die "wrong date";
          push @excl_dates, \@parsed_date;
        }
      }
      @excl_dates > 0;
    }
      or croak "-not_in : needs an arrayref of dates";
    $self->{-not_in} = \@excl_dates;
  }

  return $self;
}


sub _inspect {
  my ($self, $data) = @_;

  my @date = try {$date_parser->($data)};
  @date && check_date(@date)
    or return $self->msg(INVALID => $data);

  if (defined $self->{-min}) {
    my $min = _expand_dynamic_date($self->{-min});
    !check_date(@$min) || (_date_cmp(\@date, $min) < 0)
      and return $self->msg(TOO_SMALL => _print_date($self->{-min}));
  }

  if (defined $self->{-max}) {
    my $max = _expand_dynamic_date($self->{-max});
    !check_date(@$max) || (_date_cmp(\@date, $max) > 0)
      and return $self->msg(TOO_BIG => _print_date($self->{-max}));
  }

  if ($self->{-not_in}) {
    grep {_date_cmp(\@date, $_) == 0} @{$self->{-not_in}}
      and return $self->msg(EXCLUSION_SET => $data);
  }

  return;
}


#======================================================================
package Data::Domain::Time;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

my $time_regex = qr/^(\d\d?):?(\d\d?)?:?(\d\d?)?$/;

sub _valid_time {
  my ($h, $m, $s) = @_;
  $m ||= 0;
  $s ||= 0;
  return ($h <= 23 && $m <= 59 && $s <= 59);
}


sub _expand_dynamic_time {
  my $time = shift;
  if (not ref $time) {
    $time eq 'now' or croak "unexpected time : $time";
    $time = [(localtime)[2, 1, 0]];
  }
  return $time;
}


sub _time_cmp {
  my ($t1, $t2) = map {_expand_dynamic_time($_)} @_;

  return  $t1->[0]       <=>  $t2->[0]        # hours
      || ($t1->[1] || 0) <=> ($t2->[1] || 0)  # minutes
      || ($t1->[2] || 0) <=> ($t2->[2] || 0); # seconds
}

sub _print_time {
  my $time = _expand_dynamic_time(shift);
  return sprintf "%02d:%02d:%02d", map {$_ || 0} @$time;
}


sub new {
  my $class = shift;
  my @options = qw/-range -min -max/;
  my $self = Data::Domain::_parse_args(\@_, \@options);
  bless $self, $class;

  $self->_expand_range(qw/-range -min -max/);

  # parse time boundaries
  for my $bound (qw/-min -max/) {
    if ($self->{$bound} and $self->{$bound} ne 'now') {
      my @time = ($self->{$bound} =~ $time_regex);
      @time && _valid_time(@time)
        or croak "invalid time ($bound): $self->{$bound}";
      $self->{$bound} = \@time;
    }
  }

  # check order of boundaries
  $self->_check_min_max(qw/-min -max/, sub {_time_cmp($_[0], $_[1]) <= 0});

  return $self;
}


sub _inspect {
  my ($self, $data) = @_;

  my @t = ($data =~ $time_regex);
  @t and _valid_time(@t)
    or return $self->msg(INVALID => $data);

  if (defined $self->{-min}) {
    _time_cmp(\@t, $self->{-min}) < 0
      and return $self->msg(TOO_SMALL => _print_time($self->{-min}));
  }

  if (defined $self->{-max}) {
    _time_cmp(\@t, $self->{-max}) > 0
      and return $self->msg(TOO_BIG => _print_time($self->{-max}));
  }

  return;
}



#======================================================================
package Data::Domain::Handle;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = ();
  my $self = Data::Domain::_parse_args(\@_, \@options);
  bless $self, $class;
}

sub _inspect {
  my ($self, $data) = @_;
  Scalar::Util::openhandle($data)
    or return $self->msg(INVALID => '');

  return; # otherwise OK, no error
}




#======================================================================
package Data::Domain::Enum;
#======================================================================
use strict;
use warnings;
use Carp;
use Try::Tiny;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-values/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -values => 'arrayref');
  bless $self, $class;

  try {@{$self->{-values}}} or croak "Enum : incorrect set of values";

  not grep {! defined $_} @{$self->{-values}}
    or croak "Enum : undefined element in values";

  return $self;
}


sub _inspect {
  my ($self, $data) = @_;

  return $self->msg(NOT_IN_LIST => $data)
    if not grep {$_ eq $data} @{$self->{-values}};

  return; # otherwise OK, no error
}


#======================================================================
package Data::Domain::List;
#======================================================================
use strict;
use warnings;
use Carp;
use List::MoreUtils qw/all/;
use Scalar::Does qw/does/;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-items -size -min_size -max_size -any -all/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -items => 'arrayref');
  bless $self, $class;

  $self->_expand_range(qw/-size -min_size -max_size/);
  $self->_check_min_max(qw/-min_size -max_size <=/);

  if ($self->{-items}) {
    does($self->{-items}, 'ARRAY')
      or croak "invalid -items for Data::Domain::List";

    # if -items is given, then both -{min,max}_size cannot be shorter
    for my $bound (qw/-min_size -max_size/) {
      croak "$bound does not match -items"
      if $self->{$bound} and $self->{$bound} < @{$self->{-items}};
    }

    # check that all items are associated to proper subdomains
    my @invalid_fields = grep {!$self->_is_proper_subdomain($self->{-items}[$_])} 0 .. $#{$self->{-items}};
    croak "invalid subdomain for field: ", join ", ", @invalid_fields  if @invalid_fields;
  }

  # check that -all or -any are domains or lists of domains
  for my $arg (qw/-all -any/) {
    if (my $dom = $self->{$arg}) {
      $dom = [$dom] unless does($dom, 'ARRAY');
      all {does($_, 'Data::Domain') || does($_, 'CODE')} @$dom
        or croak "invalid arg to $arg in Data::Domain::List";
    }
  }

  return $self;
}


sub _inspect {
  my ($self, $data, $context) = @_;
  no warnings 'recursion';

  does($data, 'ARRAY')
    or return $self->msg(NOT_A_LIST => $data);

  # build a shallow copy of the data, so that default values can be inserted
  my @valid_data;
  @valid_data = @$data if exists $context->{gather_valid_data};


  if (defined $self->{-min_size} && @$data < $self->{-min_size}) {
    return $self->msg(TOO_SHORT => $self->{-min_size});
  }

  if (defined $self->{-max_size} && @$data > $self->{-max_size}) {
    return $self->msg(TOO_LONG => $self->{-max_size});
  }

  return unless $self->{-items} || $self->{-all} || $self->{-any};

  # prepare context for calling lazy subdomains
  local $context->{list} = $data;

  # initializing some variables
  my @msgs;
  my $has_invalid;
  my $items   = $self->{-items} || [];
  my $n_items = @$items;
  my $n_data  = @$data;

  # check the -items conditions
  for (my $i = 0; $i < $n_items; $i++) {
    local $context->{path} = [@{$context->{path}}, $i];
    my $subdomain  = $self->_build_subdomain($items->[$i], $context)
      or next;
    $msgs[$i]      = $subdomain->inspect($data->[$i], $context, ! exists $data->[$i]);
    $has_invalid ||= $msgs[$i];

    # re-inject the valid data for that slot
    $valid_data[$i] = $context->{gather_valid_data} if exists $context->{gather_valid_data};
  }

  # check the -all condition (can be a single domain or an arrayref of domains)
  if (my $all = $self->{-all}) {
    $all = [$all] unless does($all, 'ARRAY');
    my $n_all = @$all;
    for (my $i = $n_items, my $j = 0; # $i iterates over @$data, $j over @$all
         $i < $n_data;
         $i++, $j = ($j + 1) % $n_all) {
      local $context->{path} = [@{$context->{path}}, $i];
      my $subdomain  = $self->_build_subdomain($all->[$j], $context);
      $msgs[$i]      = $subdomain->inspect($data->[$i], $context);
      $has_invalid ||= $msgs[$i];

      # re-inject the valid data for that slot
      $valid_data[$i] = $context->{gather_valid_data} if exists $context->{gather_valid_data}
                                                      && not defined $valid_data[$i];
    }
  }

  # stop here if there was any error message
  return \@msgs if $has_invalid;

  # all other conditions were good, now check the "any" conditions
  if (my $any = $self->{-any}) {
    $any = [$any] unless does($any, 'ARRAY');

    # there must be data to inspect
    $n_data > $n_items
      or return $self->msg(ANY => $any->[0]->name);

    # inspect the remaining data for all 'any' conditions
  CONDITION:
    foreach my $condition (@$any) {
      my $subdomain;
      for (my $i = $n_items; $i < $n_data; $i++) {
        local $context->{path} = [@{$context->{path}}, $i];
        $subdomain = $self->_build_subdomain($condition, $context);
        my $error  = $subdomain->inspect($data->[$i], $context);
        next CONDITION if not $error;
      }
      return $self->msg(ANY => $subdomain->name);
    }
  }

  # re-inject the whole valid array into the context
  $context->{gather_valid_data} = \@valid_data if exists $context->{gather_valid_data};

  return; # OK, no error
}


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

  # override the parent method : pass the parameters list as an arrayref to validate(),
  # and return the validated datatree as an array
  return sub {my $params =  $self->validate(\@_);  @$params};
}

#======================================================================
package Data::Domain::Struct;
#======================================================================
use strict;
use warnings;
use Carp;
use Scalar::Does qw/does/;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-fields -exclude -keys -values -may_ignore/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -fields => 'arrayref');
  bless $self, $class;

  # parse the -fields option
  my $fields = $self->{-fields} || [];
  if (does($fields, 'ARRAY')) {
    # transform arrayref into hashref plus an ordered list of keys
    $self->{-fields_list} = [];
    $self->{-fields}      = {};
    for (my $i = 0; $i < @$fields; $i += 2) {
      my ($key, $val) = ($fields->[$i], $fields->[$i+1]);
      push @{$self->{-fields_list}}, $key;
      $self->{-fields}{$key} = $val;
    }
  }
  elsif (does($fields, 'HASH')) {
    # keep given hashref, add list of keys
    $self->{-fields_list} = [sort keys %$fields];
  }
  else {
    croak "invalid data for -fields option";
  }

  # check that all fields are associated to proper subdomains
  my @invalid_fields = grep {!$self->_is_proper_subdomain($self->{-fields}{$_})} @{$self->{-fields_list}};
  croak "invalid subdomain for field: ", join ", ", @invalid_fields  if @invalid_fields;

  # check that -exclude and -may_ignore are an arrayref or a regex or a string
  for my $opt (qw/-exclude -may_ignore/) {
    my $val = $self->{$opt} or next;
    does($val, 'ARRAY') || does($val, 'Regexp') || !ref($val)
      or croak "invalid data for $opt option";
  }

  # check that -keys or -values are List domains
  for my $arg (qw/-keys -values/) {
    if (my $dom = $self->{$arg}) {
      does($dom, 'Data::Domain::List') or does($dom, 'CODE')
        or croak "$arg in Data::Domain::Struct should be a List domain";
    }
  }

  return $self;
}


sub _inspect {
  my ($self, $data, $context) = @_;
  no warnings 'recursion';

  # check that $data is a hashref
  does($data, 'HASH')
    or return $self->msg(NOT_A_HASH => $data);

  my %msgs;

  # build a shallow copy of the data, so that default values can be inserted
  my %valid_data;
  %valid_data = %$data if exists $context->{gather_valid_data};


  # check if there are any forbidden fields
  if (my $exclude = $self->{-exclude}) {
    my @other_fields = grep {!$self->{-fields}{$_}} keys %$data;
    my @wrong_fields = grep {$self->_field_matches(-exclude => $_)} @other_fields;
    $msgs{-exclude}  = $self->msg(FORBIDDEN_FIELD => join ", ", map {"'$_'"} sort @wrong_fields)
      if @wrong_fields;
  }

  # prepare context for calling lazy subdomains
  local $context->{flat} = {%{$context->{flat}}, %$data};

  # check fields of the domain
 FIELD:
  foreach my $field (@{$self->{-fields_list}}) {
    next FIELD if not exists $data->{$field} and $self->_field_matches(-may_ignore => $field);
    local $context->{path} = [@{$context->{path}}, $field];
    my $field_spec = $self->{-fields}{$field};
    my $subdomain  = $self->_build_subdomain($field_spec, $context);
    my $msg        = $subdomain->inspect($data->{$field}, $context, ! exists $data->{$field});
    $msgs{$field}  = $msg if $msg;

    # re-inject the valid data for that field
    $valid_data{$field} = $context->{gather_valid_data} if exists $context->{gather_valid_data};
  }

  # check the List domain for keys
  if (my $keys_dom = $self->{-keys}) {
    local $context->{path} = [@{$context->{path}}, "-keys"];
    my $subdomain  = $self->_build_subdomain($keys_dom, $context);
    my $msg        = $subdomain->inspect([keys %$data], $context);
    $msgs{-keys}   = $msg if $msg;
  }

  # check the List domain for values
  if (my $values_dom = $self->{-values}) {
    local $context->{path} = [@{$context->{path}}, "-values"];
    my $subdomain  = $self->_build_subdomain($values_dom, $context);
    my $msg        = $subdomain->inspect([values %$data], $context);
    $msgs{-values} = $msg if $msg;
  }

  # re-inject the whole valid tree into the context
  $context->{gather_valid_data} = \%valid_data if exists $context->{gather_valid_data};

  return keys %msgs ? \%msgs : undef;
}

sub _field_matches {
  my ($self, $spec, $field) = @_;

  my $spec_content = $self->{$spec};
  return $spec_content && (match::simple::match($spec_content, ['*', 'all'])
                           ||
                           match::simple::match($field, $spec_content));
}


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

  # override the parent method : treat the parameters list as a hash,
  # and return the validated datatree as a hashref
  return sub {my $params =  $self->validate({@_});  %$params};
}



#======================================================================
package Data::Domain::Struict; # domain for a strict Struct :-)
#======================================================================
use strict;
use warnings;
use Carp;
use Scalar::Does qw/does/;
our @ISA = 'Data::Domain::Struct';

sub new {
  my $class = shift;
  my $self  = $class->SUPER::new(@_);

  not exists $self->{-exclude} or croak "Struict(...): invalid option: '-exclude'";
  $self->{-exclude} = '*';

  return $self;
}


#======================================================================
package Data::Domain::One_of;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-options/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -options => 'arrayref');
  bless $self, $class;

  Scalar::Does::does($self->{-options}, 'ARRAY')
    or croak "One_of: invalid options";

  return $self;
}


sub _inspect {
  my ($self, $data, $context) = @_;
  my @msgs;
  no warnings 'recursion';

  for my $subdomain (@{$self->{-options}}) {
    my $msg = $subdomain->inspect($data, $context)
      or return; # $subdomain was successful
    push @msgs, $msg;
  }
  return \@msgs;
}


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

  # take a reference to the func_signature implementation for the
  # first option ... assuming all remaining options have the same
  # structure. This wil not work in all cases, but is better than nothing.
  my $first_sig_ref = $self->{-options}[0]->can("func_signature");

  # invoke that implementation on $self
  return $self->$first_sig_ref;
}



#======================================================================
package Data::Domain::All_of;
#======================================================================
use strict;
use warnings;
use Carp;
our @ISA = 'Data::Domain';

sub new {
  my $class = shift;
  my @options = qw/-options/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -options => 'arrayref');
  bless $self, $class;

  Scalar::Does::does($self->{-options}, 'ARRAY')
    or croak "All_of: invalid options";

  return $self;
}


sub _inspect {
  my ($self, $data, $context) = @_;
  my @msgs;
  no warnings 'recursion';

  for my $subdomain (@{$self->{-options}}) {
    my $msg = $subdomain->inspect($data, $context);
    push @msgs, $msg if $msg; # subdomain failed
  }
  return @msgs ? \@msgs : undef;
}


# func_signature : reuse the implementation of the "One_of" domain
*func_signature = \&Data::Domain::One_of::func_signature;


#======================================================================

1;


__END__