File Coverage

blib/lib/CPE.pm

Criterion	Covered	Total	%
statement	55	66	83.3
branch	31	44	70.4
condition	2	3	66.6
subroutine	9	16	56.2
pod	8	8	100.0
total	105	137	76.6

package CPE;
use strict;
use warnings;
use Carp ();

our $VERSION = '0.02';

for my $accessor_name (qw(
    cpe_version
    part  vendor  product  version  update  edition
    language  sw_edition  target_sw  target_hw  other)
) {
    my $sub = sub {
        die "method '$accessor_name' takes 0 or 1 arguments, not " . scalar(@_ - 1) if @_ > 2;
        my ($self, $new) = @_;
        my $old = $self->{$accessor_name};

        if (@_ == 2) {
            my $validator = $accessor_name eq 'cpe_version' ? qr/\A2\.3\z/
                          : $accessor_name eq 'part'? qr/\A[aoh]\z/
                          : qr/\A[a-z0-9\._\-~%]*\z/;
            die  "invalid value '$new' for '$accessor_name'"
                unless $new =~ $validator;
            $self->{$accessor_name} = $new;
        }
        return $old;
    };
    { no strict 'refs'; *$accessor_name = $sub; }
}

sub is_equal    { die 'TODO' }
sub is_subset   { die 'TODO' }
sub is_superset { die 'TODO' }
sub is_disjoint { die 'TODO' }

sub as_string { die 'TODO' }
sub as_wfn    { die 'TODO' }
sub as_uri    { die 'TODO' }

sub new {
    my ($class, @args) = @_;
    my $self = @args == 1 ? _from_string($args[0]) : _from_hash(@args);
    return bless $self, $class;
}

sub _from_string {
    my ($str) = @_;

    if ($str =~ m{cpe:/
                  (?[aoh])?
                  (?: \: (?     [^:]*) )?
                  (?: \: (?    [^:]*) )?
                  (?: \: (?    [^:]*) )?
                  (?: \: (?     [^:]*) )?
                  (?: \: (?    [^:]*) )?
                  (?: \: (?   [^:]*) )?
                  (?: \: (? [^:]*) )?
                  (?: \: (?  [^:]*) )?
                  (?: \: (?  [^:]*) )?
                  (?: \: (?      [^:]*) )?
                }ix
    ) {
        my %data = %+;
        foreach my $k (keys %data) {
            if ($data{$k} eq '') {
                $data{$k} = 'ANY';
            }
            elsif ($data{$k} eq '-') {
                $data{$k} = 'NA';
            }
            elsif ($data{$k} =~ /\%/) {
                # URI CPEs may have percent-encoded special characters
                # which must be decoded to proper values.
                my %decoded = (
                    '21' => '!', '22' => '"', '23' => '#', '24' => '$',
                    '25' => '%', '26' => '&', '27' => q('), '28' => '(',
                    '29' => ')', '2a' => '*', '2b' => '+', '2c' => ',',
                    '2f' => '/', '3a' => ':', '3b' => ';', '3c' => '<',
                    '3d' => '=', '3e' => '>', '3f' => '?', '40' => '@',
                    '5b' => '[', '5c' => '\\', '5d' => ']', '5e' => '^',
                    '60' => '`', '7b' => '{', '7c' => '|', '7d' => '}',
                    '7e' => '~',
                );
                $data{$k} =~ s{\%01}{?}g if index($data{$k}, '%01') >= 0;
                $data{$k} =~ s{\%02}{*}g if index($data{$k}, '%02') >= 0;
                foreach my $special (keys %decoded) {
                    if (index($data{$k}, '%' . $special) >= 0) {
                        $data{$k} =~ s{\%$special}{\\$decoded{$special}}ig;
                    }
                }
            }
        }
        # this is a compatibility layer between CPE 2.2 and 2.3.
        # URIs using 2.3 format will have the 'edition' field starting
        # with a '~' and with '~' dividing all the new 2.3 fields within.
        # In 2.2 this is not done, and those fields don't exist.
        if (defined $data{edition} && substr($data{edition}, 0, 1) eq '~') {
            (undef,
             $data{edition},
             $data{sw_edition},
             $data{target_sw},
             $data{target_hw},
             $data{other},
            ) = map { $_ eq '' ? 'ANY' : $_ eq '-' ? 'NA' : $_ }
                # split() ignores empty values unless there is a defined
                # value afterwards, so we add an extra '!' element to the list
                # and ignore it:
                split /\~/ => $data{edition} . '~!';
        }
        return _from_hash(cpe_version => 2.3, %data);
    }
    die 'sorry, only URI CPEs can be parsed at this point. Patches welcome!';
}

sub _from_hash {
    my (%args) = @_;
    my $self = { cpe_version => '2.3', part => 'ANY' };
    foreach my $key (qw(vendor product version update edition
                        language sw_edition target_sw target_hw other)
    ) {
        if (!exists $args{$key}) {
            $self->{$key} = 'ANY';
            next;
        }
        Carp::croak "invalid characters '$args{$key}' in '$key' field."
            unless $args{$key} =~ m/\A(?:[
                a-z 0-9 \. _   # regular characters
                \- \~          # special meaning characters
                \* \?          # quantifiers
                # or any of the following special characters:
                ! " \# \$ \% \& ' \( \) \+ , \/ \:
                ; \< \= \> \@ \[ \\ \] \^ \` \{ \| \}
               ]*
               | ANY | NA     # 'ANY' and 'NA' are special values
            )\z/x;
        $self->{$key} = $args{$key};
    }
    if (exists $args{'part'}) {
        Carp::croak "'part' field must be 'a', 'o' or 'h'."
            unless $args{'part'} =~ m/\A[aoh]\z/;
        $self->{'part'} = $args{'part'};
    }
    if (exists $args{'cpe_version'}) {
        Carp::croak "only cpe_version 2.2 and 2.3 are accepted"
            unless $args{'cpe_version'} =~ m/\A2\.[23]\z/;
        $self->{'cpe_version'} = $args{'cpe_version'};
    }
    return $self;
}

1;
__END__