File Coverage

blib/lib/Types/XSD/Lite.pm
Criterion Covered Total %
statement 79 99 79.8
branch 26 52 50.0
condition 12 18 66.6
subroutine 19 30 63.3
pod 0 5 0.0
total 136 204 66.6


line stmt bran cond sub pod time code
1             package Types::XSD::Lite;
2              
3 3     3   162220 use 5.008003;
  3         27  
4 3     3   16 use strict;
  3         5  
  3         73  
5 3     3   15 use warnings;
  3         6  
  3         141  
6 3     3   1917 use utf8;
  3         42  
  3         16  
7              
8             BEGIN {
9 3     3   142 $Types::XSD::Lite::AUTHORITY = 'cpan:TOBYINK';
10 3         76 $Types::XSD::Lite::VERSION = '0.006';
11             }
12              
13 3     3   18 use B qw(perlstring);
  3         6  
  3         180  
14 3     3   17 use Carp;
  3         6  
  3         161  
15 3     3   1685 use Type::Utils;
  3         93664  
  3         25  
16 3         16 use Type::Library -base, -declare => qw(
17             AnyType AnySimpleType String NormalizedString Token Language Boolean
18             Base64Binary HexBinary Float Double AnyURI Decimal
19             Integer NonPositiveInteger NegativeInteger Long Int Short Byte
20             NonNegativeInteger PositiveInteger UnsignedLong UnsignedInt
21             UnsignedShort UnsignedByte
22 3     3   4694 );
  3         9  
23 3     3   12924 use Types::Standard;
  3         154380  
  3         31  
24              
25             our $T;
26              
27             sub create_range_check
28             {
29 36     36 0 1732 my $class = $_[0]; eval "require $class";
  36         2060  
30 36 100       80808 my ($lower, $upper) = map(defined($_) ? $class->new($_) : $_, @_[1,2]);
31 36         76642 my ($lexcl, $uexcl) = map(!!$_, @_[3,4]);
32            
33             my $checker =
34             (defined $lower and defined $upper and $lexcl and $uexcl)
35 0 0   0   0 ? sub { my $n = $class->new($_); $n > $lower and $n < $upper } :
  0         0  
36             (defined $lower and defined $upper and $lexcl)
37 0 0   0   0 ? sub { my $n = $class->new($_); $n > $lower and $n <= $upper } :
  0         0  
38             (defined $lower and defined $upper and $uexcl)
39 0 0   0   0 ? sub { my $n = $class->new($_); $n >= $lower and $n < $upper } :
  0         0  
40             (defined $lower and defined $upper)
41 0 0   0   0 ? sub { my $n = $class->new($_); $n >= $lower and $n <= $upper } :
  0         0  
42             (defined $lower and $lexcl)
43 0     0   0 ? sub { $class->new($_) > $lower } :
44             (defined $upper and $uexcl)
45 0     0   0 ? sub { $class->new($_) < $upper } :
46             (defined $lower)
47 0     0   0 ? sub { $class->new($_) >= $lower } :
48             (defined $upper)
49 0     0   0 ? sub { $class->new($_) <= $upper } :
50 36 50 33 0   751 sub { !!1 };
  0 100 66     0  
    50 66        
    50 100        
    100 66        
    50 66        
    50          
    50          
51            
52             my $inlined = sub {
53 43     43   22200 my $var = $_[1];
54 43         68 my @checks;
55 43 50       411 push @checks, sprintf('$n >%s "%s"->new("%s")', $lexcl?'':'=', $class, $lower) if defined $lower;
    100          
56 43 50       1290 push @checks, sprintf('$n <%s "%s"->new("%s")', $uexcl?'':'=', $class, $upper) if defined $upper;
    100          
57 43         983 my $code = sprintf(
58             '%s and do { my $n = "%s"->new(%s); %s }',
59             Types::Standard::Int()->inline_check($var),
60             $class,
61             $var,
62             join(" and ", @checks),
63             );
64 36         143 };
65            
66             return (
67 36         238 constraint => $checker,
68             inlined => $inlined,
69             );
70             }
71              
72             sub quick_range_check
73             {
74 7     7 0 10 my $class = $_[0]; eval "require $class";
  7         463  
75 7 100       74 my ($lower, $upper) = map(defined($_) ? $class->new($_) : $_, @_[1,2]);
76 7         378 my ($lexcl, $uexcl) = map(!!$_, @_[3,4]);
77 7         17 my $var = $_[5];
78 7         14 my @checks;
79 7 0       17 push @checks, sprintf('$n >%s "%s"->new("%s")', $lexcl?'':'=', $class, $lower) if defined $lower;
    50          
80 7 50       50 push @checks, sprintf('$n <%s "%s"->new("%s")', $uexcl?'':'=', $class, $upper) if defined $upper;
    50          
81 7         213 my $code = sprintf(
82             'do { my $n = "%s"->new(%s); %s }',
83             $class,
84             $var,
85             join(" and ", @checks),
86             );
87             }
88              
89             sub hex_length
90             {
91 0     0 0 0 my $str = shift;
92 0         0 my $len = ($str =~ tr/0-9A-Fa-f//);
93 0         0 $len / 2;
94             }
95              
96             sub b64_length
97             {
98 0     0 0 0 my $str = shift;
99 0         0 $str =~ s/[^a-zA-Z0-9+\x{2f}=]//g;
100 0         0 my $padding = ($str =~ tr/=//);
101 0         0 (length($str) * 3 / 4) - $padding;
102             }
103              
104             our @patterns; my $pattern_i = -1;
105             our @assertions; my $assertion_i = -1;
106             our %facets = (
107             assertions => sub {
108             my ($o, $var) = @_;
109             return unless exists $o->{assertions};
110             my $ass = delete $o->{assertions};
111             $ass = [$ass] unless ref($ass) eq q(ARRAY);
112             my @r;
113             for my $a (@$ass)
114             {
115             require Types::TypeTiny;
116             if (Types::TypeTiny::CodeLike()->check($a))
117             {
118             $assertion_i++;
119             $assertions[$assertion_i] = $a;
120             push @r,
121             ($var eq '$_')
122             ? sprintf('$Types::XSD::Lite::assertions[%d]->(%s)', $assertion_i, $var)
123             : sprintf('do { local $_ = %s; $Types::XSD::Lite::assertions[%d]->(%s) }', $var, $assertion_i, $var);
124             }
125             elsif (Types::TypeTiny::StringLike()->check($a))
126             {
127             push @r,
128             ($var eq '$_')
129             ? "do { $a }"
130             : "do { local \$_ = $var; $a }";
131             }
132             else
133             {
134             croak "assertions should be strings or coderefs";
135             }
136             }
137             join ' && ', map "($_)", @r;
138             },
139             length => sub {
140             my ($o, $var) = @_;
141             return unless exists $o->{length};
142             sprintf('length(%s)==%d', $var, delete $o->{length});
143             },
144             maxLength => sub {
145             my ($o, $var) = @_;
146             return unless exists $o->{maxLength};
147             sprintf('length(%s)<=%d', $var, delete $o->{maxLength});
148             },
149             minLength => sub {
150             my ($o, $var) = @_;
151             return unless exists $o->{minLength};
152             sprintf('length(%s)>=%d', $var, delete $o->{minLength});
153             },
154             lengthHex => sub {
155             my ($o, $var) = @_;
156             return unless exists $o->{length};
157             sprintf('Types::XSD::Lite::hex_length(%s)==%d', $var, delete $o->{length});
158             },
159             maxLengthHex => sub {
160             my ($o, $var) = @_;
161             return unless exists $o->{maxLength};
162             sprintf('Types::XSD::Lite::hex_length(%s)<=%d', $var, delete $o->{maxLength});
163             },
164             minLengthHex => sub {
165             my ($o, $var) = @_;
166             return unless exists $o->{minLength};
167             sprintf('Types::XSD::Lite::hex_length(%s)>=%d', $var, delete $o->{minLength});
168             },
169             lengthQName => sub {
170             my ($o, $var) = @_;
171             return unless exists $o->{length};
172             delete $o->{length};
173             "!!1"
174             },
175             maxLengthQName => sub {
176             my ($o, $var) = @_;
177             return unless exists $o->{maxLength};
178             delete $o->{maxLength};
179             "!!1"
180             },
181             minLengthQName => sub {
182             my ($o, $var) = @_;
183             return unless exists $o->{minLength};
184             delete $o->{minLength};
185             "!!1"
186             },
187             lengthB64 => sub {
188             my ($o, $var) = @_;
189             return unless exists $o->{length};
190             sprintf('Types::XSD::Lite::b64_length(%s)==%d', $var, delete $o->{length});
191             },
192             maxLengthB64 => sub {
193             my ($o, $var) = @_;
194             return unless exists $o->{maxLength};
195             sprintf('Types::XSD::Lite::b64_length(%s)<=%d', $var, delete $o->{maxLength});
196             },
197             minLengthB64 => sub {
198             my ($o, $var) = @_;
199             return unless exists $o->{minLength};
200             sprintf('Types::XSD::Lite::b64_length(%s)>=%d', $var, delete $o->{minLength});
201             },
202             pattern => sub {
203             my ($o, $var) = @_;
204             return unless exists $o->{pattern};
205             $patterns[++$pattern_i] = delete $o->{pattern};
206             sprintf('%s =~ $Types::XSD::Lite::patterns[%d]', $var, $pattern_i);
207             },
208             enumeration => sub {
209             my ($o, $var) = @_;
210             return unless exists $o->{enumeration};
211             my $re = join "|", map quotemeta, @{delete $o->{enumeration}};
212             sprintf('%s =~ m/^(?:%s)$/sm', $var, $re);
213             },
214             whiteSpace => sub {
215             my ($o, $var) = @_;
216             return unless exists $o->{whiteSpace};
217             delete($o->{whiteSpace});
218             "!!1";
219             },
220             maxInclusive => sub {
221             my ($o, $var) = @_;
222             return unless exists $o->{maxInclusive};
223             quick_range_check("Math::BigInt", undef, delete($o->{maxInclusive}), undef, undef, $var);
224             },
225             minInclusive => sub {
226             my ($o, $var) = @_;
227             return unless exists $o->{minInclusive};
228             quick_range_check("Math::BigInt", delete($o->{minInclusive}), undef, undef, undef, $var);
229             },
230             maxExclusive => sub {
231             my ($o, $var) = @_;
232             return unless exists $o->{maxExclusive};
233             quick_range_check("Math::BigInt", undef, delete($o->{maxExclusive}), undef, 1, $var);
234             },
235             minExclusive => sub {
236             my ($o, $var) = @_;
237             return unless exists $o->{minExclusive};
238             quick_range_check("Math::BigInt", delete($o->{minExclusive}), undef, 1, undef, $var);
239             },
240             maxInclusiveFloat => sub {
241             my ($o, $var) = @_;
242             return unless exists $o->{maxInclusive};
243             quick_range_check("Math::BigFloat", undef, delete($o->{maxInclusive}), undef, undef, $var);
244             },
245             minInclusiveFloat => sub {
246             my ($o, $var) = @_;
247             return unless exists $o->{minInclusive};
248             quick_range_check("Math::BigFloat", delete($o->{minInclusive}), undef, undef, undef, $var);
249             },
250             maxExclusiveFloat => sub {
251             my ($o, $var) = @_;
252             return unless exists $o->{maxExclusive};
253             quick_range_check("Math::BigFloat", undef, delete($o->{maxExclusive}), undef, 1, $var);
254             },
255             minExclusiveFloat => sub {
256             my ($o, $var) = @_;
257             return unless exists $o->{minExclusive};
258             quick_range_check("Math::BigFloat", delete($o->{minExclusive}), undef, 1, undef, $var);
259             },
260             maxInclusiveStr => sub {
261             my ($o, $var) = @_;
262             return unless exists $o->{maxInclusive};
263             sprintf('%s le %s', $var, perlstring delete $o->{maxInclusive});
264             },
265             minInclusiveStr => sub {
266             my ($o, $var) = @_;
267             return unless exists $o->{minInclusive};
268             sprintf('%s ge %s', $var, perlstring delete $o->{minInclusive});
269             },
270             maxExclusiveStr => sub {
271             my ($o, $var) = @_;
272             return unless exists $o->{maxExclusive};
273             sprintf('%s lt %s', $var, perlstring delete $o->{maxExclusive});
274             },
275             minExclusiveStr => sub {
276             my ($o, $var) = @_;
277             return unless exists $o->{minExclusive};
278             sprintf('%s gt %s', $var, perlstring delete $o->{minExclusive});
279             },
280             totalDigits => sub {
281             my ($o, $var) = @_;
282             return unless exists $o->{totalDigits};
283             sprintf('do { no warnings "uninitialized"; my $tmp = %s; ($tmp=~tr/0-9//) <= %d }', $var, delete $o->{totalDigits});
284             },
285             fractionDigits => sub {
286             my ($o, $var) = @_;
287             return unless exists $o->{fractionDigits};
288             sprintf('do { no warnings "uninitialized"; my (undef, $tmp) = split /\\./, %s; ($tmp=~tr/0-9//) <= %d }', $var, delete $o->{fractionDigits});
289             },
290             );
291              
292             sub facet
293             {
294 72     72 0 73058 my $self = pop;
295 72         310 my @facets = ("assertions", @_);
296 72         162 my $regexp = qr{^${\(join "|", map quotemeta, @facets)}$}ms;
  72         2260  
297 72         386 my $name = "$self";
298            
299             my $inline_generator = sub
300             {
301 2     2   38 my %p_not_destroyed = @_;
302             return sub {
303 7         34506 local $T = $_[0]->parent;
304 7         40 my %p = %p_not_destroyed; # copy;
305 7         15 my $var = $_[1];
306             my $r = sprintf(
307             '(%s)',
308             join(
309             ' and ',
310             $self->inline_check($var),
311 7         21 map($facets{$_}->(\%p, $var), @facets),
312             ),
313             );
314 7 0       20 croak sprintf(
    50          
315             'Attempt to parameterize type "%s" with unrecognised parameter%s %s',
316             $name,
317             scalar(keys %p)==1 ? '' : 's',
318             join(", ", map(qq["$_"], sort keys %p)),
319             ) if keys %p;
320 7         31 return $r;
321 2         18 };
322 72         935 };
323            
324 72         172 $self->{inline_generator} = $inline_generator;
325             $self->{constraint_generator} = sub {
326 1     1   303 my $sub = sprintf(
327             'sub { %s }',
328             $inline_generator->(@_)->($self, '$_[0]'),
329             );
330 1 50       248 eval($sub) or croak "could not build sub: $@\n\nCODE: $sub\n";
331 72         298 };
332             $self->{name_generator} = sub {
333 1     1   34 my ($s, %a) = @_;
334 1         17 sprintf('%s[%s]', $s, join q[,], map sprintf("%s=>%s", $_, perlstring $a{$_}), sort keys %a);
335 72         307 };
336            
337 72 50       255 return if $self->is_anon;
338            
339 3     3   10659 no strict qw( refs );
  3         9  
  3         164  
340 3     3   20 no warnings qw( redefine prototype );
  3         6  
  3         3703  
341 72         662 *{$self->library . '::' . $self->name} = $self->library->_mksub($self);
  72         22873  
342             }
343              
344             declare AnyType, as Types::Standard::Any;
345              
346             declare AnySimpleType, as Types::Standard::Value;
347              
348             facet qw( length minLength maxLength pattern enumeration whiteSpace ),
349             declare String, as Types::Standard::Str;
350              
351             facet qw( length minLength maxLength pattern enumeration whiteSpace ),
352             declare NormalizedString, as Types::Standard::StrMatch[qr{^[^\t\r\n]*$}sm];
353              
354             facet qw( length minLength maxLength pattern enumeration whiteSpace ),
355             declare Token, as intersection([
356             NormalizedString,
357             Types::Standard::StrMatch([qr{\A\s}sm])->complementary_type,
358             Types::Standard::StrMatch([qr{\s\z}sm])->complementary_type,
359             Types::Standard::StrMatch([qr{\s{2}}sm])->complementary_type,
360             ]);
361              
362             facet qw( length minLength maxLength pattern enumeration whiteSpace ),
363             declare Language, as Types::Standard::StrMatch[qr{\A[a-zA-Z]{1,8}(?:-[a-zA-Z0-9]{1,8})*\z}sm];
364              
365             facet qw( pattern whiteSpace ),
366             declare Boolean, as Types::Standard::StrMatch[qr{\A(?:true|false|0|1)\z}ism];
367              
368             facet qw( lengthB64 minLengthB64 maxLengthB64 pattern enumeration whiteSpace ),
369             declare Base64Binary, as Types::Standard::StrMatch[qr{\A[a-zA-Z0-9+\x{2f}=\s]+\z}ism];
370              
371             facet qw( lengthHex minLengthHex maxLengthHex pattern enumeration whiteSpace ),
372             declare HexBinary, as Types::Standard::StrMatch[qr{\A[a-fA-F0-9]+\z}ism];
373              
374             facet qw( pattern enumeration whiteSpace maxInclusiveFloat maxExclusiveFloat minInclusiveFloat minExclusiveFloat ),
375             declare Float, as Types::Standard::Num;
376              
377             facet qw( pattern enumeration whiteSpace maxInclusiveFloat maxExclusiveFloat minInclusiveFloat minExclusiveFloat ),
378             declare Double, as Types::Standard::Num;
379              
380             facet qw( length minLength maxLength pattern enumeration whiteSpace ),
381             declare AnyURI, as Types::Standard::Str;
382              
383             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusiveFloat maxExclusiveFloat minInclusiveFloat minExclusiveFloat ),
384             declare Decimal, as Types::Standard::StrMatch[qr{\A(?:(?:[+-]?[0-9]+(?:\.[0-9]+)?)|(?:[+-]?\.[0-9]+))\z}ism];
385              
386             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
387             declare Integer, as Types::Standard::Int;
388              
389             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
390             declare NonPositiveInteger, as Integer, create_range_check("Math::BigInt", undef, 0);
391              
392             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
393             declare NegativeInteger, as NonPositiveInteger, create_range_check("Math::BigInt", undef, -1);
394              
395             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
396             declare NonNegativeInteger, as Integer, create_range_check("Math::BigInt", 0, undef);
397              
398             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
399             declare PositiveInteger, as NonNegativeInteger, create_range_check("Math::BigInt", 1, undef);
400              
401             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
402             declare Long, as Integer, create_range_check("Math::BigInt", q[-9223372036854775808], q[9223372036854775807]);
403              
404             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
405             declare Int, as Long, create_range_check("Math::BigInt", q[-2147483648], q[2147483647]);
406              
407             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
408             declare Short, as Int, create_range_check("Math::BigInt", q[-32768], q[32767]);
409              
410             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
411             declare Byte, as Short, create_range_check("Math::BigInt", q[-128], q[127]);
412              
413             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
414             declare UnsignedLong, as NonNegativeInteger, create_range_check("Math::BigInt", q[0], q[18446744073709551615]);
415              
416             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
417             declare UnsignedInt, as UnsignedLong, create_range_check("Math::BigInt", q[0], q[4294967295]);
418              
419             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
420             declare UnsignedShort, as UnsignedInt, create_range_check("Math::BigInt", q[0], q[65535]);
421              
422             facet qw( totalDigits fractionDigits pattern whiteSpace enumeration maxInclusive maxExclusive minInclusive minExclusive ),
423             declare UnsignedByte, as UnsignedShort, create_range_check("Math::BigInt", q[0], q[255]);
424              
425             1;
426              
427             __END__