File Coverage

blib/lib/Types/Common/Numeric.pm
Criterion Covered Total %
statement 21 21 100.0
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 29 29 100.0


line stmt bran cond sub pod time code
1             package Types::Common::Numeric;
2              
3 36     36   83524 use 5.008001;
  36         157  
4 36     36   1542 use strict;
  36         111  
  36         2195  
5 36     36   237 use warnings;
  36         125  
  36         1886  
6              
7             BEGIN {
8 36     36   123 $Types::Common::Numeric::AUTHORITY = 'cpan:TOBYINK';
9 36         2406 $Types::Common::Numeric::VERSION = '2.004000';
10             }
11              
12             $Types::Common::Numeric::VERSION =~ tr/_//d;
13              
14 36         3033 use Type::Library -base, -declare => qw(
15             PositiveNum PositiveOrZeroNum
16             PositiveInt PositiveOrZeroInt
17             NegativeNum NegativeOrZeroNum
18             NegativeInt NegativeOrZeroInt
19             SingleDigit
20             NumRange IntRange
21 36     36   9521 );
  36         1470  
22              
23 36     36   2776 use Type::Tiny ();
  36         87  
  36         986  
24 36     36   10738 use Types::Standard qw( Num Int Bool );
  36         119  
  36         368  
25              
26 14     14   106 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  14         68  
27              
28             my $meta = __PACKAGE__->meta;
29              
30             $meta->add_type(
31             name => 'PositiveNum',
32             parent => Num,
33             constraint => sub { $_ > 0 },
34             inlined => sub { undef, qq($_ > 0) },
35             message => sub { "Must be a positive number" },
36             );
37              
38             $meta->add_type(
39             name => 'PositiveOrZeroNum',
40             parent => Num,
41             constraint => sub { $_ >= 0 },
42             inlined => sub { undef, qq($_ >= 0) },
43             message => sub { "Must be a number greater than or equal to zero" },
44             type_default => sub { return 0; },
45             );
46              
47             my ( $pos_int, $posz_int );
48             if ( Type::Tiny::_USE_XS ) {
49             $pos_int = Type::Tiny::XS::get_coderef_for( 'PositiveInt' )
50             if Type::Tiny::XS->VERSION >= 0.013; # fixed bug with "00"
51             $posz_int = Type::Tiny::XS::get_coderef_for( 'PositiveOrZeroInt' );
52             }
53              
54             $meta->add_type(
55             name => 'PositiveInt',
56             parent => Int,
57             constraint => sub { $_ > 0 },
58             inlined => sub {
59             if ( $pos_int ) {
60             my $xsub = Type::Tiny::XS::get_subname_for( $_[0]->name );
61             return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks;
62             }
63             undef, qq($_ > 0);
64             },
65             message => sub { "Must be a positive integer" },
66             $pos_int ? ( compiled_type_constraint => $pos_int ) : (),
67             );
68              
69             $meta->add_type(
70             name => 'PositiveOrZeroInt',
71             parent => Int,
72             constraint => sub { $_ >= 0 },
73             inlined => sub {
74             if ( $posz_int ) {
75             my $xsub = Type::Tiny::XS::get_subname_for( $_[0]->name );
76             return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks;
77             }
78             undef, qq($_ >= 0);
79             },
80             message => sub { "Must be an integer greater than or equal to zero" },
81             $posz_int ? ( compiled_type_constraint => $posz_int ) : (),
82             type_default => sub { return 0; },
83             );
84              
85             $meta->add_type(
86             name => 'NegativeNum',
87             parent => Num,
88             constraint => sub { $_ < 0 },
89             inlined => sub { undef, qq($_ < 0) },
90             message => sub { "Must be a negative number" },
91             );
92              
93             $meta->add_type(
94             name => 'NegativeOrZeroNum',
95             parent => Num,
96             constraint => sub { $_ <= 0 },
97             inlined => sub { undef, qq($_ <= 0) },
98             message => sub { "Must be a number less than or equal to zero" },
99             type_default => sub { return 0; },
100             );
101              
102             $meta->add_type(
103             name => 'NegativeInt',
104             parent => Int,
105             constraint => sub { $_ < 0 },
106             inlined => sub { undef, qq($_ < 0) },
107             message => sub { "Must be a negative integer" },
108             );
109              
110             $meta->add_type(
111             name => 'NegativeOrZeroInt',
112             parent => Int,
113             constraint => sub { $_ <= 0 },
114             inlined => sub { undef, qq($_ <= 0) },
115             message => sub { "Must be an integer less than or equal to zero" },
116             type_default => sub { return 0; },
117             );
118              
119             $meta->add_type(
120             name => 'SingleDigit',
121             parent => Int,
122             constraint => sub { $_ >= -9 and $_ <= 9 },
123             inlined => sub { undef, qq($_ >= -9), qq($_ <= 9) },
124             message => sub { "Must be a single digit" },
125             type_default => sub { return 0; },
126             );
127              
128             for my $base ( qw/Num Int/ ) {
129             $meta->add_type(
130             name => "${base}Range",
131             parent => Types::Standard->get_type( $base ),
132             constraint_generator => sub {
133             return $meta->get_type( "${base}Range" ) unless @_;
134            
135             my $base_obj = Types::Standard->get_type( $base );
136            
137             my ( $min, $max, $min_excl, $max_excl ) = @_;
138             !defined( $min )
139             or $base_obj->check( $min )
140             or _croak(
141             "${base}Range min must be a %s; got %s", lc( $base ),
142             $min
143             );
144             !defined( $max )
145             or $base_obj->check( $max )
146             or _croak(
147             "${base}Range max must be a %s; got %s", lc( $base ),
148             $max
149             );
150             !defined( $min_excl )
151             or Bool->check( $min_excl )
152             or _croak( "${base}Range minexcl must be a boolean; got $min_excl" );
153             !defined( $max_excl )
154             or Bool->check( $max_excl )
155             or _croak( "${base}Range maxexcl must be a boolean; got $max_excl" );
156            
157             # this is complicated so defer to the inline generator
158             eval sprintf(
159             'sub { %s }',
160             join ' and ',
161             grep defined,
162             $meta->get_type( "${base}Range" )->inline_generator->( @_ )->( undef, '$_[0]' ),
163             );
164             },
165             inline_generator => sub {
166             my ( $min, $max, $min_excl, $max_excl ) = @_;
167            
168             my $gt = $min_excl ? '>' : '>=';
169             my $lt = $max_excl ? '<' : '<=';
170            
171             return sub {
172             my $v = $_[1];
173             my @code = ( undef ); # parent constraint
174             push @code, "$v $gt $min";
175             push @code, "$v $lt $max" if defined $max;
176             return @code;
177             };
178             },
179             deep_explanation => sub {
180             my ( $type, $value, $varname ) = @_;
181             my ( $min, $max, $min_excl, $max_excl ) = @{ $type->parameters || [] };
182             my @whines;
183             if ( defined $max ) {
184             push @whines, sprintf(
185             '"%s" expects %s to be %s %d and %s %d',
186             $type,
187             $varname,
188             $min_excl ? 'greater than' : 'at least',
189             $min,
190             $max_excl ? 'less than' : 'at most',
191             $max,
192             );
193             } #/ if ( defined $max )
194             else {
195             push @whines, sprintf(
196             '"%s" expects %s to be %s %d',
197             $type,
198             $varname,
199             $min_excl ? 'greater than' : 'at least',
200             $min,
201             );
202             }
203             push @whines, sprintf(
204             "%s is %s",
205             $varname,
206             $value,
207             );
208             return \@whines;
209             },
210             );
211             } #/ for my $base ( qw/Num Int/)
212              
213             __PACKAGE__->meta->make_immutable;
214              
215             1;
216              
217             __END__