File Coverage

blib/lib/CPAN/Meta/Validator.pm
Criterion Covered Total %
statement 131 199 65.8
branch 67 126 53.1
condition 22 62 35.4
subroutine 25 28 89.2
pod 3 23 13.0
total 248 438 56.6


line stmt bran cond sub pod time code
1 13     13   158 use 5.006;
  13         26  
2 13     13   40 use strict;
  13         12  
  13         204  
3 13     13   37 use warnings;
  13         42  
  13         41587  
4             package CPAN::Meta::Validator;
5              
6             our $VERSION = '2.150010';
7              
8             #pod =head1 SYNOPSIS
9             #pod
10             #pod my $struct = decode_json_file('META.json');
11             #pod
12             #pod my $cmv = CPAN::Meta::Validator->new( $struct );
13             #pod
14             #pod unless ( $cmv->is_valid ) {
15             #pod my $msg = "Invalid META structure. Errors found:\n";
16             #pod $msg .= join( "\n", $cmv->errors );
17             #pod die $msg;
18             #pod }
19             #pod
20             #pod =head1 DESCRIPTION
21             #pod
22             #pod This module validates a CPAN Meta structure against the version of the
23             #pod the specification claimed in the C field of the structure.
24             #pod
25             #pod =cut
26              
27             #--------------------------------------------------------------------------#
28             # This code copied and adapted from Test::CPAN::Meta
29             # by Barbie, for Miss Barbell Productions,
30             # L
31             #--------------------------------------------------------------------------#
32              
33             #--------------------------------------------------------------------------#
34             # Specification Definitions
35             #--------------------------------------------------------------------------#
36              
37             my %known_specs = (
38             '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
39             '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
40             '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
41             '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
42             '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
43             );
44             my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
45              
46             my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
47              
48             my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
49              
50             my $no_index_2 = {
51             'map' => { file => { list => { value => \&string } },
52             directory => { list => { value => \&string } },
53             'package' => { list => { value => \&string } },
54             namespace => { list => { value => \&string } },
55             ':key' => { name => \&custom_2, value => \&anything },
56             }
57             };
58              
59             my $no_index_1_3 = {
60             'map' => { file => { list => { value => \&string } },
61             directory => { list => { value => \&string } },
62             'package' => { list => { value => \&string } },
63             namespace => { list => { value => \&string } },
64             ':key' => { name => \&string, value => \&anything },
65             }
66             };
67              
68             my $no_index_1_2 = {
69             'map' => { file => { list => { value => \&string } },
70             dir => { list => { value => \&string } },
71             'package' => { list => { value => \&string } },
72             namespace => { list => { value => \&string } },
73             ':key' => { name => \&string, value => \&anything },
74             }
75             };
76              
77             my $no_index_1_1 = {
78             'map' => { ':key' => { name => \&string, list => { value => \&string } },
79             }
80             };
81              
82             my $prereq_map = {
83             map => {
84             ':key' => {
85             name => \&phase,
86             'map' => {
87             ':key' => {
88             name => \&relation,
89             %$module_map1,
90             },
91             },
92             }
93             },
94             };
95              
96             my %definitions = (
97             '2' => {
98             # REQUIRED
99             'abstract' => { mandatory => 1, value => \&string },
100             'author' => { mandatory => 1, list => { value => \&string } },
101             'dynamic_config' => { mandatory => 1, value => \&boolean },
102             'generated_by' => { mandatory => 1, value => \&string },
103             'license' => { mandatory => 1, list => { value => \&license } },
104             'meta-spec' => {
105             mandatory => 1,
106             'map' => {
107             version => { mandatory => 1, value => \&version},
108             url => { value => \&url },
109             ':key' => { name => \&custom_2, value => \&anything },
110             }
111             },
112             'name' => { mandatory => 1, value => \&string },
113             'release_status' => { mandatory => 1, value => \&release_status },
114             'version' => { mandatory => 1, value => \&version },
115              
116             # OPTIONAL
117             'description' => { value => \&string },
118             'keywords' => { list => { value => \&string } },
119             'no_index' => $no_index_2,
120             'optional_features' => {
121             'map' => {
122             ':key' => {
123             name => \&string,
124             'map' => {
125             description => { value => \&string },
126             prereqs => $prereq_map,
127             ':key' => { name => \&custom_2, value => \&anything },
128             }
129             }
130             }
131             },
132             'prereqs' => $prereq_map,
133             'provides' => {
134             'map' => {
135             ':key' => {
136             name => \&module,
137             'map' => {
138             file => { mandatory => 1, value => \&file },
139             version => { value => \&version },
140             ':key' => { name => \&custom_2, value => \&anything },
141             }
142             }
143             }
144             },
145             'resources' => {
146             'map' => {
147             license => { list => { value => \&url } },
148             homepage => { value => \&url },
149             bugtracker => {
150             'map' => {
151             web => { value => \&url },
152             mailto => { value => \&string},
153             ':key' => { name => \&custom_2, value => \&anything },
154             }
155             },
156             repository => {
157             'map' => {
158             web => { value => \&url },
159             url => { value => \&url },
160             type => { value => \&string },
161             ':key' => { name => \&custom_2, value => \&anything },
162             }
163             },
164             ':key' => { value => \&string, name => \&custom_2 },
165             }
166             },
167              
168             # CUSTOM -- additional user defined key/value pairs
169             # note we can only validate the key name, as the structure is user defined
170             ':key' => { name => \&custom_2, value => \&anything },
171             },
172              
173             '1.4' => {
174             'meta-spec' => {
175             mandatory => 1,
176             'map' => {
177             version => { mandatory => 1, value => \&version},
178             url => { mandatory => 1, value => \&urlspec },
179             ':key' => { name => \&string, value => \&anything },
180             },
181             },
182              
183             'name' => { mandatory => 1, value => \&string },
184             'version' => { mandatory => 1, value => \&version },
185             'abstract' => { mandatory => 1, value => \&string },
186             'author' => { mandatory => 1, list => { value => \&string } },
187             'license' => { mandatory => 1, value => \&license },
188             'generated_by' => { mandatory => 1, value => \&string },
189              
190             'distribution_type' => { value => \&string },
191             'dynamic_config' => { value => \&boolean },
192              
193             'requires' => $module_map1,
194             'recommends' => $module_map1,
195             'build_requires' => $module_map1,
196             'configure_requires' => $module_map1,
197             'conflicts' => $module_map2,
198              
199             'optional_features' => {
200             'map' => {
201             ':key' => { name => \&string,
202             'map' => { description => { value => \&string },
203             requires => $module_map1,
204             recommends => $module_map1,
205             build_requires => $module_map1,
206             conflicts => $module_map2,
207             ':key' => { name => \&string, value => \&anything },
208             }
209             }
210             }
211             },
212              
213             'provides' => {
214             'map' => {
215             ':key' => { name => \&module,
216             'map' => {
217             file => { mandatory => 1, value => \&file },
218             version => { value => \&version },
219             ':key' => { name => \&string, value => \&anything },
220             }
221             }
222             }
223             },
224              
225             'no_index' => $no_index_1_3,
226             'private' => $no_index_1_3,
227              
228             'keywords' => { list => { value => \&string } },
229              
230             'resources' => {
231             'map' => { license => { value => \&url },
232             homepage => { value => \&url },
233             bugtracker => { value => \&url },
234             repository => { value => \&url },
235             ':key' => { value => \&string, name => \&custom_1 },
236             }
237             },
238              
239             # additional user defined key/value pairs
240             # note we can only validate the key name, as the structure is user defined
241             ':key' => { name => \&string, value => \&anything },
242             },
243              
244             '1.3' => {
245             'meta-spec' => {
246             mandatory => 1,
247             'map' => {
248             version => { mandatory => 1, value => \&version},
249             url => { mandatory => 1, value => \&urlspec },
250             ':key' => { name => \&string, value => \&anything },
251             },
252             },
253              
254             'name' => { mandatory => 1, value => \&string },
255             'version' => { mandatory => 1, value => \&version },
256             'abstract' => { mandatory => 1, value => \&string },
257             'author' => { mandatory => 1, list => { value => \&string } },
258             'license' => { mandatory => 1, value => \&license },
259             'generated_by' => { mandatory => 1, value => \&string },
260              
261             'distribution_type' => { value => \&string },
262             'dynamic_config' => { value => \&boolean },
263              
264             'requires' => $module_map1,
265             'recommends' => $module_map1,
266             'build_requires' => $module_map1,
267             'conflicts' => $module_map2,
268              
269             'optional_features' => {
270             'map' => {
271             ':key' => { name => \&string,
272             'map' => { description => { value => \&string },
273             requires => $module_map1,
274             recommends => $module_map1,
275             build_requires => $module_map1,
276             conflicts => $module_map2,
277             ':key' => { name => \&string, value => \&anything },
278             }
279             }
280             }
281             },
282              
283             'provides' => {
284             'map' => {
285             ':key' => { name => \&module,
286             'map' => {
287             file => { mandatory => 1, value => \&file },
288             version => { value => \&version },
289             ':key' => { name => \&string, value => \&anything },
290             }
291             }
292             }
293             },
294              
295              
296             'no_index' => $no_index_1_3,
297             'private' => $no_index_1_3,
298              
299             'keywords' => { list => { value => \&string } },
300              
301             'resources' => {
302             'map' => { license => { value => \&url },
303             homepage => { value => \&url },
304             bugtracker => { value => \&url },
305             repository => { value => \&url },
306             ':key' => { value => \&string, name => \&custom_1 },
307             }
308             },
309              
310             # additional user defined key/value pairs
311             # note we can only validate the key name, as the structure is user defined
312             ':key' => { name => \&string, value => \&anything },
313             },
314              
315             # v1.2 is misleading, it seems to assume that a number of fields where created
316             # within v1.1, when they were created within v1.2. This may have been an
317             # original mistake, and that a v1.1 was retro fitted into the timeline, when
318             # v1.2 was originally slated as v1.1. But I could be wrong ;)
319             '1.2' => {
320             'meta-spec' => {
321             mandatory => 1,
322             'map' => {
323             version => { mandatory => 1, value => \&version},
324             url => { mandatory => 1, value => \&urlspec },
325             ':key' => { name => \&string, value => \&anything },
326             },
327             },
328              
329              
330             'name' => { mandatory => 1, value => \&string },
331             'version' => { mandatory => 1, value => \&version },
332             'license' => { mandatory => 1, value => \&license },
333             'generated_by' => { mandatory => 1, value => \&string },
334             'author' => { mandatory => 1, list => { value => \&string } },
335             'abstract' => { mandatory => 1, value => \&string },
336              
337             'distribution_type' => { value => \&string },
338             'dynamic_config' => { value => \&boolean },
339              
340             'keywords' => { list => { value => \&string } },
341              
342             'private' => $no_index_1_2,
343             '$no_index' => $no_index_1_2,
344              
345             'requires' => $module_map1,
346             'recommends' => $module_map1,
347             'build_requires' => $module_map1,
348             'conflicts' => $module_map2,
349              
350             'optional_features' => {
351             'map' => {
352             ':key' => { name => \&string,
353             'map' => { description => { value => \&string },
354             requires => $module_map1,
355             recommends => $module_map1,
356             build_requires => $module_map1,
357             conflicts => $module_map2,
358             ':key' => { name => \&string, value => \&anything },
359             }
360             }
361             }
362             },
363              
364             'provides' => {
365             'map' => {
366             ':key' => { name => \&module,
367             'map' => {
368             file => { mandatory => 1, value => \&file },
369             version => { value => \&version },
370             ':key' => { name => \&string, value => \&anything },
371             }
372             }
373             }
374             },
375              
376             'resources' => {
377             'map' => { license => { value => \&url },
378             homepage => { value => \&url },
379             bugtracker => { value => \&url },
380             repository => { value => \&url },
381             ':key' => { value => \&string, name => \&custom_1 },
382             }
383             },
384              
385             # additional user defined key/value pairs
386             # note we can only validate the key name, as the structure is user defined
387             ':key' => { name => \&string, value => \&anything },
388             },
389              
390             # note that the 1.1 spec only specifies 'version' as mandatory
391             '1.1' => {
392             'name' => { value => \&string },
393             'version' => { mandatory => 1, value => \&version },
394             'license' => { value => \&license },
395             'generated_by' => { value => \&string },
396              
397             'license_uri' => { value => \&url },
398             'distribution_type' => { value => \&string },
399             'dynamic_config' => { value => \&boolean },
400              
401             'private' => $no_index_1_1,
402              
403             'requires' => $module_map1,
404             'recommends' => $module_map1,
405             'build_requires' => $module_map1,
406             'conflicts' => $module_map2,
407              
408             # additional user defined key/value pairs
409             # note we can only validate the key name, as the structure is user defined
410             ':key' => { name => \&string, value => \&anything },
411             },
412              
413             # note that the 1.0 spec doesn't specify optional or mandatory fields
414             # but we will treat version as mandatory since otherwise META 1.0 is
415             # completely arbitrary and pointless
416             '1.0' => {
417             'name' => { value => \&string },
418             'version' => { mandatory => 1, value => \&version },
419             'license' => { value => \&license },
420             'generated_by' => { value => \&string },
421              
422             'license_uri' => { value => \&url },
423             'distribution_type' => { value => \&string },
424             'dynamic_config' => { value => \&boolean },
425              
426             'requires' => $module_map1,
427             'recommends' => $module_map1,
428             'build_requires' => $module_map1,
429             'conflicts' => $module_map2,
430              
431             # additional user defined key/value pairs
432             # note we can only validate the key name, as the structure is user defined
433             ':key' => { name => \&string, value => \&anything },
434             },
435             );
436              
437             #--------------------------------------------------------------------------#
438             # Code
439             #--------------------------------------------------------------------------#
440              
441             #pod =method new
442             #pod
443             #pod my $cmv = CPAN::Meta::Validator->new( $struct )
444             #pod
445             #pod The constructor must be passed a metadata structure.
446             #pod
447             #pod =cut
448              
449             sub new {
450 700     700 1 1331 my ($class,$data) = @_;
451              
452             # create an attributes hash
453             my $self = {
454             'data' => $data,
455 700   100     793 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0",
456             'errors' => undef,
457             };
458              
459             # create the object
460 700         1411 return bless $self, $class;
461             }
462              
463             #pod =method is_valid
464             #pod
465             #pod if ( $cmv->is_valid ) {
466             #pod ...
467             #pod }
468             #pod
469             #pod Returns a boolean value indicating whether the metadata provided
470             #pod is valid.
471             #pod
472             #pod =cut
473              
474             sub is_valid {
475 700     700 1 898 my $self = shift;
476 700         647 my $data = $self->{data};
477 700         607 my $spec_version = $self->{spec};
478 700         1135 $self->check_map($definitions{$spec_version},$data);
479 700         1318 return ! $self->errors;
480             }
481              
482             #pod =method errors
483             #pod
484             #pod warn( join "\n", $cmv->errors );
485             #pod
486             #pod Returns a list of errors seen during validation.
487             #pod
488             #pod =cut
489              
490             sub errors {
491 735     735 1 646 my $self = shift;
492 735 100       3752 return () unless(defined $self->{errors});
493 70         58 return @{$self->{errors}};
  70         199  
494             }
495              
496             #pod =begin :internals
497             #pod
498             #pod =head2 Check Methods
499             #pod
500             #pod =over
501             #pod
502             #pod =item *
503             #pod
504             #pod check_map($spec,$data)
505             #pod
506             #pod Checks whether a map (or hash) part of the data structure conforms to the
507             #pod appropriate specification definition.
508             #pod
509             #pod =item *
510             #pod
511             #pod check_list($spec,$data)
512             #pod
513             #pod Checks whether a list (or array) part of the data structure conforms to
514             #pod the appropriate specification definition.
515             #pod
516             #pod =item *
517             #pod
518             #pod =back
519             #pod
520             #pod =cut
521              
522             my $spec_error = "Missing validation action in specification. "
523             . "Must be one of 'map', 'list', or 'value'";
524              
525             sub check_map {
526 6722     6722 0 5691 my ($self,$spec,$data) = @_;
527              
528 6722 100       9631 if(ref($spec) ne 'HASH') {
529 4         5 $self->_error( "Unknown META specification, cannot validate." );
530 4         5 return;
531             }
532              
533 6718 100       7824 if(ref($data) ne 'HASH') {
534 2         4 $self->_error( "Expected a map structure from string or file." );
535 2         2 return;
536             }
537              
538 6716         10307 for my $key (keys %$spec) {
539 26681 100       34992 next unless($spec->{$key}->{mandatory});
540 7588 100       9968 next if(defined $data->{$key});
541 22         21 push @{$self->{stack}}, $key;
  22         44  
542 22         55 $self->_error( "Missing mandatory field, '$key'" );
543 22         17 pop @{$self->{stack}};
  22         35  
544             }
545              
546 6716         11827 for my $key (keys %$data) {
547 27306         16184 push @{$self->{stack}}, $key;
  27306         26514  
548 27306 100       35962 if($spec->{$key}) {
    50          
549 14349 100       16482 if($spec->{$key}{value}) {
    100          
    50          
550 10712         12212 $spec->{$key}{value}->($self,$key,$data->{$key});
551             } elsif($spec->{$key}{'map'}) {
552 2625         3629 $self->check_map($spec->{$key}{'map'},$data->{$key});
553             } elsif($spec->{$key}{'list'}) {
554 1012         1607 $self->check_list($spec->{$key}{'list'},$data->{$key});
555             } else {
556 0         0 $self->_error( "$spec_error for '$key'" );
557             }
558              
559             } elsif ($spec->{':key'}) {
560 12957         14502 $spec->{':key'}{name}->($self,$key,$key);
561 12957 100       15526 if($spec->{':key'}{value}) {
    50          
    0          
562 9560         12286 $spec->{':key'}{value}->($self,$key,$data->{$key});
563             } elsif($spec->{':key'}{'map'}) {
564 3397         5115 $self->check_map($spec->{':key'}{'map'},$data->{$key});
565             } elsif($spec->{':key'}{'list'}) {
566 0         0 $self->check_list($spec->{':key'}{'list'},$data->{$key});
567             } else {
568 0         0 $self->_error( "$spec_error for ':key'" );
569             }
570              
571              
572             } else {
573 0         0 $self->_error( "Unknown key, '$key', found in map structure" );
574             }
575 27306         16767 pop @{$self->{stack}};
  27306         30991  
576             }
577             }
578              
579             sub check_list {
580 1012     1012 0 903 my ($self,$spec,$data) = @_;
581              
582 1012 100       1590 if(ref($data) ne 'ARRAY') {
583 2         4 $self->_error( "Expected a list structure" );
584 2         3 return;
585             }
586              
587 1010 50       1366 if(defined $spec->{mandatory}) {
588 0 0       0 if(!defined $data->[0]) {
589 0         0 $self->_error( "Missing entries from mandatory list" );
590             }
591             }
592              
593 1010         1093 for my $value (@$data) {
594 1729   50     1086 push @{$self->{stack}}, $value || "";
  1729         2749  
595 1729 50       1978 if(defined $spec->{value}) {
    0          
    0          
    0          
596 1729         1949 $spec->{value}->($self,'list',$value);
597             } elsif(defined $spec->{'map'}) {
598 0         0 $self->check_map($spec->{'map'},$value);
599             } elsif(defined $spec->{'list'}) {
600 0         0 $self->check_list($spec->{'list'},$value);
601             } elsif ($spec->{':key'}) {
602 0         0 $self->check_map($spec,$value);
603             } else {
604 0         0 $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
605             }
606 1729         1052 pop @{$self->{stack}};
  1729         2332  
607             }
608             }
609              
610             #pod =head2 Validator Methods
611             #pod
612             #pod =over
613             #pod
614             #pod =item *
615             #pod
616             #pod header($self,$key,$value)
617             #pod
618             #pod Validates that the header is valid.
619             #pod
620             #pod Note: No longer used as we now read the data structure, not the file.
621             #pod
622             #pod =item *
623             #pod
624             #pod url($self,$key,$value)
625             #pod
626             #pod Validates that a given value is in an acceptable URL format
627             #pod
628             #pod =item *
629             #pod
630             #pod urlspec($self,$key,$value)
631             #pod
632             #pod Validates that the URL to a META specification is a known one.
633             #pod
634             #pod =item *
635             #pod
636             #pod string_or_undef($self,$key,$value)
637             #pod
638             #pod Validates that the value is either a string or an undef value. Bit of a
639             #pod catchall function for parts of the data structure that are completely user
640             #pod defined.
641             #pod
642             #pod =item *
643             #pod
644             #pod string($self,$key,$value)
645             #pod
646             #pod Validates that a string exists for the given key.
647             #pod
648             #pod =item *
649             #pod
650             #pod file($self,$key,$value)
651             #pod
652             #pod Validate that a file is passed for the given key. This may be made more
653             #pod thorough in the future. For now it acts like \&string.
654             #pod
655             #pod =item *
656             #pod
657             #pod exversion($self,$key,$value)
658             #pod
659             #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
660             #pod
661             #pod =item *
662             #pod
663             #pod version($self,$key,$value)
664             #pod
665             #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
666             #pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
667             #pod
668             #pod =item *
669             #pod
670             #pod boolean($self,$key,$value)
671             #pod
672             #pod Validates for a boolean value: a defined value that is either "1" or "0" or
673             #pod stringifies to those values.
674             #pod
675             #pod =item *
676             #pod
677             #pod license($self,$key,$value)
678             #pod
679             #pod Validates that a value is given for the license. Returns 1 if an known license
680             #pod type, or 2 if a value is given but the license type is not a recommended one.
681             #pod
682             #pod =item *
683             #pod
684             #pod custom_1($self,$key,$value)
685             #pod
686             #pod Validates that the given key is in CamelCase, to indicate a user defined
687             #pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
688             #pod of the spec, this was only explicitly stated for 'resources'.
689             #pod
690             #pod =item *
691             #pod
692             #pod custom_2($self,$key,$value)
693             #pod
694             #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
695             #pod defined keyword and only has characters in the class [-_a-zA-Z]
696             #pod
697             #pod =item *
698             #pod
699             #pod identifier($self,$key,$value)
700             #pod
701             #pod Validates that key is in an acceptable format for the META specification,
702             #pod for an identifier, i.e. any that matches the regular expression
703             #pod qr/[a-z][a-z_]/i.
704             #pod
705             #pod =item *
706             #pod
707             #pod module($self,$key,$value)
708             #pod
709             #pod Validates that a given key is in an acceptable module name format, e.g.
710             #pod 'Test::CPAN::Meta::Version'.
711             #pod
712             #pod =back
713             #pod
714             #pod =end :internals
715             #pod
716             #pod =cut
717              
718             sub header {
719 0     0 0 0 my ($self,$key,$value) = @_;
720 0 0       0 if(defined $value) {
721 0 0 0     0 return 1 if($value && $value =~ /^--- #YAML:1.0/);
722             }
723 0         0 $self->_error( "file does not have a valid YAML header." );
724 0         0 return 0;
725             }
726              
727             sub release_status {
728 159     159 0 172 my ($self,$key,$value) = @_;
729 159 50       209 if(defined $value) {
730 159   100     327 my $version = $self->{data}{version} || '';
731 159 100       299 if ( $version =~ /_/ ) {
732 22 50       93 return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
733 0         0 $self->_error( "'$value' for '$key' is invalid for version '$version'" );
734             }
735             else {
736 137 50       495 return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
737 0         0 $self->_error( "'$value' for '$key' is invalid" );
738             }
739             }
740             else {
741 0         0 $self->_error( "'$key' is not defined" );
742             }
743 0         0 return 0;
744             }
745              
746             # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
747             sub _uri_split {
748 714     714   3258 return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
749             }
750              
751             sub url {
752 714     714 0 661 my ($self,$key,$value) = @_;
753 714 50       998 if(defined $value) {
754 714         833 my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
755 714 50 33     2439 unless ( defined $scheme && length $scheme ) {
756 0         0 $self->_error( "'$value' for '$key' does not have a URL scheme" );
757 0         0 return 0;
758             }
759 714 50 33     1899 unless ( defined $auth && length $auth ) {
760 0         0 $self->_error( "'$value' for '$key' does not have a URL authority" );
761 0         0 return 0;
762             }
763 714         896 return 1;
764             }
765 0   0     0 $value ||= '';
766 0         0 $self->_error( "'$value' for '$key' is not a valid URL." );
767 0         0 return 0;
768             }
769              
770             sub urlspec {
771 380     380 0 380 my ($self,$key,$value) = @_;
772 380 50       568 if(defined $value) {
773 380 50 33     1599 return 1 if($value && $known_specs{$self->{spec}} eq $value);
774 0 0 0     0 if($value && $known_urls{$value}) {
775 0         0 $self->_error( 'META specification URL does not match version' );
776 0         0 return 0;
777             }
778             }
779 0         0 $self->_error( 'Unknown META specification' );
780 0         0 return 0;
781             }
782              
783 1037     1037 0 853 sub anything { return 1 }
784              
785             sub string {
786 4994     4994 0 4299 my ($self,$key,$value) = @_;
787 4994 100       6010 if(defined $value) {
788 4993 100 66     8345 return 1 if($value || $value =~ /^0$/);
789             }
790 2         3 $self->_error( "value is an undefined string" );
791 2         1 return 0;
792             }
793              
794             sub string_or_undef {
795 0     0 0 0 my ($self,$key,$value) = @_;
796 0 0       0 return 1 unless(defined $value);
797 0 0 0     0 return 1 if($value || $value =~ /^0$/);
798 0         0 $self->_error( "No string defined for '$key'" );
799 0         0 return 0;
800             }
801              
802             sub file {
803 2421     2421 0 2003 my ($self,$key,$value) = @_;
804 2421 50       3569 return 1 if(defined $value);
805 0         0 $self->_error( "No file defined for '$key'" );
806 0         0 return 0;
807             }
808              
809             sub exversion {
810 8381     8381 0 7808 my ($self,$key,$value) = @_;
811 8381 50 66     24216 if(defined $value && ($value || $value =~ /0/)) {
      33        
812 8381         5322 my $pass = 1;
813 8381 100       11921 for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
  8451         9256  
814 8381         8724 return $pass;
815             }
816 0 0       0 $value = '' unless(defined $value);
817 0         0 $self->_error( "'$value' for '$key' is not a valid version." );
818 0         0 return 0;
819             }
820              
821             sub version {
822 12027     12027 0 10357 my ($self,$key,$value) = @_;
823 12027 50       10950 if(defined $value) {
824 12027 50 66     23084 return 0 unless($value || $value =~ /0/);
825 12027 100       43584 return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
826             } else {
827 0         0 $value = '';
828             }
829 12         32 $self->_error( "'$value' for '$key' is not a valid version." );
830 12         25 return 0;
831             }
832              
833             sub boolean {
834 663     663 0 598 my ($self,$key,$value) = @_;
835 663 50       831 if(defined $value) {
836 663 50       2334 return 1 if($value =~ /^(0|1)$/);
837             } else {
838 0         0 $value = '';
839             }
840 0         0 $self->_error( "'$value' for '$key' is not a boolean value." );
841 0         0 return 0;
842             }
843              
844             my %v1_licenses = (
845             'perl' => 'http://dev.perl.org/licenses/',
846             'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
847             'apache' => 'http://apache.org/licenses/LICENSE-2.0',
848             'artistic' => 'http://opensource.org/licenses/artistic-license.php',
849             'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
850             'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
851             'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
852             'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
853             'mit' => 'http://opensource.org/licenses/mit-license.php',
854             'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
855             'open_source' => undef,
856             'unrestricted' => undef,
857             'restrictive' => undef,
858             'unknown' => undef,
859             );
860              
861             my %v2_licenses = map { $_ => 1 } qw(
862             agpl_3
863             apache_1_1
864             apache_2_0
865             artistic_1
866             artistic_2
867             bsd
868             freebsd
869             gfdl_1_2
870             gfdl_1_3
871             gpl_1
872             gpl_2
873             gpl_3
874             lgpl_2_1
875             lgpl_3_0
876             mit
877             mozilla_1_0
878             mozilla_1_1
879             openssl
880             perl_5
881             qpl_1_0
882             ssleay
883             sun
884             zlib
885             open_source
886             restricted
887             unrestricted
888             unknown
889             );
890              
891             sub license {
892 700     700 0 669 my ($self,$key,$value) = @_;
893 700 100       1296 my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
894 700 100       845 if(defined $value) {
895 699 100 33     2030 return 1 if($value && exists $licenses->{$value});
896             } else {
897 1         1 $value = '';
898             }
899 3         8 $self->_error( "License '$value' is invalid" );
900 3         4 return 0;
901             }
902              
903             sub custom_1 {
904 98     98 0 103 my ($self,$key) = @_;
905 98 50       124 if(defined $key) {
906             # a valid user defined key should be alphabetic
907             # and contain at least one capital case letter.
908 98 50 33     671 return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
      33        
909             } else {
910 0         0 $key = '';
911             }
912 0         0 $self->_error( "Custom resource '$key' must be in CamelCase." );
913 0         0 return 0;
914             }
915              
916             sub custom_2 {
917 203     203 0 199 my ($self,$key) = @_;
918 203 50       228 if(defined $key) {
919 203 50 33     842 return 1 if($key && $key =~ /^x_/i); # user defined
920             } else {
921 0         0 $key = '';
922             }
923 0         0 $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
924 0         0 return 0;
925             }
926              
927             sub identifier {
928 0     0 0 0 my ($self,$key) = @_;
929 0 0       0 if(defined $key) {
930 0 0 0     0 return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
931             } else {
932 0         0 $key = '';
933             }
934 0         0 $self->_error( "Key '$key' is not a legal identifier." );
935 0         0 return 0;
936             }
937              
938             sub module {
939 10802     10802 0 8894 my ($self,$key) = @_;
940 10802 50       9668 if(defined $key) {
941 10802 50 33     47327 return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
942             } else {
943 0         0 $key = '';
944             }
945 0         0 $self->_error( "Key '$key' is not a legal module name." );
946 0         0 return 0;
947             }
948              
949             my @valid_phases = qw/ configure build test runtime develop /;
950             sub phase {
951 382     382 0 343 my ($self,$key) = @_;
952 382 50       448 if(defined $key) {
953 382 50 33     744 return 1 if( length $key && grep { $key eq $_ } @valid_phases );
  1910         2518  
954 0 0       0 return 1 if $key =~ /x_/i;
955             } else {
956 0         0 $key = '';
957             }
958 0         0 $self->_error( "Key '$key' is not a legal phase." );
959 0         0 return 0;
960             }
961              
962             my @valid_relations = qw/ requires recommends suggests conflicts /;
963             sub relation {
964 448     448 0 386 my ($self,$key) = @_;
965 448 50       483 if(defined $key) {
966 448 50 33     728 return 1 if( length $key && grep { $key eq $_ } @valid_relations );
  1792         2416  
967 0 0       0 return 1 if $key =~ /x_/i;
968             } else {
969 0         0 $key = '';
970             }
971 0         0 $self->_error( "Key '$key' is not a legal prereq relationship." );
972 0         0 return 0;
973             }
974              
975             sub _error {
976 47     47   42 my $self = shift;
977 47         31 my $mess = shift;
978              
979 47 100       74 $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
  43         105  
980 47         73 $mess .= " [Validation: $self->{spec}]";
981              
982 47         34 push @{$self->{errors}}, $mess;
  47         76  
983             }
984              
985             1;
986              
987             # ABSTRACT: validate CPAN distribution metadata structures
988              
989             =pod
990              
991             =encoding UTF-8
992              
993             =head1 NAME
994              
995             CPAN::Meta::Validator - validate CPAN distribution metadata structures
996              
997             =head1 VERSION
998              
999             version 2.150010
1000              
1001             =head1 SYNOPSIS
1002              
1003             my $struct = decode_json_file('META.json');
1004              
1005             my $cmv = CPAN::Meta::Validator->new( $struct );
1006              
1007             unless ( $cmv->is_valid ) {
1008             my $msg = "Invalid META structure. Errors found:\n";
1009             $msg .= join( "\n", $cmv->errors );
1010             die $msg;
1011             }
1012              
1013             =head1 DESCRIPTION
1014              
1015             This module validates a CPAN Meta structure against the version of the
1016             the specification claimed in the C field of the structure.
1017              
1018             =head1 METHODS
1019              
1020             =head2 new
1021              
1022             my $cmv = CPAN::Meta::Validator->new( $struct )
1023              
1024             The constructor must be passed a metadata structure.
1025              
1026             =head2 is_valid
1027              
1028             if ( $cmv->is_valid ) {
1029             ...
1030             }
1031              
1032             Returns a boolean value indicating whether the metadata provided
1033             is valid.
1034              
1035             =head2 errors
1036              
1037             warn( join "\n", $cmv->errors );
1038              
1039             Returns a list of errors seen during validation.
1040              
1041             =begin :internals
1042              
1043             =head2 Check Methods
1044              
1045             =over
1046              
1047             =item *
1048              
1049             check_map($spec,$data)
1050              
1051             Checks whether a map (or hash) part of the data structure conforms to the
1052             appropriate specification definition.
1053              
1054             =item *
1055              
1056             check_list($spec,$data)
1057              
1058             Checks whether a list (or array) part of the data structure conforms to
1059             the appropriate specification definition.
1060              
1061             =item *
1062              
1063             =back
1064              
1065             =head2 Validator Methods
1066              
1067             =over
1068              
1069             =item *
1070              
1071             header($self,$key,$value)
1072              
1073             Validates that the header is valid.
1074              
1075             Note: No longer used as we now read the data structure, not the file.
1076              
1077             =item *
1078              
1079             url($self,$key,$value)
1080              
1081             Validates that a given value is in an acceptable URL format
1082              
1083             =item *
1084              
1085             urlspec($self,$key,$value)
1086              
1087             Validates that the URL to a META specification is a known one.
1088              
1089             =item *
1090              
1091             string_or_undef($self,$key,$value)
1092              
1093             Validates that the value is either a string or an undef value. Bit of a
1094             catchall function for parts of the data structure that are completely user
1095             defined.
1096              
1097             =item *
1098              
1099             string($self,$key,$value)
1100              
1101             Validates that a string exists for the given key.
1102              
1103             =item *
1104              
1105             file($self,$key,$value)
1106              
1107             Validate that a file is passed for the given key. This may be made more
1108             thorough in the future. For now it acts like \&string.
1109              
1110             =item *
1111              
1112             exversion($self,$key,$value)
1113              
1114             Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
1115              
1116             =item *
1117              
1118             version($self,$key,$value)
1119              
1120             Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
1121             are both valid. A leading 'v' like 'v1.2.3' is also valid.
1122              
1123             =item *
1124              
1125             boolean($self,$key,$value)
1126              
1127             Validates for a boolean value: a defined value that is either "1" or "0" or
1128             stringifies to those values.
1129              
1130             =item *
1131              
1132             license($self,$key,$value)
1133              
1134             Validates that a value is given for the license. Returns 1 if an known license
1135             type, or 2 if a value is given but the license type is not a recommended one.
1136              
1137             =item *
1138              
1139             custom_1($self,$key,$value)
1140              
1141             Validates that the given key is in CamelCase, to indicate a user defined
1142             keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
1143             of the spec, this was only explicitly stated for 'resources'.
1144              
1145             =item *
1146              
1147             custom_2($self,$key,$value)
1148              
1149             Validates that the given key begins with 'x_' or 'X_', to indicate a user
1150             defined keyword and only has characters in the class [-_a-zA-Z]
1151              
1152             =item *
1153              
1154             identifier($self,$key,$value)
1155              
1156             Validates that key is in an acceptable format for the META specification,
1157             for an identifier, i.e. any that matches the regular expression
1158             qr/[a-z][a-z_]/i.
1159              
1160             =item *
1161              
1162             module($self,$key,$value)
1163              
1164             Validates that a given key is in an acceptable module name format, e.g.
1165             'Test::CPAN::Meta::Version'.
1166              
1167             =back
1168              
1169             =end :internals
1170              
1171             =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
1172             identifier license module phase relation release_status string string_or_undef
1173             url urlspec version header check_map
1174              
1175             =head1 BUGS
1176              
1177             Please report any bugs or feature using the CPAN Request Tracker.
1178             Bugs can be submitted through the web interface at
1179             L
1180              
1181             When submitting a bug or request, please include a test-file or a patch to an
1182             existing test-file that illustrates the bug or desired feature.
1183              
1184             =head1 AUTHORS
1185              
1186             =over 4
1187              
1188             =item *
1189              
1190             David Golden
1191              
1192             =item *
1193              
1194             Ricardo Signes
1195              
1196             =item *
1197              
1198             Adam Kennedy
1199              
1200             =back
1201              
1202             =head1 COPYRIGHT AND LICENSE
1203              
1204             This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
1205              
1206             This is free software; you can redistribute it and/or modify it under
1207             the same terms as the Perl 5 programming language system itself.
1208              
1209             =cut
1210              
1211             __END__