File Coverage

blib/lib/Test/CPAN/Meta/Version.pm
Criterion Covered Total %
statement 166 174 95.4
branch 99 114 86.8
condition 45 48 93.7
subroutine 25 25 100.0
pod 20 20 100.0
total 355 381 93.1


line stmt bran cond sub pod time code
1             package Test::CPAN::Meta::Version;
2              
3 10     10   28394 use warnings;
  10         11  
  10         262  
4 10     10   33 use strict;
  10         12  
  10         229  
5              
6 10     10   30 use vars qw($VERSION);
  10         9  
  10         23936  
7             $VERSION = '0.25';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             Test::CPAN::Meta::Version - Validate CPAN META data against the specification
14              
15             =head1 SYNOPSIS
16              
17             use Test::CPAN::Meta::Version;
18              
19             =head1 DESCRIPTION
20              
21             This distribution was written to ensure that a META.yml file, provided with a
22             standard distribution uploaded to CPAN, meets the specifications that are
23             slowly being introduced to module uploads, via the use of package makers and
24             installers such as L, L and
25             L.
26              
27             This module is meant to be used together with L, however
28             the code is self contained enough that you can access it directly.
29              
30             See L for further details of the CPAN Meta Specification.
31              
32             =cut
33              
34             #----------------------------------------------------------------------------
35              
36             #############################################################################
37             #Specification Definitions #
38             #############################################################################
39              
40             my %known_specs = (
41             '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
42             '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
43             '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
44             '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
45             '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
46             );
47             my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
48              
49             my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
50             my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
51             my $no_index_1_3 = {
52             'map' => { file => { list => { value => \&string } },
53             directory => { list => { value => \&string } },
54             'package' => { list => { value => \&string } },
55             namespace => { list => { value => \&string } },
56             }
57             };
58             my $no_index_1_2 = {
59             'map' => { file => { list => { value => \&string } },
60             dir => { list => { value => \&string } },
61             'package' => { list => { value => \&string } },
62             namespace => { list => { value => \&string } },
63             }
64             };
65             my $no_index_1_1 = {
66             'map' => { ':key' => { name => \&keyword, list => { value => \&string } },
67             }
68             };
69              
70             my %definitions = (
71             '1.4' => {
72             # 'header' => { mandatory => 1, value => \&header },
73             'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version},
74             url => { mandatory => 1, value => \&urlspec } } },
75              
76             'name' => { mandatory => 1, value => \&string },
77             'version' => { mandatory => 1, value => \&version },
78             'abstract' => { mandatory => 1, value => \&string },
79             'author' => { mandatory => 1, list => { value => \&string } },
80             'license' => { mandatory => 1, value => \&license },
81             'generated_by' => { mandatory => 1, value => \&string },
82              
83             'distribution_type' => { value => \&string },
84             'dynamic_config' => { value => \&boolean },
85              
86             'requires' => $module_map1,
87             'recommends' => $module_map1,
88             'build_requires' => $module_map1,
89             'configure_requires' => $module_map1,
90             'conflicts' => $module_map2,
91              
92             'optional_features' => {
93             'map' => {
94             ':key' => { name => \&identifier,
95             'map' => { description => { value => \&string },
96             requires_packages => { value => \&string },
97             requires_os => { value => \&string },
98             excludes_os => { value => \&string },
99             requires => $module_map1,
100             recommends => $module_map1,
101             build_requires => $module_map1,
102             conflicts => $module_map2,
103             }
104             }
105             }
106             },
107              
108             'provides' => {
109             'map' => { ':key' => { name => \&module,
110             'map' => { file => { mandatory => 1, value => \&file },
111             version => { value => \&version } } } }
112             },
113              
114             'no_index' => $no_index_1_3,
115             'private' => $no_index_1_3,
116              
117             'keywords' => { list => { value => \&string } },
118              
119             'resources' => {
120             'map' => { license => { value => \&url },
121             homepage => { value => \&url },
122             bugtracker => { value => \&url },
123             repository => { value => \&url },
124             ':key' => { value => \&string, name => \&resource },
125             }
126             },
127              
128             # additional user defined key/value pairs
129             # note we can only validate the key name, as the structure is user defined
130             ':key' => { name => \&keyword, value => \&anything },
131             },
132              
133             '1.3' => {
134             # 'header' => { mandatory => 1, value => \&header },
135             'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version},
136             url => { mandatory => 1, value => \&urlspec } } },
137              
138             'name' => { mandatory => 1, value => \&string },
139             'version' => { mandatory => 1, value => \&version },
140             'abstract' => { mandatory => 1, value => \&string },
141             'author' => { mandatory => 1, list => { value => \&string } },
142             'license' => { mandatory => 1, value => \&license },
143             'generated_by' => { mandatory => 1, value => \&string },
144              
145             'distribution_type' => { value => \&string },
146             'dynamic_config' => { value => \&boolean },
147              
148             'requires' => $module_map1,
149             'recommends' => $module_map1,
150             'build_requires' => $module_map1,
151             'conflicts' => $module_map2,
152              
153             'optional_features' => {
154             'map' => {
155             ':key' => { name => \&identifier,
156             'map' => { description => { value => \&string },
157             requires_packages => { value => \&string },
158             requires_os => { value => \&string },
159             excludes_os => { value => \&string },
160             requires => $module_map1,
161             recommends => $module_map1,
162             build_requires => $module_map1,
163             conflicts => $module_map2,
164             }
165             }
166             }
167             },
168              
169             'provides' => {
170             'map' => { ':key' => { name => \&module,
171             'map' => { file => { mandatory => 1, value => \&file },
172             version => { value => \&version } } } }
173             },
174              
175             'no_index' => $no_index_1_3,
176             'private' => $no_index_1_3,
177              
178             'keywords' => { list => { value => \&string } },
179              
180             'resources' => {
181             'map' => { license => { value => \&url },
182             homepage => { value => \&url },
183             bugtracker => { value => \&url },
184             repository => { value => \&url },
185             ':key' => { value => \&string, name => \&resource },
186             }
187             },
188              
189             # additional user defined key/value pairs
190             # note we can only validate the key name, as the structure is user defined
191             ':key' => { name => \&keyword, value => \&anything },
192             },
193              
194             # v1.2 is misleading, it seems to assume that a number of fields where created
195             # within v1.1, when they were created within v1.2. This may have been an
196             # original mistake, and that a v1.1 was retro fitted into the timeline, when
197             # v1.2 was originally slated as v1.1. But I could be wrong ;)
198             '1.2' => {
199             # 'header' => { mandatory => 1, value => \&header },
200             'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version},
201             url => { mandatory => 1, value => \&urlspec } } },
202              
203             'name' => { mandatory => 1, value => \&string },
204             'version' => { mandatory => 1, value => \&version },
205             'license' => { mandatory => 1, value => \&license },
206             'generated_by' => { mandatory => 1, value => \&string },
207             'author' => { mandatory => 1, list => { value => \&string } },
208             'abstract' => { mandatory => 1, value => \&string },
209              
210             'distribution_type' => { value => \&string },
211             'dynamic_config' => { value => \&boolean },
212              
213             'keywords' => { list => { value => \&string } },
214              
215             'private' => $no_index_1_2,
216             '$no_index' => $no_index_1_2,
217              
218             'requires' => $module_map1,
219             'recommends' => $module_map1,
220             'build_requires' => $module_map1,
221             'conflicts' => $module_map2,
222              
223             'optional_features' => {
224             'map' => {
225             ':key' => { name => \&identifier,
226             'map' => { description => { value => \&string },
227             requires_packages => { value => \&string },
228             requires_os => { value => \&string },
229             excludes_os => { value => \&string },
230             requires => $module_map1,
231             recommends => $module_map1,
232             build_requires => $module_map1,
233             conflicts => $module_map2,
234             }
235             }
236             }
237             },
238              
239             'provides' => {
240             'map' => { ':key' => { name => \&module,
241             'map' => { file => { mandatory => 1, value => \&file },
242             version => { value => \&version } } } }
243             },
244              
245             'resources' => {
246             'map' => { license => { value => \&url },
247             homepage => { value => \&url },
248             bugtracker => { value => \&url },
249             repository => { value => \&url },
250             ':key' => { value => \&string, name => \&resource },
251             }
252             },
253              
254             # additional user defined key/value pairs
255             # note we can only validate the key name, as the structure is user defined
256             ':key' => { name => \&keyword, value => \&anything },
257             },
258              
259             # note that the 1.1 spec doesn't specify optional or mandatory fields, what
260             # appears below is assumed from later specifications.
261             '1.1' => {
262             # 'header' => { mandatory => 1, value => \&header },
263             'name' => { mandatory => 1, value => \&string },
264             'version' => { mandatory => 1, value => \&version },
265             'license' => { mandatory => 1, value => \&license },
266             'license_uri' => { mandatory => 0, value => \&url },
267             'generated_by' => { mandatory => 1, value => \&string },
268              
269             'distribution_type' => { value => \&string },
270             'dynamic_config' => { value => \&boolean },
271              
272             'private' => $no_index_1_1,
273              
274             'requires' => $module_map1,
275             'recommends' => $module_map1,
276             'build_requires' => $module_map1,
277             'conflicts' => $module_map2,
278              
279             # additional user defined key/value pairs
280             # note we can only validate the key name, as the structure is user defined
281             ':key' => { name => \&keyword, value => \&anything },
282             },
283              
284             # note that the 1.0 spec doesn't specify optional or mandatory fields, what
285             # appears below is assumed from later specifications.
286             '1.0' => {
287             # 'header' => { mandatory => 1, value => \&header },
288             'name' => { mandatory => 1, value => \&string },
289             'version' => { mandatory => 1, value => \&version },
290             'license' => { mandatory => 1, value => \&license },
291             'generated_by' => { mandatory => 1, value => \&string },
292              
293             'distribution_type' => { value => \&string },
294             'dynamic_config' => { value => \&boolean },
295              
296             'requires' => $module_map1,
297             'recommends' => $module_map1,
298             'build_requires' => $module_map1,
299             'conflicts' => $module_map2,
300              
301             # additional user defined key/value pairs
302             # note we can only validate the key name, as the structure is user defined
303             ':key' => { name => \&keyword, value => \&anything },
304             },
305             );
306              
307             #############################################################################
308             #Code #
309             #############################################################################
310              
311             =head1 CLASS CONSTRUCTOR
312              
313             =over
314              
315             =item * new( data => $data [, spec => $version] )
316              
317             The constructor must be passed a valid data structure.
318              
319             Optionally you may also provide a specification version. This version is then
320             use to ensure that the given data structure meets the respective
321             specification definition. If no version is provided the module will attempt to
322             deduce the appropriate specification version from the data structure itself.
323              
324             =back
325              
326             =cut
327              
328             sub new {
329 49     49 1 69279 my ($class,%hash) = @_;
330              
331             # create an attributes hash
332 49         119 my $atts = {
333             'spec' => $hash{spec},
334             'data' => $hash{data},
335             };
336              
337             # create the object
338 49         123 my $self = bless $atts, $class;
339             }
340              
341             =head1 METHODS
342              
343             =head2 Main Methods
344              
345             =over
346              
347             =item * parse()
348              
349             Using the given data structure provided with the constructor, attempts to
350             parse and validate according to the appropriate specification definition.
351              
352             Returns 1 if any errors found, otherwise returns 0.
353              
354             =item * errors()
355              
356             Returns a list of the errors found during parsing.
357              
358             =back
359              
360             =cut
361              
362             sub parse {
363 48     48 1 82 my $self = shift;
364 48         61 my $data = $self->{data};
365              
366 48 100       93 unless($self->{spec}) {
367 23 100 66     116 $self->{spec} = $data->{'meta-spec'} && $data->{'meta-spec'}{'version'} ? $data->{'meta-spec'}{'version'} : '1.0';
368             }
369              
370 48         96 $self->check_map($definitions{$self->{spec}},$data);
371 48 100       152 return defined $self->{errors} ? 1 : 0;
372             }
373              
374             sub errors {
375 45     45 1 92 my $self = shift;
376 45 100       92 return () unless($self->{errors});
377 23         14 return @{$self->{errors}};
  23         53  
378             }
379              
380             =head2 Check Methods
381              
382             =over
383              
384             =item * check_map($spec,$data)
385              
386             Checks whether a map (or hash) part of the data structure conforms to the
387             appropriate specification definition.
388              
389             =item * check_list($spec,$data)
390              
391             Checks whether a list (or array) part of the data structure conforms to
392             the appropriate specification definition.
393              
394             =back
395              
396             =cut
397              
398             sub check_map {
399 368     368 1 645 my ($self,$spec,$data) = @_;
400              
401 368 100       505 if(ref($spec) ne 'HASH') {
402 1         2 $self->_error( "Unknown META.yml specification, cannot validate." );
403 1         1 return;
404             }
405              
406 367 100       419 if(ref($data) ne 'HASH') {
407 3         7 $self->_error( "Expected a map structure from data string or file." );
408 3         5 return;
409             }
410              
411 364         599 for my $key (keys %$spec) {
412 1460 100       2164 next unless($spec->{$key}->{mandatory});
413 455 100       661 next if(defined $data->{$key});
414 4         2 push @{$self->{stack}}, $key;
  4         8  
415 4         14 $self->_error( "Missing mandatory field, '$key'" );
416 4         3 pop @{$self->{stack}};
  4         8  
417             }
418              
419 364         681 for my $key (keys %$data) {
420 1287         756 push @{$self->{stack}}, $key;
  1287         1254  
421 1287 100       1784 if($spec->{$key}) {
    50          
422 837 100       1296 if($spec->{$key}{value}) {
    100          
    50          
423 512         695 $spec->{$key}{value}->($self,$key,$data->{$key});
424             } elsif($spec->{$key}{'map'}) {
425 248         387 $self->check_map($spec->{$key}{'map'},$data->{$key});
426             } elsif($spec->{$key}{'list'}) {
427 77         127 $self->check_list($spec->{$key}{'list'},$data->{$key});
428             }
429              
430             } elsif ($spec->{':key'}) {
431 450         507 $spec->{':key'}{name}->($self,$key,$key);
432 450 100       566 if($spec->{':key'}{value}) {
    50          
    0          
433 380         532 $spec->{':key'}{value}->($self,$key,$data->{$key});
434             } elsif($spec->{':key'}{'map'}) {
435 70         123 $self->check_map($spec->{':key'}{'map'},$data->{$key});
436             } elsif($spec->{':key'}{'list'}) {
437 0         0 $self->check_list($spec->{':key'}{'list'},$data->{$key});
438             }
439              
440             } else {
441 0         0 $self->_error( "Unknown key, '$key', found in map structure" );
442             }
443 1286         765 pop @{$self->{stack}};
  1286         1481  
444             }
445             }
446              
447             sub check_list {
448 79     79 1 748 my ($self,$spec,$data) = @_;
449              
450 79 100       114 if(ref($data) ne 'ARRAY') {
451 3         7 $self->_error( "Expected a list structure" );
452 3         4 return;
453             }
454              
455 76 50       110 if(defined $spec->{mandatory}) {
456 0 0       0 if(!defined $data->[0]) {
457 0         0 $self->_error( "Missing entries from mandatory list" );
458             }
459             }
460              
461 76         69 for my $value (@$data) {
462 111         65 push @{$self->{stack}}, $value;
  111         110  
463 111 50       129 if(defined $spec->{value}) {
    0          
    0          
    0          
464 111         132 $spec->{value}->($self,'list',$value);
465             } elsif(defined $spec->{'map'}) {
466 0         0 $self->check_map($spec->{'map'},$value);
467             } elsif(defined $spec->{'list'}) {
468 0         0 $self->check_list($spec->{'list'},$value);
469              
470             } elsif ($spec->{':key'}) {
471 0         0 $self->check_map($spec,$value);
472              
473             } else {
474 0         0 $self->_error( "Unknown value type, '$value', found in list structure" );
475             }
476 109         63 pop @{$self->{stack}};
  109         156  
477             }
478             }
479              
480             =head2 Validator Methods
481              
482             =over
483              
484             =item * header($self,$key,$value)
485              
486             Validates that the YAML header is valid.
487              
488             Note: No longer used as we now read the YAML data structure, not the file.
489              
490             =item * url($self,$key,$value)
491              
492             Validates that a given value is in an acceptable URL format
493              
494             =item * urlspec($self,$key,$value)
495              
496             Validates that the URL to a META.yml specification is a known one.
497              
498             =item * string_or_undef($self,$key,$value)
499              
500             Validates that the value is either a string or an undef value. Bit of a
501             catchall function for parts of the data structure that are completely user
502             defined.
503              
504             =item * string($self,$key,$value)
505              
506             Validates that a string exists for the given key.
507              
508             =item * file($self,$key,$value)
509              
510             Validate that a file is passed for the given key. This may be made more
511             thorough in the future. For now it acts like \&string.
512              
513             =item * exversion($self,$key,$value)
514              
515             Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
516              
517             =item * version($self,$key,$value)
518              
519             Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
520             are both valid. A leading 'v' like 'v1.2.3' is also valid.
521              
522             =item * boolean($self,$key,$value)
523              
524             Validates for a boolean value. Currently these values are '1', '0', 'true',
525             'false', however the latter 2 may be removed.
526              
527             =item * license($self,$key,$value)
528              
529             Validates that a value is given for the license. Returns 1 if an known license
530             type, or 2 if a value is given but the license type is not a recommended one.
531              
532             =item * resource($self,$key,$value)
533              
534             Validates that the given key is in CamelCase, to indicate a user defined
535             keyword.
536              
537             =item * keyword($self,$key,$value)
538              
539             Validates that key is in an acceptable format for the META.yml specification,
540             i.e. any in the character class [-_a-z].
541              
542             For user defined keys, although not explicitly stated in the specifications
543             (v1.0 - v1.4), the convention is to precede the key with a pattern matching
544             qr{\Ax_}i. Following this any character from the character class [-_a-zA-Z]
545             can be used. This clarification has been added to v2.0 of the specification.
546              
547             =item * identifier($self,$key,$value)
548              
549             Validates that key is in an acceptable format for the META.yml specification,
550             for an identifier, i.e. any that matches the regular expression
551             qr/[a-z][a-z_]/i.
552              
553             =item * module($self,$key,$value)
554              
555             Validates that a given key is in an acceptable module name format, e.g.
556             'Test::CPAN::Meta::Version'.
557              
558             =item * anything($self,$key,$value)
559              
560             Usually reserved for user defined structures, allowing them to be considered
561             valid without a need for a specification definition for the structure.
562              
563             =back
564              
565             =cut
566              
567             sub header {
568 4     4 1 8 my ($self,$key,$value) = @_;
569 4 100       8 if(defined $value) {
570 3 100 100     19 return 1 if($value && $value =~ /^--- #YAML:1.0/);
571             }
572 3         6 $self->_error( "file does not have a valid YAML header." );
573 3         8 return 0;
574             }
575              
576             sub _uri_split {
577 28     28   113 return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
578             }
579              
580             sub url {
581 30     30 1 37 my ($self,$key,$value) = @_;
582 30 100       42 if($value) {
583 28         38 my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
584              
585 28 100       50 unless ( $scheme ) {
586 2         8 $self->_error( "'$value' for '$key' does not have a URL scheme" );
587 2         7 return 0;
588             }
589 26 100       35 unless ( $auth ) {
590 4         17 $self->_error( "'$value' for '$key' does not have a URL authority" );
591 4         10 return 0;
592             }
593 22         27 return 1;
594             } else {
595 2         4 $value = '';
596             }
597 2         10 $self->_error( "'$value' for '$key' is not a valid URL." );
598 2         10 return 0;
599             }
600              
601             sub urlspec {
602 44     44 1 51 my ($self,$key,$value) = @_;
603 44 100       62 if(defined $value) {
604 43 100 100     174 return 1 if($value && $known_specs{$self->{spec}} eq $value);
605 8 100 100     32 if($value && $known_urls{$value}) {
606 6         332 $self->_error( 'META.yml specification URL does not match version' );
607 6         10 return 0;
608             }
609             }
610 3         6 $self->_error( 'Unknown META.yml specification' );
611 3         8 return 0;
612             }
613              
614             sub string {
615 299     299 1 327 my ($self,$key,$value) = @_;
616 299 100       344 if(defined $value) {
617 298 100 100     510 return 1 if($value || $value =~ /^0$/);
618             }
619 2         4 $self->_error( "value is an undefined string" );
620 2         6 return 0;
621             }
622              
623             sub string_or_undef {
624 4     4 1 5 my ($self,$key,$value) = @_;
625 4 100       11 return 1 unless(defined $value);
626 3 100 100     15 return 1 if($value || $value =~ /^0$/);
627 1         4 $self->_error( "No string defined for '$key'" );
628 1         3 return 0;
629             }
630              
631             sub file {
632 69     69 1 63 my ($self,$key,$value) = @_;
633 69 100       122 return 1 if(defined $value);
634 1         4 $self->_error( "No file defined for '$key'" );
635 1         3 return 0;
636             }
637              
638             sub exversion {
639 313     313 1 291 my ($self,$key,$value) = @_;
640 313 100 100     776 if(defined $value && ($value || $value =~ /0/)) {
      66        
641 310         212 my $pass = 1;
642 310 100       428 for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
  315         331  
643 310         335 return $pass;
644             }
645 3 100       6 $value = '' unless(defined $value);
646 3         10 $self->_error( "'$value' for '$key' is not a valid version." );
647 3         9 return 0;
648             }
649              
650             sub version {
651 479     479 1 445 my ($self,$key,$value) = @_;
652 479 100       474 if(defined $value) {
653 477 100 100     756 return 0 unless($value || $value =~ /0/);
654 476 100       1765 return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
655             } else {
656 2         3 $value = '';
657             }
658 6         21 $self->_error( "'$value' for '$key' is not a valid version." );
659 6         15 return 0;
660             }
661              
662             sub boolean {
663 8     8 1 13 my ($self,$key,$value) = @_;
664 8 100       14 if(defined $value) {
665 6 100       31 return 1 if($value =~ /^(0|1|true|false)$/);
666             } else {
667 2         2 $value = '';
668             }
669 4         16 $self->_error( "'$value' for '$key' is not a boolean value." );
670 4         12 return 0;
671             }
672              
673             my %licenses = (
674             'perl' => 'http://dev.perl.org/licenses/',
675             'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
676             'apache' => 'http://apache.org/licenses/LICENSE-2.0',
677             'artistic' => 'http://opensource.org/licenses/artistic-license.php',
678             'artistic2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
679             'artistic-2.0' => 'http://opensource.org/licenses/artistic-license-2.0.php',
680             'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.phpt',
681             'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
682             'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
683             'mit' => 'http://opensource.org/licenses/mit-license.php',
684             'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
685             'open_source' => undef,
686             'unrestricted' => undef,
687             'restrictive' => undef,
688             'unknown' => undef,
689             );
690              
691             sub license {
692 65     65 1 5582 my ($self,$key,$value) = @_;
693 65 100       83 if(defined $value) {
694 64 100 100     295 return 1 if($value && exists $licenses{$value});
695 4 100       12 return 2 if($value);
696             } else {
697 1         2 $value = '';
698             }
699 2         10 $self->_error( "License '$value' is unknown" );
700 2         7 return 0;
701             }
702              
703             sub resource {
704 7     7 1 13 my ($self,$key) = @_;
705 7 100       16 if(defined $key) {
706             # a valid user defined key should be alphabetic
707             # and contain at least one capital case letter.
708 6 100 66     68 return 1 if($key && $key =~ /^[a-z]+$/i && $key =~ /[A-Z]/);
      100        
709             } else {
710 1         2 $key = '';
711             }
712 3         11 $self->_error( "Resource '$key' must be in CamelCase." );
713 3         9 return 0;
714             }
715              
716             sub keyword {
717 82     82 1 3594 my ($self,$key) = @_;
718 82 100       101 if(defined $key) {
719 81 100 100     373 return 1 if($key && $key =~ /^([a-z][-_a-z]*)$/); # spec defined
720 6 100 100     27 return 1 if($key && $key =~ /^x_([a-z][-_a-z]*)$/i); # user defined
721             } else {
722 1         2 $key = '';
723             }
724 6         20 $self->_error( "Key '$key' is not a legal keyword." );
725 6         17 return 0;
726             }
727              
728             sub identifier {
729 13     13 1 3141 my ($self,$key) = @_;
730 13 100       23 if(defined $key) {
731 12 100 100     88 return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
732             } else {
733 1         2 $key = '';
734             }
735 5         14 $self->_error( "Key '$key' is not a legal identifier." );
736 5         14 return 0;
737             }
738              
739             sub module {
740 382     382 1 321 my ($self,$key) = @_;
741 382 100       512 if(defined $key) {
742 381 100 100     1711 return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
743             } else {
744 1         2 $key = '';
745             }
746 9         26 $self->_error( "Key '$key' is not a legal module name." );
747 9         13 return 0;
748             }
749              
750 71     71 1 58 sub anything { return 1 }
751              
752             sub _error {
753 73     73   61 my $self = shift;
754 73         62 my $mess = shift;
755              
756 73 100       244 $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
  25         63  
757 73         130 $mess .= " [Validation: $self->{spec}]";
758              
759 73         56 push @{$self->{errors}}, $mess;
  73         138  
760             }
761              
762             q( "Before software can be reusable it first has to be usable." - Ralph Johnson );
763              
764             __END__