File Coverage

blib/lib/Data/Domain.pm

Criterion	Covered	Total	%
statement	660	703	93.8
branch	279	342	81.5
condition	108	155	69.6
subroutine	138	146	94.5
pod	5	5	100.0
total	1190	1351	88.0

#======================================================================
package Data::Domain; # documentation at end of file
#======================================================================
use 5.010;
use strict;
use warnings;
use Carp;
use Data::Dumper;
use Scalar::Does 0.007;
use Scalar::Util ();
use Try::Tiny;
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.11";

our $MESSAGE;        # global var for last message from _matches()
our $MAX_DEEP = 100; # limit for recursive calls to inspect()

#----------------------------------------------------------------------
# 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 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        ],
  );
}

# setup exports through Sub::Exporter API
use Sub::Exporter -setup => {
  exports    => [ 'node_from_path',                                          # no longer documented, 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
#----------------------------------------------------------------------

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    => "data true/false",
      MATCH_ISA     => "is not a '%s'",
      MATCH_CAN     => "does not have method '%s'",
      MATCH_DOES    => "does not do '%s'",
      MATCH_BLESSED => "data blessed/unblessed",
      MATCH_PACKAGE => "data is/is not a package",
      MATCH_REF     => "is/is not a reference",
      MATCH_SMART   => "does not smart-match '%s'",
      MATCH_ISWEAK  => "weak/strong reference",
      MATCH_READONLY=> "readonly data",
      MATCH_TAINTED => "tainted/untainted",
    },
    Whatever => {
      MATCH_DEFINED => "data 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'"
    },
  },

  "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    => "donnée vraie/fausse",
      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 => "donnée blessed/unblessed",
      MATCH_PACKAGE => "est/n'est pas un package",
      MATCH_REF     => "est/n'est pas une référence",
      MATCH_SMART   => "n'obéit pas au smart-match '%s'",
      MATCH_ISWEAK  => "référence weak/strong",
      MATCH_READONLY=> "donnée readonly",
      MATCH_TAINTED => "tainted/untainted",
    },
    Whatever => {
      MATCH_DEFINED => "donnée définie/non définie",
    },
    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 champ interdit: '%s'",
    },
  },
};

# inherit Int and Nat messages from Num messages
foreach my $language (keys %$builtin_msgs) {
  $builtin_msgs->{$language}{$_} = $builtin_msgs->{$language}{Num}
    for qw/Int Nat/;
}

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

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

sub messages { # private 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) = @_;
  no warnings 'recursion';

  if (!defined $data) {
    # success if data was optional;
    return if $self->{-optional};

    # only the 'Whatever' domain can accept undef; other domains will fail
    return $self->msg(UNDEFINED => '')
      unless $self->isa("Data::Domain::Whatever");
  }
  else { # if $data is defined
    # 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::readonly($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 _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;
}




#----------------------------------------------------------------------
# METHODS FOR INTERNAL USE
#----------------------------------------------------------------------


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

  # 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->($msg_id, @args); # user function
      /^$/    and return "$name: $msgs";          # user constant string
      /^HASH/ and do { $msg =  $msgs->{$msg_id}   # user hash of msgs
                         and return sprintf "$name: $msg", @args;
                       last; # not found in this hash - revert to $global_msgs
                     };
      croak "invalid -messages option";           # otherwise
    }
  }

  # otherwise, try global messages
  return $global_msgs->($msg_id, @args)      if ref $global_msgs eq 'CODE';
  $msg = $global_msgs->{$subclass}{$msg_id}  # otherwise
      || $global_msgs->{Generic}{$msg_id}
     or croak "no error string for message $msg_id";

  return sprintf "$name: $msg", @args;
}


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 _expand_range {
  my ($self, $range_field, $min_field, $max_field) = @_;
  my $name = $self->{-name} || $self->subclass;

  # 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 {   # remove "at source_file, line ..." from error message
        (my $error_msg = $_) =~ s/\bat\b.*//s;
        # 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;
}


#----------------------------------------------------------------------
# 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/;

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 documented, 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;
}



#======================================================================
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 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);

  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
  $context ||= {root => $data,
                flat => {},
                path => []};
  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);
    $has_invalid ||= $msgs[$i];
  }

  # 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];
    }
  }

  # 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} || $any->[0]->subclass));

    # 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} || $subdomain->subclass));
    }
  }

  return; # OK, no error
}


#======================================================================
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/;
  my $self = Data::Domain::_parse_args(\@_, \@options, -fields => 'arrayref');
  bless $self, $class;

  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} = [keys %$fields];
  }
  else {
    croak "invalid data for -fields option";
  }

  # check that -exclude is an arrayref or a regex or a string
  if (my $exclude = $self->{-exclude}) {
    does($exclude, 'ARRAY') || does($exclude, 'Regexp') || !ref($exclude)
      or croak "invalid data for -exclude 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);

  # check if there are any forbidden fields
  if (my $exclude = $self->{-exclude}) {
  FIELD:
    foreach my $field (keys %$data) {
      next FIELD if $self->{-fields}{$field};

      return $self->msg(FORBIDDEN_FIELD => $field)
        if match::simple::match($field, $exclude)
        or match::simple::match($exclude, ['*', 'all']);
    }
  }

  my %msgs;
  my $has_invalid;

  # prepare context for calling lazy subdomains
  $context ||= {root => $data,
                flat => {},
                list => [],
                path => []};
  local $context->{flat} = {%{$context->{flat}}, %$data};

  # check fields of the domain
  foreach my $field (@{$self->{-fields_list}}) {
    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);
    $msgs{$field}  = $msg if $msg;
    $has_invalid ||=  $msg;
  }

  # 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);
    $msgs{-keys}   = $subdomain->inspect([keys %$data], $context)
      and $has_invalid = 1;
  }

  # 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);
    $msgs{-values} = $subdomain->inspect([values %$data], $context)
      and $has_invalid = 1;
  }

  return $has_invalid ? \%msgs : undef;
}

#======================================================================
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;
}


#======================================================================
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;
}


#======================================================================
1;


__END__