File Coverage

File:blib/lib/Test/YAML/Meta/Version.pm
Coverage:95.3%

linestmtbrancondsubpodtimecode
1package Test::YAML::Meta::Version;
2
3
6
6
6
0
0
0
use warnings;
4
6
6
6
0
0
0
use strict;
5
6
6
6
6
0
0
0
use vars qw($VERSION);
7$VERSION = '0.04';
8
9#----------------------------------------------------------------------------
10
11 - 33
=head1 NAME

Test::YAML::Meta::Version - Validation of META.yml specification elements.

=head1 SYNOPSIS

  use Test::YAML::Meta::Version;

=head1 DESCRIPTION

This module was written to ensure that a META.yml file, provided with a 
standard distribution uploaded to CPAN, meets the specifications that are 
slowly being introduced to module uploads, via the use of 
L<ExtUtils::MakeMaker>, L<Module::Build> and L<Module::Install>.

This module is meant to be used together with L<Test::YAML::Meta>, however
the code is self contained enough that you can access it directly.

=head1 ABSTRACT

Validation of META.yml specification elements.

=cut
34
35#----------------------------------------------------------------------------
36
37#############################################################################
38#Specification Definitions #
39#############################################################################
40
41my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
42my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
43my $no_index_1_3 = {
44    'map' => { file => { list => { value => \&string } },
45                     directory => { list => { value => \&string } },
46                     'package' => { list => { value => \&string } },
47                     namespace => { list => { value => \&string } },
48    }
49};
50my $no_index_1_2 = {
51    'map' => { file => { list => { value => \&string } },
52                     dir => { list => { value => \&string } },
53                     'package' => { list => { value => \&string } },
54                     namespace => { list => { value => \&string } },
55    }
56};
57my $no_index_1_1 = {
58    'map' => { ':key' => { name => \&word, list => { value => \&string } },
59    }
60};
61
62my %definitions = (
63'1.3' => {
64# 'header' => { mandatory => 1, value => \&header },
65  'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version},
66                                                    url => { mandatory => 1, value => \&urlspec } } },
67
68  'name' => { mandatory => 1, value => \&string },
69  'version' => { mandatory => 1, value => \&version },
70  'license' => { mandatory => 1, value => \&license },
71  'generated_by' => { mandatory => 1, value => \&string },
72  'author' => { mandatory => 1, list => { value => \&string } },
73
74  'abstract' => { value => \&string },
75  'dynamic_config' => { value => \&boolean },
76
77  'requires' => $module_map1,
78  'recommends' => $module_map1,
79  'build_requires' => $module_map1,
80  'conflicts' => $module_map2,
81
82  'optional_features' => {
83    list => {
84        ':key' => { name => \&word,
85            'map' => { description => { value => \&string },
86                         requires_packages => { value => \&string },
87                         requires_os => { value => \&string },
88                         excludes_os => { value => \&string },
89                         requires => $module_map1,
90                         recommends => $module_map1,
91                         build_requires => $module_map1,
92                         conflicts => $module_map2,
93            }
94        }
95     }
96  },
97
98  'provides' => {
99    'map' => { ':key' => { name => \&module,
100                                 'map' => { file => { mandatory => 1, value => \&file },
101                                            version => { value => \&version } } } }
102  },
103
104  'no_index' => $no_index_1_3,
105  'private' => $no_index_1_3,
106
107  'keywords' => { list => { value => \&string } },
108
109  'resources' => {
110    'map' => { license => { value => \&url },
111                     homepage => { value => \&url },
112                     bugtracker => { value => \&url },
113                     repository => { value => \&url },
114                     ':key' => { value => \&string, name => \&resource },
115    }
116  },
117
118  # additional user defined key/value pairs
119  # note we can only validate the key name, as the structure is user defined
120  ':key' => { name => \&word },
121},
122
123# v1.2 is misleading, it seems to assume that a number of fields where created
124# within v1.1, when they were created within v1.2. This may have been an
125# original mistake, and that a v1.1 was retro fitted into the timeline, when
126# v1.2 was originally slated as v1.1. But I could be wrong ;)
127'1.2' => {
128# 'header' => { mandatory => 1, value => \&header },
129  'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version},
130                                                        url => { mandatory => 1, value => \&urlspec } } },
131
132  'name' => { mandatory => 1, value => \&string },
133  'version' => { mandatory => 1, value => \&version },
134  'license' => { mandatory => 1, value => \&license },
135  'distribution_type' => { mandatory => 1, value => \&string },
136  'generated_by' => { mandatory => 1, value => \&string },
137  'author' => { mandatory => 1, list => { value => \&string } },
138
139  'abstract' => { value => \&string },
140  'dynamic_config' => { value => \&boolean },
141
142  'keywords' => { list => { value => \&string } },
143
144  'private' => $no_index_1_2,
145  '$no_index' => $no_index_1_2,
146
147  'requires' => $module_map1,
148  'recommends' => $module_map1,
149  'build_requires' => $module_map1,
150  'conflicts' => $module_map2,
151
152  'provides' => {
153    'map' => { ':key' => { name => \&module,
154                                 'map' => { file => { mandatory => 1, value => \&file },
155                                            version => { value => \&version } } } }
156  },
157
158  'resources' => {
159    'map' => { license => { value => \&url },
160                     homepage => { value => \&url },
161                     bugtracker => { value => \&url },
162                     repository => { value => \&url },
163                     ':key' => { value => \&string, name => \&resource },
164    }
165  },
166
167  # additional user defined key/value pairs
168  # note we can only validate the key name, as the structure is user defined
169  ':key' => { name => \&word },
170},
171
172# note that the 1.1 spec doesn't specify optional or mandatory fields, what
173# appears below is assumed from later specifications.
174'1.1' => {
175# 'header' => { mandatory => 1, value => \&header },
176  'name' => { mandatory => 1, value => \&string },
177  'version' => { mandatory => 1, value => \&version },
178  'license' => { mandatory => 1, value => \&license },
179  'license_uri' => { mandatory => 0, value => \&url },
180  'distribution_type' => { mandatory => 1, value => \&string },
181  'generated_by' => { mandatory => 1, value => \&string },
182
183  'dynamic_config' => { value => \&boolean },
184
185  'private' => $no_index_1_1,
186
187  'requires' => $module_map1,
188  'recommends' => $module_map1,
189  'build_requires' => $module_map1,
190  'conflicts' => $module_map2,
191
192  # additional user defined key/value pairs
193  # note we can only validate the key name, as the structure is user defined
194  ':key' => { name => \&word },
195},
196
197# note that the 1.0 spec doesn't specify optional or mandatory fields, what
198# appears below is assumed from later specifications.
199'1.0' => {
200# 'header' => { mandatory => 1, value => \&header },
201  'name' => { mandatory => 1, value => \&string },
202  'version' => { mandatory => 1, value => \&version },
203  'license' => { mandatory => 1, value => \&license },
204  'distribution_type' => { mandatory => 1, value => \&string },
205  'generated_by' => { mandatory => 1, value => \&string },
206
207  'dynamic_config' => { value => \&boolean },
208
209  'requires' => $module_map1,
210  'recommends' => $module_map1,
211  'build_requires' => $module_map1,
212  'conflicts' => $module_map2,
213
214  # additional user defined key/value pairs
215  # note we can only validate the key name, as the structure is user defined
216  ':key' => { name => \&word },
217},
218);
219
220#############################################################################
221#Code #
222#############################################################################
223
224 - 239
=head1 CLASS CONSTRUCTOR

=over

=item * new( yaml => $yaml [, spec => $version] )

The constructor must be passed a valid YAML data structure. 

Optionally you may also provide a specification version. This version is then
use to ensure that the given YAML data structure meets the respective 
specification definition. If no version is provided the module will attempt to 
deduce the appropriate specification version from the data structure itself.

=back

=cut
240
241sub new {
242
42
1
0
    my ($class,%hash) = @_;
243
244    # create an attributes hash
245
42
0
    my $atts = {
246        'spec' => $hash{spec},
247        'yaml' => $hash{yaml},
248    };
249
250    # create the object
251
42
0
    my $self = bless $atts, $class;
252}
253
254 - 273
=head1 METHODS

=head2 Main Methods

=over

=item * parse()

Using the YAML data structure provided with the constructure, attempts to 
parse and validate according to the appropriate specification definition.

Returns 1 if any errors found, otherwise returns 0.

=item * errors()

Returns a list of the errors found during parsing.

=back

=cut
274
275sub parse {
276
41
1
0
    my $self = shift;
277
41
0
    my $data = $self->{yaml};
278
279
41
0
    unless($self->{spec}) {
280
20
0
        $self->{spec} = $data->{'meta-spec'} && $data->{'meta-spec'}->{'version'} ? $data->{'meta-spec'}->{'version'} : '1.0';
281    }
282
283
41
0
    $self->check_map($definitions{$self->{spec}},$data);
284
41
0
    return defined $self->{errors} ? 1 : 0;
285}
286
287sub errors {
288
40
1
0
    my $self = shift;
289
40
0
    return () unless($self->{errors});
290
22
22
0
0
    return @{$self->{errors}};
291}
292
293 - 309
=head2 Check Methods

=over

=item * check_map($spec,$data)

Checks whether a map (or hash) part of the YAML data structure conforms to the 
appropriate specification definition.

=item * check_list($spec,$data)

Checks whether a list (or array) part of the YAML data structure conforms to 
the appropriate specification definition.

=back

=cut
310
311sub check_map {
312
330
1
0
    my ($self,$spec,$data) = @_;
313
314
330
0
    if(ref($data) ne 'HASH') {
315
3
0
        $self->_error( "Expected a map structure from YAML string or file" );
316
3
0
        return;
317    }
318
319
327
0
    for my $key (keys %$spec) {
320
1240
20030
        next unless($spec->{$key}->{mandatory});
321
371
0
        next if(defined $data->{$key});
322
4
4
0
0
        push @{$self->{stack}}, $key;
323
4
0
        $self->_error( "Missing mandatory field, '$key'" );
324
4
4
0
0
        pop @{$self->{stack}};
325    }
326
327
327
0
    for my $key (keys %$data) {
328
1149
1149
0
10015
        push @{$self->{stack}}, $key;
329
1149
0
        if($spec->{$key}) {
330
708
0
            if($spec->{$key}{value}) {
331
422
0
                $spec->{$key}{value}->($self,$key,$data->{$key});
332            } elsif($spec->{$key}{'map'}) {
333
219
0
                $self->check_map($spec->{$key}{'map'},$data->{$key});
334            } elsif($spec->{$key}{'list'}) {
335
67
0
                $self->check_list($spec->{$key}{'list'},$data->{$key});
336            }
337
338        } elsif ($spec->{':key'}) {
339
441
0
            $spec->{':key'}{name}->($self,$key,$key);
340
441
10015
            if($spec->{':key'}{value}) {
341
278
10015
                $spec->{':key'}{value}->($self,$key,$data->{$key});
342            } elsif($spec->{':key'}{'map'}) {
343
66
0
                $self->check_map($spec->{':key'}{'map'},$data->{$key});
344            } elsif($spec->{':key'}{'list'}) {
345
0
0
                $self->check_list($spec->{':key'}{'list'},$data->{$key});
346            }
347
348
349        } else {
350
0
0
            $self->_error( "Unknown key, '$key', found in map structure" );
351        }
352
1148
1148
0
0
        pop @{$self->{stack}};
353    }
354}
355
356sub check_list {
357
69
1
0
    my ($self,$spec,$data) = @_;
358
359
69
0
    if(ref($data) ne 'ARRAY') {
360
3
0
        $self->_error( "Expected a list structure" );
361
3
0
        return;
362    }
363
364
66
0
    if(defined $spec->{mandatory}) {
365
0
0
        if(!defined $data->[0]) {
366
0
0
            $self->_error( "Missing entries from mandatory list" );
367        }
368    }
369
370
66
0
    for my $value (@$data) {
371
95
95
0
0
        push @{$self->{stack}}, $value;
372
95
10015
        if(defined $spec->{value}) {
373
93
0
            $spec->{value}->($self,'list',$value);
374        } elsif(defined $spec->{'map'}) {
375
0
0
            $self->check_map($spec->{'map'},$value);
376        } elsif(defined $spec->{'list'}) {
377
0
0
            $self->check_list($spec->{'list'},$value);
378
379        } elsif ($spec->{':key'}) {
380
2
0
            $self->check_map($spec,$value);
381
382        } else {
383
0
0
            $self->_error( "Unknown value type, '$value', found in list structure" );
384        }
385
93
93
0
0
        pop @{$self->{stack}};
386    }
387}
388
389 - 457
=head2 Validator Methods

=over

=item * header($self,$key,$value)

Validates that the YAML header is valid.

Note: No longer used as we now read the YAML data structure, not the file.

=item * url($self,$key,$value)

Validates that a given value is in an acceptable URL format

=item * urlspec($self,$key,$value)

Validates that the URL to a META.yml specification is a known one.

=item * string_or_undef($self,$key,$value)

Validates that the value is either a string or an undef value. Bit of a 
catchall function for parts of the data structure that are completely user
defined.

=item * string($self,$key,$value)

Validates that a string exists for the given key.

=item * file($self,$key,$value)

Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.

=item * exversion($self,$key,$value)

Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.

=item * version($self,$key,$value)

Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid.

=item * boolean($self,$key,$value)

Validates for a boolean value. Currently these values are '1', '0', 'true', 
'false', however the latter 2 may be removed.

=item * license($self,$key,$value)

Validates that the given value represents an known license type.

=item * resource($self,$key,$value)

Validates that the given key is in CamelCase, to indicate a user defined 
keyword.

=item * word($self,$key,$value)

Validates that key is in an acceptable format for the META.yml specification,
i.e. any in the character class [-_a-z].

=item * module($self,$key,$value)

Validates that a given key is in an acceptable module name format, e.g. 
'Test::YAML::Meta::Version'.

=back

=cut
458
459sub header {
460
4
1
0
    my ($self,$key,$value) = @_;
461
4
0
    if(defined $value) {
462
3
0
        return 1 if($value && $value =~ /^--- #YAML:1.0/);
463    }
464
3
0
    $self->_error( "file does not have a valid YAML header." );
465
3
0
    return 0;
466}
467
468#my $protocol = qr¬(?:http|https|ftp|afs|news|nntp|mid|cid|mailto|wais|prospero|telnet|gopher)¬;
469my $protocol = qr¬(?:ftp|http|https)¬;
470my $badproto = qr¬(\w+)://¬;
471my $proto = qr¬$protocol://(?:[\w]+:\w+@)?¬;
472my $atom = qr¬[a-z\d]¬i;
473my $domain = qr¬((($atom(($atom|-)*$atom)?)\.)*([a-zA-Z](($atom|-)*$atom)?))¬;
474my $ip = qr¬((\d+)(\.(\d+)){3})(:(\d+))?¬;
475my $enc = qr¬%[a-fA-F\d]{2}¬;
476my $legal1 = qr¬[a-zA-Z\d\$\-_.+!*'(),]¬; #' - this comment is to avoid syntax highlighting issues
477my $legal2 = qr¬[;:@&=]¬;
478my $legal3 = qr¬((($legal1|$enc)|$legal2)*)¬;
479my $path = qr¬\/$legal3(\/$legal3)*¬;
480my $query = qr¬\?$legal3¬;
481my $urlregex = qr¬(($proto)?($domain|$ip)(($path)?($query)?)?)¬;
482
483sub url {
484
25
1
0
    my ($self,$key,$value) = @_;
485
25
0
    if(defined $value) {
486
24
0
        if($value && $value =~ /^$badproto$/) {
487
4
0
            $self->_error( "Domain name required for a valid URL." );
488
4
0
            return 0;
489        }
490
20
0
        if($value && $value =~ /^$badproto/ && $1 !~ $protocol) {
491
1
0
            $self->_error( "Unknown protocol used in URL." );
492
1
0
            return 0;
493        }
494
19
0
        return 1 if($value && $value =~ /^$urlregex$/);
495    }
496
3
0
    $value ||= '';
497
3
0
    $self->_error( "'$value' for '$key' is not a valid URL." );
498
3
0
    return 0;
499}
500
501my %known_specs = (
502    '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
503    '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
504    '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
505    '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
506);
507my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
508
509sub urlspec {
510
38
1
10015
    my ($self,$key,$value) = @_;
511
38
10015
    if(defined $value) {
512
37
0
        return 1 if($value && $known_specs{$self->{spec}} eq $value);
513
8
0
        if($value && $known_urls{$value}) {
514
6
0
            $self->_error( 'META.yml specification URL does not match version' );
515
6
0
            return 0;
516        }
517    }
518
3
0
    $self->_error( 'Unknown META.yml specification' );
519
3
0
    return 0;
520}
521
522sub string {
523
227
1
0
    my ($self,$key,$value) = @_;
524
227
0
    if(defined $value) {
525
226
10015
        return 1 if($value || $value =~ /^0$/);
526    }
527
2
0
    $self->_error( "value is an undefined string" );
528
2
0
    return 0;
529}
530
531sub string_or_undef {
532
4
1
0
    my ($self,$key,$value) = @_;
533
4
0
    return 1 unless(defined $value);
534
3
0
    return 1 if($value || $value =~ /^0$/);
535
1
0
    $self->_error( "No string defined for '$key'" );
536
1
0
    return 0;
537}
538
539sub file {
540
65
1
0
    my ($self,$key,$value) = @_;
541
65
0
    return 1 if(defined $value);
542
1
0
    $self->_error( "No file defined for '$key'" );
543
1
0
    return 0;
544}
545
546sub exversion {
547
282
1
0
    my ($self,$key,$value) = @_;
548
282
0
    if(defined $value && ($value || $value =~ /0/)) {
549
279
0
        my $pass = 1;
550
279
284
0
0
        for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
551
279
0
        return $pass;
552    }
553
3
0
    $value = '<undef>' unless(defined $value);
554
3
0
    $self->_error( "'$value' for '$key' is not a valid version." );
555
3
0
    return 0;
556}
557
558sub version {
559
430
1
0
    my ($self,$key,$value) = @_;
560
430
20030
    if(defined $value) {
561
428
0
        return 0 unless($value || $value =~ /0/);
562
427
0
        return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?\d+((\.\d+((_|\.)\d+)?)?)/);
563    } else {
564
2
0
        $value = '<undef>';
565    }
566
6
0
    $self->_error( "'$value' for '$key' is not a valid version." );
567
6
0
    return 0;
568}
569
570sub boolean {
571
8
1
0
    my ($self,$key,$value) = @_;
572
8
0
    if(defined $value) {
573
6
0
        return 1 if($value =~ /^(0|1|true|false)$/);
574    } else {
575
2
0
        $value = '<undef>';
576    }
577
4
0
    $self->_error( "'$value' for '$key' is not a boolean value." );
578
4
0
    return 0;
579}
580
581my %licenses = (
582    perl => 'http://dev.perl.org/licenses/',
583    gpl => 'http://www.opensource.org/licenses/gpl-license.php',
584    apache => 'http://apache.org/licenses/LICENSE-2.0',
585    artistic => 'http://opensource.org/licenses/artistic-license.php',
586    lgpl => 'http://opensource.org/licenses/artistic-license.php',
587    bsd => 'http://www.opensource.org/licenses/bsd-license.php',
588    gpl => 'http://www.opensource.org/licenses/gpl-license.php',
589    mit => 'http://opensource.org/licenses/mit-license.php',
590    mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
591    open_source => undef,
592    unrestricted => undef,
593    restrictive => undef,
594    unknown => undef,
595);
596
597sub license {
598
57
1
0
    my ($self,$key,$value) = @_;
599
57
0
    if(defined $value) {
600
56
0
        return 1 if($value && exists $licenses{$value});
601    } else {
602
1
0
        $value = '<undef>';
603    }
604
3
0
    $self->_error( "License '$value' is unknown" );
605
3
0
    return 0;
606}
607
608sub resource {
609
4
1
0
    my ($self,$key) = @_;
610
4
0
    if(defined $key) {
611
3
10015
        return 1 if($key && $key =~ /^([A-Z][a-z]+)+$/);
612    } else {
613
1
0
        $key = '<undef>';
614    }
615
3
0
    $self->_error( "Resource '$key' must be in CamelCase." );
616
3
0
    return 0;
617}
618
619sub word {
620
105
1
0
    my ($self,$key) = @_;
621
105
0
    if(defined $key) {
622
104
0
        return 1 if($key && $key =~ /^([-_a-z]+)$/);
623    } else {
624
1
0
        $key = '<undef>';
625    }
626
3
0
    $self->_error( "Key '$key' is not a legal keyword." );
627
3
0
    return 0;
628}
629
630sub module {
631
347
1
0
    my ($self,$key) = @_;
632
347
0
    if(defined $key) {
633
346
10015
        return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
634    } else {
635
1
0
        $key = '<undef>';
636    }
637
9
0
    $self->_error( "Key '$key' is not a legal module name." );
638
9
0
    return 0;
639}
640
641sub _error {
642
65
0
    my $self = shift;
643
65
0
    my $mess = shift;
644
645
65
25
0
0
    $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
646
65
0
    $mess .= " [Validation: $self->{spec}]";
647
648
65
65
0
0
    push @{$self->{errors}}, $mess;
649}
650
651q( Currently Listening To: Nine Inch Nails - "With Teeth" );
652