lib/Moose/Util/TypeConstraints.pm

   1
   2 package Moose::Util::TypeConstraints;
   3
   4 use Carp ();
   5 use List::MoreUtils qw( all any );
   6 use Scalar::Util qw( blessed reftype );
   7 use Moose::Exporter;
   8 use Moose::Deprecated;
   9
  10 ## --------------------------------------------------------
  11 # Prototyped subs must be predeclared because we have a
  12 # circular dependency with Moose::Meta::Attribute et. al.
  13 # so in case of us being use'd first the predeclaration
  14 # ensures the prototypes are in scope when consumers are
  15 # compiled.
  16
  17 # dah sugah!
  18 sub where (&);
  19 sub via (&);
  20 sub message (&);
  21 sub optimize_as (&);
  22 sub inline_as (&);
  23
  24 ## --------------------------------------------------------
  25
  26 use Moose::Deprecated;
  27 use Moose::Meta::TypeConstraint;
  28 use Moose::Meta::TypeConstraint::Union;
  29 use Moose::Meta::TypeConstraint::Parameterized;
  30 use Moose::Meta::TypeConstraint::Parameterizable;
  31 use Moose::Meta::TypeConstraint::Class;
  32 use Moose::Meta::TypeConstraint::Role;
  33 use Moose::Meta::TypeConstraint::Enum;
  34 use Moose::Meta::TypeConstraint::DuckType;
  35 use Moose::Meta::TypeCoercion;
  36 use Moose::Meta::TypeCoercion::Union;
  37 use Moose::Meta::TypeConstraint::Registry;
  38
  39 Moose::Exporter->setup_import_methods(
  40     as_is => [
  41         qw(
  42             type subtype class_type role_type maybe_type duck_type
  43             as where message optimize_as inline_as
  44             coerce from via
  45             enum union
  46             find_type_constraint
  47             register_type_constraint
  48             match_on_type )
  49     ],
  50 );
  51
  52 ## --------------------------------------------------------
  53 ## type registry and some useful functions for it
  54 ## --------------------------------------------------------
  55
  56 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
  57
  58 sub get_type_constraint_registry {$REGISTRY}
  59 sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
  60
  61 sub export_type_constraints_as_functions {
  62     my $pkg = caller();
  63     no strict 'refs';
  64     foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
  65         my $tc = $REGISTRY->get_type_constraint($constraint)
  66             ->_compiled_type_constraint;
  67         *{"${pkg}::${constraint}"}
  68             = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
  69     }
  70 }
  71
  72 sub create_type_constraint_union {
  73     _create_type_constraint_union(\@_);
  74 }
  75
  76 sub create_named_type_constraint_union {
  77     my $name = shift;
  78     _create_type_constraint_union($name, \@_);
  79 }
  80
  81 sub _create_type_constraint_union {
  82     my $name;
  83     $name = shift if @_ > 1;
  84     my @tcs = @{ shift() };
  85
  86     my @type_constraint_names;
  87
  88     if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) {
  89         @type_constraint_names = _parse_type_constraint_union( $tcs[0] );
  90     }
  91     else {
  92         @type_constraint_names = @tcs;
  93     }
  94
  95     ( scalar @type_constraint_names >= 2 )
  96         || __PACKAGE__->_throw_error(
  97         "You must pass in at least 2 type names to make a union");
  98
  99     my @type_constraints = map {
 100         find_or_parse_type_constraint($_)
 101             || __PACKAGE__->_throw_error(
 102             "Could not locate type constraint ($_) for the union");
 103     } @type_constraint_names;
 104
 105     my %options = (
 106       type_constraints => \@type_constraints
 107     );
 108     $options{name} = $name if defined $name;
 109
 110     return Moose::Meta::TypeConstraint::Union->new(%options);
 111 }
 112
 113
 114 sub create_parameterized_type_constraint {
 115     my $type_constraint_name = shift;
 116     my ( $base_type, $type_parameter )
 117         = _parse_parameterized_type_constraint($type_constraint_name);
 118
 119     ( defined $base_type && defined $type_parameter )
 120         || __PACKAGE__->_throw_error(
 121         "Could not parse type name ($type_constraint_name) correctly");
 122
 123     if ( $REGISTRY->has_type_constraint($base_type) ) {
 124         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
 125         return _create_parameterized_type_constraint(
 126             $base_type_tc,
 127             $type_parameter
 128         );
 129     }
 130     else {
 131         __PACKAGE__->_throw_error(
 132             "Could not locate the base type ($base_type)");
 133     }
 134 }
 135
 136 sub _create_parameterized_type_constraint {
 137     my ( $base_type_tc, $type_parameter ) = @_;
 138     if ( $base_type_tc->can('parameterize') ) {
 139         return $base_type_tc->parameterize($type_parameter);
 140     }
 141     else {
 142         return Moose::Meta::TypeConstraint::Parameterized->new(
 143             name   => $base_type_tc->name . '[' . $type_parameter . ']',
 144             parent => $base_type_tc,
 145             type_parameter =>
 146                 find_or_create_isa_type_constraint($type_parameter),
 147         );
 148     }
 149 }
 150
 151 #should we also support optimized checks?
 152 sub create_class_type_constraint {
 153     my ( $class, $options ) = @_;
 154
 155 # too early for this check
 156 #find_type_constraint("ClassName")->check($class)
 157 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 158
 159     my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) );
 160
 161     if (my $type = $REGISTRY->get_type_constraint($class)) {
 162         if (!($type->isa('Moose::Meta::TypeConstraint::Class') && $type->class eq $class)) {
 163             _confess(
 164                 "The type constraint '$class' has already been created in "
 165               . $type->_package_defined_in
 166               . " and cannot be created again in "
 167               . $pkg_defined_in )
 168         }
 169         else {
 170             return $type;
 171         }
 172     }
 173
 174     my %options = (
 175         class              => $class,
 176         name               => $class,
 177         package_defined_in => $pkg_defined_in,
 178         %{ $options || {} },
 179     );
 180
 181     $options{name} ||= "__ANON__";
 182
 183     my $tc = Moose::Meta::TypeConstraint::Class->new(%options);
 184     $REGISTRY->add_type_constraint($tc);
 185     return $tc;
 186 }
 187
 188 sub create_role_type_constraint {
 189     my ( $role, $options ) = @_;
 190
 191 # too early for this check
 192 #find_type_constraint("ClassName")->check($class)
 193 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 194
 195     my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) );
 196
 197     if (my $type = $REGISTRY->get_type_constraint($role)) {
 198         if (!($type->isa('Moose::Meta::TypeConstraint::Role') && $type->role eq $role)) {
 199             _confess(
 200                 "The type constraint '$role' has already been created in "
 201               . $type->_package_defined_in
 202               . " and cannot be created again in "
 203               . $pkg_defined_in )
 204         }
 205         else {
 206             return $type;
 207         }
 208     }
 209
 210     my %options = (
 211         role               => $role,
 212         name               => $role,
 213         package_defined_in => $pkg_defined_in,
 214         %{ $options || {} },
 215     );
 216
 217     $options{name} ||= "__ANON__";
 218
 219     my $tc = Moose::Meta::TypeConstraint::Role->new(%options);
 220     $REGISTRY->add_type_constraint($tc);
 221     return $tc;
 222 }
 223
 224 sub find_or_create_type_constraint {
 225     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 226
 227     if ( my $constraint
 228         = find_or_parse_type_constraint($type_constraint_name) ) {
 229         return $constraint;
 230     }
 231     elsif ( defined $options_for_anon_type ) {
 232
 233         # NOTE:
 234         # if there is no $options_for_anon_type
 235         # specified, then we assume they don't
 236         # want to create one, and return nothing.
 237
 238         # otherwise assume that we should create
 239         # an ANON type with the $options_for_anon_type
 240         # options which can be passed in. It should
 241         # be noted that these don't get registered
 242         # so we need to return it.
 243         # - SL
 244         return Moose::Meta::TypeConstraint->new(
 245             name => '__ANON__',
 246             %{$options_for_anon_type}
 247         );
 248     }
 249
 250     return;
 251 }
 252
 253 sub find_or_create_isa_type_constraint {
 254     my ($type_constraint_name, $options) = @_;
 255     find_or_parse_type_constraint($type_constraint_name)
 256         || create_class_type_constraint($type_constraint_name, $options);
 257 }
 258
 259 sub find_or_create_does_type_constraint {
 260     my ($type_constraint_name, $options) = @_;
 261     find_or_parse_type_constraint($type_constraint_name)
 262         || create_role_type_constraint($type_constraint_name, $options);
 263 }
 264
 265 sub find_or_parse_type_constraint {
 266     my $type_constraint_name = normalize_type_constraint_name(shift);
 267     my $constraint;
 268
 269     if ( $constraint = find_type_constraint($type_constraint_name) ) {
 270         return $constraint;
 271     }
 272     elsif ( _detect_type_constraint_union($type_constraint_name) ) {
 273         $constraint = create_type_constraint_union($type_constraint_name);
 274     }
 275     elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
 276         $constraint
 277             = create_parameterized_type_constraint($type_constraint_name);
 278     }
 279     else {
 280         return;
 281     }
 282
 283     $REGISTRY->add_type_constraint($constraint);
 284     return $constraint;
 285 }
 286
 287 sub normalize_type_constraint_name {
 288     my $type_constraint_name = shift;
 289     $type_constraint_name =~ s/\s//g;
 290     return $type_constraint_name;
 291 }
 292
 293 sub _confess {
 294     my $error = shift;
 295
 296     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 297     Carp::confess($error);
 298 }
 299
 300 ## --------------------------------------------------------
 301 ## exported functions ...
 302 ## --------------------------------------------------------
 303
 304 sub find_type_constraint {
 305     my $type = shift;
 306
 307     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
 308         return $type;
 309     }
 310     else {
 311         return unless $REGISTRY->has_type_constraint($type);
 312         return $REGISTRY->get_type_constraint($type);
 313     }
 314 }
 315
 316 sub register_type_constraint {
 317     my $constraint = shift;
 318     __PACKAGE__->_throw_error("can't register an unnamed type constraint")
 319         unless defined $constraint->name;
 320     $REGISTRY->add_type_constraint($constraint);
 321     return $constraint;
 322 }
 323
 324 # type constructors
 325
 326 sub type {
 327     my $name = shift;
 328
 329     my %p = map { %{$_} } @_;
 330
 331     return _create_type_constraint(
 332         $name, undef, $p{where}, $p{message},
 333         $p{optimize_as}, $p{inline_as},
 334     );
 335 }
 336
 337 sub subtype {
 338     if ( @_ == 1 && !ref $_[0] ) {
 339         __PACKAGE__->_throw_error(
 340             'A subtype cannot consist solely of a name, it must have a parent'
 341         );
 342     }
 343
 344     # The blessed check is mostly to accommodate MooseX::Types, which
 345     # uses an object which overloads stringification as a type name.
 346     my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
 347
 348     my %p = map { %{$_} } @_;
 349
 350     # subtype Str => where { ... };
 351     if ( !exists $p{as} ) {
 352         $p{as} = $name;
 353         $name = undef;
 354     }
 355
 356     return _create_type_constraint(
 357         $name, $p{as}, $p{where}, $p{message},
 358         $p{optimize_as}, $p{inline_as},
 359     );
 360 }
 361
 362 sub class_type {
 363     create_class_type_constraint(@_);
 364 }
 365
 366 sub role_type ($;$) {
 367     create_role_type_constraint(@_);
 368 }
 369
 370 sub maybe_type {
 371     my ($type_parameter) = @_;
 372
 373     register_type_constraint(
 374         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
 375     );
 376 }
 377
 378 sub duck_type {
 379     my ( $type_name, @methods ) = @_;
 380     if ( ref $type_name eq 'ARRAY' && !@methods ) {
 381         @methods   = ($type_name);
 382         $type_name = undef;
 383     }
 384     if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
 385         @methods = @{ $methods[0] };
 386     }
 387     else {
 388         Moose::Deprecated::deprecated(
 389             feature => 'non-arrayref form of duck_type',
 390             message => "Passing a list of values to duck_type is deprecated. "
 391                      . "The method names should be wrapped in an arrayref.",
 392         );
 393     }
 394
 395     register_type_constraint(
 396         create_duck_type_constraint(
 397             $type_name,
 398             \@methods,
 399         )
 400     );
 401 }
 402
 403 sub coerce {
 404     my ( $type_name, @coercion_map ) = @_;
 405     _install_type_coercions( $type_name, \@coercion_map );
 406 }
 407
 408 # The trick of returning @_ lets us avoid having to specify a
 409 # prototype. Perl will parse this:
 410 #
 411 # subtype 'Foo'
 412 #     => as 'Str'
 413 #     => where { ... }
 414 #
 415 # as this:
 416 #
 417 # subtype( 'Foo', as( 'Str', where { ... } ) );
 418 #
 419 # If as() returns all its extra arguments, this just works, and
 420 # preserves backwards compatibility.
 421 sub as { { as => shift }, @_ }
 422 sub where (&)       { { where       => $_[0] } }
 423 sub message (&)     { { message     => $_[0] } }
 424 sub optimize_as (&) { { optimize_as => $_[0] } }
 425 sub inline_as (&)   { { inline_as   => $_[0] } }
 426
 427 sub from    {@_}
 428 sub via (&) { $_[0] }
 429
 430 sub enum {
 431     my ( $type_name, @values ) = @_;
 432
 433     # NOTE:
 434     # if only an array-ref is passed then
 435     # you get an anon-enum
 436     # - SL
 437     if ( ref $type_name eq 'ARRAY' ) {
 438         @values == 0
 439             || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?");
 440
 441         @values    = ($type_name);
 442         $type_name = undef;
 443     }
 444     if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
 445         @values = @{ $values[0] };
 446     }
 447     else {
 448         Moose::Deprecated::deprecated(
 449             feature => 'non-arrayref form of enum',
 450             message => "Passing a list of values to enum is deprecated. "
 451                      . "Enum values should be wrapped in an arrayref.",
 452         );
 453     }
 454
 455     register_type_constraint(
 456         create_enum_type_constraint(
 457             $type_name,
 458             \@values,
 459         )
 460     );
 461 }
 462
 463 sub union {
 464   my ( $type_name, @constraints ) = @_;
 465   if ( ref $type_name eq 'ARRAY' ) {
 466     @constraints == 0
 467       || __PACKAGE__->_throw_error("union called with an array reference and additional arguments.");
 468     @constraints = @$type_name;
 469     $type_name   = undef;
 470   }
 471   if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) {
 472     @constraints = @{ $constraints[0] };
 473   }
 474   if ( defined $type_name ) {
 475     return register_type_constraint(
 476       create_named_type_constraint_union( $type_name, @constraints )
 477     );
 478   }
 479   return create_type_constraint_union( @constraints );
 480 }
 481
 482 sub create_enum_type_constraint {
 483     my ( $type_name, $values ) = @_;
 484
 485     Moose::Meta::TypeConstraint::Enum->new(
 486         name => $type_name || '__ANON__',
 487         values => $values,
 488     );
 489 }
 490
 491 sub create_duck_type_constraint {
 492     my ( $type_name, $methods ) = @_;
 493
 494     Moose::Meta::TypeConstraint::DuckType->new(
 495         name => $type_name || '__ANON__',
 496         methods => $methods,
 497     );
 498 }
 499
 500 sub match_on_type {
 501     my ($to_match, @cases) = @_;
 502     my $default;
 503     if (@cases % 2 != 0) {
 504         $default = pop @cases;
 505         (ref $default eq 'CODE')
 506             || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
 507     }
 508     while (@cases) {
 509         my ($type, $action) = splice @cases, 0, 2;
 510
 511         unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
 512             $type = find_or_parse_type_constraint($type)
 513                  || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
 514         }
 515
 516         (ref $action eq 'CODE')
 517             || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
 518
 519         if ($type->check($to_match)) {
 520             local $_ = $to_match;
 521             return $action->($to_match);
 522         }
 523     }
 524     (defined $default)
 525         || __PACKAGE__->_throw_error("No cases matched for $to_match");
 526     {
 527         local $_ = $to_match;
 528         return $default->($to_match);
 529     }
 530 }
 531
 532
 533 ## --------------------------------------------------------
 534 ## desugaring functions ...
 535 ## --------------------------------------------------------
 536
 537 sub _create_type_constraint ($$$;$$) {
 538     my $name      = shift;
 539     my $parent    = shift;
 540     my $check     = shift;
 541     my $message   = shift;
 542     my $optimized = shift;
 543     my $inlined   = shift;
 544
 545     my $pkg_defined_in = scalar( caller(1) );
 546
 547     if ( defined $name ) {
 548         my $type = $REGISTRY->get_type_constraint($name);
 549
 550         ( $type->_package_defined_in eq $pkg_defined_in )
 551             || _confess(
 552                   "The type constraint '$name' has already been created in "
 553                 . $type->_package_defined_in
 554                 . " and cannot be created again in "
 555                 . $pkg_defined_in )
 556             if defined $type;
 557
 558         $name =~ /^[\w:\.]+$/
 559             or die qq{$name contains invalid characters for a type name.}
 560             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 561     }
 562
 563     my %opts = (
 564         name               => $name,
 565         package_defined_in => $pkg_defined_in,
 566
 567         ( $check     ? ( constraint => $check )     : () ),
 568         ( $message   ? ( message    => $message )   : () ),
 569         ( $optimized ? ( optimized  => $optimized ) : () ),
 570         ( $inlined   ? ( inlined    => $inlined )   : () ),
 571     );
 572
 573     my $constraint;
 574     if (
 575         defined $parent
 576         and $parent
 577         = blessed $parent
 578         ? $parent
 579         : find_or_create_isa_type_constraint($parent)
 580         ) {
 581         $constraint = $parent->create_child_type(%opts);
 582     }
 583     else {
 584         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 585     }
 586
 587     $REGISTRY->add_type_constraint($constraint)
 588         if defined $name;
 589
 590     return $constraint;
 591 }
 592
 593 sub _install_type_coercions ($$) {
 594     my ( $type_name, $coercion_map ) = @_;
 595     my $type = find_type_constraint($type_name);
 596     ( defined $type )
 597         || __PACKAGE__->_throw_error(
 598         "Cannot find type '$type_name', perhaps you forgot to load it");
 599     if ( $type->has_coercion ) {
 600         $type->coercion->add_type_coercions(@$coercion_map);
 601     }
 602     else {
 603         my $type_coercion = Moose::Meta::TypeCoercion->new(
 604             type_coercion_map => $coercion_map,
 605             type_constraint   => $type
 606         );
 607         $type->coercion($type_coercion);
 608     }
 609 }
 610
 611 ## --------------------------------------------------------
 612 ## type notation parsing ...
 613 ## --------------------------------------------------------
 614
 615 {
 616
 617     # All I have to say is mugwump++ cause I know
 618     # do not even have enough regexp-fu to be able
 619     # to have written this (I can only barely
 620     # understand it as it is)
 621     # - SL
 622
 623     use re "eval";
 624
 625     my $valid_chars = qr{[\w:\.]};
 626     my $type_atom   = qr{ (?>$valid_chars+) }x;
 627     my $ws          = qr{ (?>\s*) }x;
 628     my $op_union    = qr{ $ws \| $ws }x;
 629
 630     my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
 631     if (Class::MOP::IS_RUNNING_ON_5_10) {
 632         my $type_pattern
 633             = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
 634         my $type_capture_parts_pattern
 635             = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
 636         my $type_with_parameter_pattern
 637             = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
 638         my $union_pattern
 639             = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
 640         my $any_pattern
 641             = q{ (?&type) | (?&union) };
 642
 643         my $defines = qr{(?(DEFINE)
 644             (?<valid_chars>         $valid_chars)
 645             (?<type_atom>           $type_atom)
 646             (?<ws>                  $ws)
 647             (?<op_union>            $op_union)
 648             (?<type>                $type_pattern)
 649             (?<type_capture_parts>  $type_capture_parts_pattern)
 650             (?<type_with_parameter> $type_with_parameter_pattern)
 651             (?<union>               $union_pattern)
 652             (?<any>                 $any_pattern)
 653         )}x;
 654
 655         $type                = qr{ $type_pattern                $defines }x;
 656         $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
 657         $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
 658         $union               = qr{ $union_pattern               $defines }x;
 659         $any                 = qr{ $any_pattern                 $defines }x;
 660     }
 661     else {
 662         $type
 663             = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
 664         $type_capture_parts
 665             = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
 666         $type_with_parameter
 667             = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
 668         $union
 669             = qr{ $type (?> (?: $op_union $type )+ ) }x;
 670         $any
 671             = qr{ $type | $union }x;
 672     }
 673
 674
 675     sub _parse_parameterized_type_constraint {
 676         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 677         $_[0] =~ m{ $type_capture_parts }x;
 678         return ( $1, $2 );
 679     }
 680
 681     sub _detect_parameterized_type_constraint {
 682         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 683         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 684     }
 685
 686     sub _parse_type_constraint_union {
 687         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 688         my $given = shift;
 689         my @rv;
 690         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 691             push @rv => $1;
 692         }
 693         ( pos($given) eq length($given) )
 694             || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
 695                 . pos($given)
 696                 . " and str-length="
 697                 . length($given)
 698                 . ")" );
 699         @rv;
 700     }
 701
 702     sub _detect_type_constraint_union {
 703         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 704         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 705     }
 706 }
 707
 708 ## --------------------------------------------------------
 709 # define some basic built-in types
 710 ## --------------------------------------------------------
 711
 712 # By making these classes immutable before creating all the types in
 713 # Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow
 714 # MOP-based accessors.
 715 $_->make_immutable(
 716     inline_constructor => 1,
 717     constructor_name   => "_new",
 718
 719     # these are Class::MOP accessors, so they need inlining
 720     inline_accessors => 1
 721     ) for grep { $_->is_mutable }
 722     map { Class::MOP::class_of($_) }
 723     qw(
 724     Moose::Meta::TypeConstraint
 725     Moose::Meta::TypeConstraint::Union
 726     Moose::Meta::TypeConstraint::Parameterized
 727     Moose::Meta::TypeConstraint::Parameterizable
 728     Moose::Meta::TypeConstraint::Class
 729     Moose::Meta::TypeConstraint::Role
 730     Moose::Meta::TypeConstraint::Enum
 731     Moose::Meta::TypeConstraint::DuckType
 732     Moose::Meta::TypeConstraint::Registry
 733 );
 734
 735 require Moose::Util::TypeConstraints::Builtins;
 736 Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY);
 737
 738 my @PARAMETERIZABLE_TYPES
 739     = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
 740
 741 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 742
 743 sub add_parameterizable_type {
 744     my $type = shift;
 745     ( blessed $type
 746             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
 747         || __PACKAGE__->_throw_error(
 748         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
 749         );
 750     push @PARAMETERIZABLE_TYPES => $type;
 751 }
 752
 753 ## --------------------------------------------------------
 754 # end of built-in types ...
 755 ## --------------------------------------------------------
 756
 757 {
 758     my @BUILTINS = list_all_type_constraints();
 759     sub list_all_builtin_type_constraints {@BUILTINS}
 760 }
 761
 762 sub _throw_error {
 763     shift;
 764     require Moose;
 765     unshift @_, 'Moose';
 766     goto &Moose::throw_error;
 767 }
 768
 769 1;
 770
 771 # ABSTRACT: Type constraint system for Moose
 772
 773 __END__
 774
 775 =pod
 776
 777 =head1 SYNOPSIS
 778
 779   use Moose::Util::TypeConstraints;
 780
 781   subtype 'Natural',
 782       as 'Int',
 783       where { $_ > 0 };
 784
 785   subtype 'NaturalLessThanTen',
 786       as 'Natural',
 787       where { $_ < 10 },
 788       message { "This number ($_) is not less than ten!" };
 789
 790   coerce 'Num',
 791       from 'Str',
 792       via { 0+$_ };
 793
 794   class_type 'DateTimeClass', { class => 'DateTime' };
 795
 796   role_type 'Barks', { role => 'Some::Library::Role::Barks' };
 797
 798   enum 'RGBColors', [qw(red green blue)];
 799
 800   union 'StringOrArray', [qw( String Array )];
 801
 802   no Moose::Util::TypeConstraints;
 803
 804 =head1 DESCRIPTION
 805
 806 This module provides Moose with the ability to create custom type
 807 constraints to be used in attribute definition.
 808
 809 =head2 Important Caveat
 810
 811 This is B<NOT> a type system for Perl 5. These are type constraints,
 812 and they are not used by Moose unless you tell it to. No type
 813 inference is performed, expressions are not typed, etc. etc. etc.
 814
 815 A type constraint is at heart a small "check if a value is valid"
 816 function. A constraint can be associated with an attribute. This
 817 simplifies parameter validation, and makes your code clearer to read,
 818 because you can refer to constraints by name.
 819
 820 =head2 Slightly Less Important Caveat
 821
 822 It is B<always> a good idea to quote your type names.
 823
 824 This prevents Perl from trying to execute the call as an indirect
 825 object call. This can be an issue when you have a subtype with the
 826 same name as a valid class.
 827
 828 For instance:
 829
 830   subtype DateTime => as Object => where { $_->isa('DateTime') };
 831
 832 will I<just work>, while this:
 833
 834   use DateTime;
 835   subtype DateTime => as Object => where { $_->isa('DateTime') };
 836
 837 will fail silently and cause many headaches. The simple way to solve
 838 this, as well as future proof your subtypes from classes which have
 839 yet to have been created, is to quote the type name:
 840
 841   use DateTime;
 842   subtype 'DateTime', as 'Object', where { $_->isa('DateTime') };
 843
 844 =head2 Default Type Constraints
 845
 846 This module also provides a simple hierarchy for Perl 5 types, here is
 847 that hierarchy represented visually.
 848
 849   Any
 850   Item
 851       Bool
 852       Maybe[`a]
 853       Undef
 854       Defined
 855           Value
 856               Str
 857                   Num
 858                       Int
 859                   ClassName
 860                   RoleName
 861           Ref
 862               ScalarRef[`a]
 863               ArrayRef[`a]
 864               HashRef[`a]
 865               CodeRef
 866               RegexpRef
 867               GlobRef
 868               FileHandle
 869               Object
 870
 871 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 872 parameterized, this means you can say:
 873
 874   ArrayRef[Int]    # an array of integers
 875   HashRef[CodeRef] # a hash of str to CODE ref mappings
 876   ScalarRef[Int]   # a reference to an integer
 877   Maybe[Str]       # value may be a string, may be undefined
 878
 879 If Moose finds a name in brackets that it does not recognize as an
 880 existing type, it assumes that this is a class name, for example
 881 C<ArrayRef[DateTime]>.
 882
 883 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 884 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 885 name, I<not> as a parameterization of C<ArrayRef>.
 886
 887 B<NOTE:> The C<Undef> type constraint for the most part works
 888 correctly now, but edge cases may still exist, please use it
 889 sparingly.
 890
 891 B<NOTE:> The C<ClassName> type constraint does a complex package
 892 existence check. This means that your class B<must> be loaded for this
 893 type constraint to pass.
 894
 895 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 896 name> which is a role, like C<'MyApp::Role::Comparable'>.
 897
 898 =head2 Type Constraint Naming
 899
 900 Type name declared via this module can only contain alphanumeric
 901 characters, colons (:), and periods (.).
 902
 903 Since the types created by this module are global, it is suggested
 904 that you namespace your types just as you would namespace your
 905 modules. So instead of creating a I<Color> type for your
 906 B<My::Graphics> module, you would call the type
 907 I<My::Graphics::Types::Color> instead.
 908
 909 =head2 Use with Other Constraint Modules
 910
 911 This module can play nicely with other constraint modules with some
 912 slight tweaking. The C<where> clause in types is expected to be a
 913 C<CODE> reference which checks its first argument and returns a
 914 boolean. Since most constraint modules work in a similar way, it
 915 should be simple to adapt them to work with Moose.
 916
 917 For instance, this is how you could use it with
 918 L<Declare::Constraints::Simple> to declare a completely new type.
 919
 920   type 'HashOfArrayOfObjects',
 921       where {
 922           IsHashRef(
 923               -keys   => HasLength,
 924               -values => IsArrayRef(IsObject)
 925           )->(@_);
 926       };
 927
 928 For more examples see the F<t/examples/example_w_DCS.t> test
 929 file.
 930
 931 Here is an example of using L<Test::Deep> and its non-test
 932 related C<eq_deeply> function.
 933
 934   type 'ArrayOfHashOfBarsAndRandomNumbers',
 935       where {
 936           eq_deeply($_,
 937               array_each(subhashof({
 938                   bar           => isa('Bar'),
 939                   random_number => ignore()
 940               })))
 941         };
 942
 943 For a complete example see the
 944 F<t/examples/example_w_TestDeep.t> test file.
 945
 946 =head2 Error messages
 947
 948 Type constraints can also specify custom error messages, for when they fail to
 949 validate. This is provided as just another coderef, which receives the invalid
 950 value in C<$_>, as in:
 951
 952   subtype 'PositiveInt',
 953        as 'Int',
 954        where { $_ > 0 },
 955        message { "$_ is not a positive integer!" };
 956
 957 If no message is specified, a default message will be used, which indicates
 958 which type constraint was being used and what value failed. If
 959 L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to
 960 display the invalid value, otherwise it will just be printed as is.
 961
 962 =head1 FUNCTIONS
 963
 964 =head2 Type Constraint Constructors
 965
 966 The following functions are used to create type constraints.  They
 967 will also register the type constraints your create in a global
 968 registry that is used to look types up by name.
 969
 970 See the L</SYNOPSIS> for an example of how to use these.
 971
 972 =over 4
 973
 974 =item B<< subtype 'Name', as 'Parent', where { } ... >>
 975
 976 This creates a named subtype.
 977
 978 If you provide a parent that Moose does not recognize, it will
 979 automatically create a new class type constraint for this name.
 980
 981 When creating a named type, the C<subtype> function should either be
 982 called with the sugar helpers (C<where>, C<message>, etc), or with a
 983 name and a hashref of parameters:
 984
 985  subtype( 'Foo', { where => ..., message => ... } );
 986
 987 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 988 and C<optimize_as>.
 989
 990 =item B<< subtype as 'Parent', where { } ... >>
 991
 992 This creates an unnamed subtype and will return the type
 993 constraint meta-object, which will be an instance of
 994 L<Moose::Meta::TypeConstraint>.
 995
 996 When creating an anonymous type, the C<subtype> function should either
 997 be called with the sugar helpers (C<where>, C<message>, etc), or with
 998 just a hashref of parameters:
 999
1000  subtype( { where => ..., message => ... } );
1001
1002 =item B<class_type ($class, ?$options)>
1003
1004 Creates a new subtype of C<Object> with the name C<$class> and the
1005 metaclass L<Moose::Meta::TypeConstraint::Class>.
1006
1007   # Create a type called 'Box' which tests for objects which ->isa('Box')
1008   class_type 'Box';
1009
1010 By default, the name of the type and the name of the class are the same, but
1011 you can specify both separately.
1012
1013   # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box');
1014   class_type 'Box', { class => 'ObjectLibrary::Box' };
1015
1016 =item B<role_type ($role, ?$options)>
1017
1018 Creates a C<Role> type constraint with the name C<$role> and the
1019 metaclass L<Moose::Meta::TypeConstraint::Role>.
1020
1021   # Create a type called 'Walks' which tests for objects which ->does('Walks')
1022   role_type 'Walks';
1023
1024 By default, the name of the type and the name of the role are the same, but
1025 you can specify both separately.
1026
1027   # Create a type called 'Walks' which tests for objects which ->does('MooseX::Role::Walks');
1028   role_type 'Walks', { role => 'MooseX::Role::Walks' };
1029
1030 =item B<maybe_type ($type)>
1031
1032 Creates a type constraint for either C<undef> or something of the
1033 given type.
1034
1035 =item B<duck_type ($name, \@methods)>
1036
1037 This will create a subtype of Object and test to make sure the value
1038 C<can()> do the methods in C<\@methods>.
1039
1040 This is intended as an easy way to accept non-Moose objects that
1041 provide a certain interface. If you're using Moose classes, we
1042 recommend that you use a C<requires>-only Role instead.
1043
1044 =item B<duck_type (\@methods)>
1045
1046 If passed an ARRAY reference as the only parameter instead of the
1047 C<$name>, C<\@methods> pair, this will create an unnamed duck type.
1048 This can be used in an attribute definition like so:
1049
1050   has 'cache' => (
1051       is  => 'ro',
1052       isa => duck_type( [qw( get_set )] ),
1053   );
1054
1055 =item B<enum ($name, \@values)>
1056
1057 This will create a basic subtype for a given set of strings.
1058 The resulting constraint will be a subtype of C<Str> and
1059 will match any of the items in C<\@values>. It is case sensitive.
1060 See the L</SYNOPSIS> for a simple example.
1061
1062 B<NOTE:> This is not a true proper enum type, it is simply
1063 a convenient constraint builder.
1064
1065 =item B<enum (\@values)>
1066
1067 If passed an ARRAY reference as the only parameter instead of the
1068 C<$name>, C<\@values> pair, this will create an unnamed enum. This
1069 can then be used in an attribute definition like so:
1070
1071   has 'sort_order' => (
1072       is  => 'ro',
1073       isa => enum([qw[ ascending descending ]]),
1074   );
1075
1076 =item B<union ($name, \@constraints)>
1077
1078 This will create a basic subtype where any of the provided constraints
1079 may match in order to satisfy this constraint.
1080
1081 =item B<union (\@constraints)>
1082
1083 If passed an ARRAY reference as the only parameter instead of the
1084 C<$name>, C<\@constraints> pair, this will create an unnamed union.
1085 This can then be used in an attribute definition like so:
1086
1087   has 'items' => (
1088       is => 'ro',
1089       isa => union([qw[ Str ArrayRef ]]),
1090   );
1091
1092 This is similar to the existing string union:
1093
1094   isa => 'Str|ArrayRef'
1095
1096 except that it supports anonymous elements as child constraints:
1097
1098   has 'color' => (
1099     isa => 'ro',
1100     isa => union([ 'Int',  enum([qw[ red green blue ]]) ]),
1101   );
1102
1103 =item B<as 'Parent'>
1104
1105 This is just sugar for the type constraint construction syntax.
1106
1107 It takes a single argument, which is the name of a parent type.
1108
1109 =item B<where { ... }>
1110
1111 This is just sugar for the type constraint construction syntax.
1112
1113 It takes a subroutine reference as an argument. When the type
1114 constraint is tested, the reference is run with the value to be tested
1115 in C<$_>. This reference should return true or false to indicate
1116 whether or not the constraint check passed.
1117
1118 =item B<message { ... }>
1119
1120 This is just sugar for the type constraint construction syntax.
1121
1122 It takes a subroutine reference as an argument. When the type
1123 constraint fails, then the code block is run with the value provided
1124 in C<$_>. This reference should return a string, which will be used in
1125 the text of the exception thrown.
1126
1127 =item B<inline_as { ... }>
1128
1129 This can be used to define a "hand optimized" inlinable version of your type
1130 constraint.
1131
1132 You provide a subroutine which will be called I<as a method> on a
1133 L<Moose::Meta::TypeConstraint> object. It will receive a single parameter, the
1134 name of the variable to check, typically something like C<"$_"> or C<"$_[0]">.
1135
1136 The subroutine should return a code string suitable for inlining. You can
1137 assume that the check will be wrapped in parentheses when it is inlined.
1138
1139 The inlined code should include any checks that your type's parent types
1140 do. If your parent type constraint defines its own inlining, you can simply use
1141 that to avoid repeating code. For example, here is the inlining code for the
1142 C<Value> type, which is a subtype of C<Defined>:
1143
1144     sub {
1145         $_[0]->parent()->_inline_check($_[1])
1146         . ' && !ref(' . $_[1] . ')'
1147     }
1148
1149 =item B<optimize_as { ... }>
1150
1151 B<This feature is deprecated, use C<inline_as> instead.>
1152
1153 This can be used to define a "hand optimized" version of your
1154 type constraint which can be used to avoid traversing a subtype
1155 constraint hierarchy.
1156
1157 B<NOTE:> You should only use this if you know what you are doing.
1158 All the built in types use this, so your subtypes (assuming they
1159 are shallow) will not likely need to use this.
1160
1161 =item B<< type 'Name', where { } ... >>
1162
1163 This creates a base type, which has no parent.
1164
1165 The C<type> function should either be called with the sugar helpers
1166 (C<where>, C<message>, etc), or with a name and a hashref of
1167 parameters:
1168
1169   type( 'Foo', { where => ..., message => ... } );
1170
1171 The valid hashref keys are C<where>, C<message>, and C<inlined_as>.
1172
1173 =back
1174
1175 =head2 Type Constraint Utilities
1176
1177 =over 4
1178
1179 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
1180
1181 This is a utility function for doing simple type based dispatching similar to
1182 match/case in OCaml and case/of in Haskell. It is not as featureful as those
1183 languages, nor does not it support any kind of automatic destructuring
1184 bind. Here is a simple Perl pretty printer dispatching over the core Moose
1185 types.
1186
1187   sub ppprint {
1188       my $x = shift;
1189       match_on_type $x => (
1190           HashRef => sub {
1191               my $hash = shift;
1192               '{ '
1193                   . (
1194                   join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
1195                       sort keys %$hash
1196                   ) . ' }';
1197           },
1198           ArrayRef => sub {
1199               my $array = shift;
1200               '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
1201           },
1202           CodeRef   => sub {'sub { ... }'},
1203           RegexpRef => sub { 'qr/' . $_ . '/' },
1204           GlobRef   => sub { '*' . B::svref_2object($_)->NAME },
1205           Object    => sub { $_->can('to_string') ? $_->to_string : $_ },
1206           ScalarRef => sub { '\\' . ppprint( ${$_} ) },
1207           Num       => sub {$_},
1208           Str       => sub { '"' . $_ . '"' },
1209           Undef     => sub {'undef'},
1210           => sub { die "I don't know what $_ is" }
1211       );
1212   }
1213
1214 Or a simple JSON serializer:
1215
1216   sub to_json {
1217       my $x = shift;
1218       match_on_type $x => (
1219           HashRef => sub {
1220               my $hash = shift;
1221               '{ '
1222                   . (
1223                   join ", " =>
1224                       map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
1225                       sort keys %$hash
1226                   ) . ' }';
1227           },
1228           ArrayRef => sub {
1229               my $array = shift;
1230               '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
1231           },
1232           Num   => sub {$_},
1233           Str   => sub { '"' . $_ . '"' },
1234           Undef => sub {'null'},
1235           => sub { die "$_ is not acceptable json type" }
1236       );
1237   }
1238
1239 The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
1240 be either a string type or a L<Moose::Meta::TypeConstraint> object, and
1241 C<\&action> is a subroutine reference. This function will dispatch on the
1242 first match for C<$value>. It is possible to have a catch-all by providing an
1243 additional subroutine reference as the final argument to C<match_on_type>.
1244
1245 =back
1246
1247 =head2 Type Coercion Constructors
1248
1249 You can define coercions for type constraints, which allow you to
1250 automatically transform values to something valid for the type
1251 constraint. If you ask your accessor to coerce, then Moose will run
1252 the type-coercion code first, followed by the type constraint
1253 check. This feature should be used carefully as it is very powerful
1254 and could easily take off a limb if you are not careful.
1255
1256 See the L</SYNOPSIS> for an example of how to use these.
1257
1258 =over 4
1259
1260 =item B<< coerce 'Name', from 'OtherName', via { ... }  >>
1261
1262 This defines a coercion from one type to another. The C<Name> argument
1263 is the type you are coercing I<to>.
1264
1265 To define multiple coercions, supply more sets of from/via pairs:
1266
1267   coerce 'Name',
1268     from 'OtherName', via { ... },
1269     from 'ThirdName', via { ... };
1270
1271 =item B<from 'OtherName'>
1272
1273 This is just sugar for the type coercion construction syntax.
1274
1275 It takes a single type name (or type object), which is the type being
1276 coerced I<from>.
1277
1278 =item B<via { ... }>
1279
1280 This is just sugar for the type coercion construction syntax.
1281
1282 It takes a subroutine reference. This reference will be called with
1283 the value to be coerced in C<$_>. It is expected to return a new value
1284 of the proper type for the coercion.
1285
1286 =back
1287
1288 =head2 Creating and Finding Type Constraints
1289
1290 These are additional functions for creating and finding type
1291 constraints. Most of these functions are not available for
1292 importing. The ones that are importable as specified.
1293
1294 =over 4
1295
1296 =item B<find_type_constraint($type_name)>
1297
1298 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1299 object for a named type.
1300
1301 This function is importable.
1302
1303 =item B<register_type_constraint($type_object)>
1304
1305 This function will register a L<Moose::Meta::TypeConstraint> with the
1306 global type registry.
1307
1308 This function is importable.
1309
1310 =item B<normalize_type_constraint_name($type_constraint_name)>
1311
1312 This method takes a type constraint name and returns the normalized
1313 form. This removes any whitespace in the string.
1314
1315 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1316
1317 =item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)>
1318
1319 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1320 or a list of names. It returns a new
1321 L<Moose::Meta::TypeConstraint::Union> object.
1322
1323 =item B<create_parameterized_type_constraint($type_name)>
1324
1325 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1326 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1327 object. The C<BaseType> must exist already exist as a parameterizable
1328 type.
1329
1330 =item B<create_class_type_constraint($class, $options)>
1331
1332 Given a class name this function will create a new
1333 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1334
1335 The C<$options> is a hash reference that will be passed to the
1336 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1337
1338 =item B<create_role_type_constraint($role, $options)>
1339
1340 Given a role name this function will create a new
1341 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1342
1343 The C<$options> is a hash reference that will be passed to the
1344 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1345
1346 =item B<create_enum_type_constraint($name, $values)>
1347
1348 Given a enum name this function will create a new
1349 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1350
1351 =item B<create_duck_type_constraint($name, $methods)>
1352
1353 Given a duck type name this function will create a new
1354 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
1355
1356 =item B<find_or_parse_type_constraint($type_name)>
1357
1358 Given a type name, this first attempts to find a matching constraint
1359 in the global registry.
1360
1361 If the type name is a union or parameterized type, it will create a
1362 new object of the appropriate, but if given a "regular" type that does
1363 not yet exist, it simply returns false.
1364
1365 When given a union or parameterized type, the member or base type must
1366 already exist.
1367
1368 If it creates a new union or parameterized type, it will add it to the
1369 global registry.
1370
1371 =item B<find_or_create_isa_type_constraint($type_name)>
1372
1373 =item B<find_or_create_does_type_constraint($type_name)>
1374
1375 These functions will first call C<find_or_parse_type_constraint>. If
1376 that function does not return a type, a new type object will
1377 be created.
1378
1379 The C<isa> variant will use C<create_class_type_constraint> and the
1380 C<does> variant will use C<create_role_type_constraint>.
1381
1382 =item B<get_type_constraint_registry>
1383
1384 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1385 keeps track of all type constraints.
1386
1387 =item B<list_all_type_constraints>
1388
1389 This will return a list of type constraint names in the global
1390 registry. You can then fetch the actual type object using
1391 C<find_type_constraint($type_name)>.
1392
1393 =item B<list_all_builtin_type_constraints>
1394
1395 This will return a list of builtin type constraints, meaning those
1396 which are defined in this module. See the L<Default Type Constraints>
1397 section for a complete list.
1398
1399 =item B<export_type_constraints_as_functions>
1400
1401 This will export all the current type constraints as functions into
1402 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1403 mostly used for testing, but it might prove useful to others.
1404
1405 =item B<get_all_parameterizable_types>
1406
1407 This returns all the parameterizable types that have been registered,
1408 as a list of type objects.
1409
1410 =item B<add_parameterizable_type($type)>
1411
1412 Adds C<$type> to the list of parameterizable types
1413
1414 =back
1415
1416 =head1 BUGS
1417
1418 See L<Moose/BUGS> for details on reporting bugs.
1419
1420 =cut