view release on metacpan or  search on metacpan

lib/CPE.pm  view on Meta::CPAN

) {
    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:/
                  (?<part>[aoh])?
                  (?: \: (?<vendor>     [^:]*) )?
                  (?: \: (?<product>    [^:]*) )?
                  (?: \: (?<version>    [^:]*) )?
                  (?: \: (?<update>     [^:]*) )?
                  (?: \: (?<edition>    [^:]*) )?
                  (?: \: (?<language>   [^:]*) )?
                  (?: \: (?<sw_edition> [^:]*) )?
                  (?: \: (?<target_sw>  [^:]*) )?
                  (?: \: (?<target_hw>  [^:]*) )?
                  (?: \: (?<other>      [^:]*) )?
                }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:
                ! " \# \$ \% \& ' \( \) \+ , \/ \:
                ; \< \= \> \@ \[ \\ \] \^ \` \{ \| \}