view release on metacpan or  search on metacpan

lib/Test/CVE.pm  view on Meta::CPAN

    #        "https://bugzilla.redhat.com/show_bug.cgi?id=518278",
    #        "http://secunia.com/advisories/36415",
    #        "https://exchange.xforce.ibmcloud.com/vulnerabilities/52628"
    #        ],
    #     "title" : "Off-by-one error in the bzinflate function in Bzip2.xs in the Compress-Raw-Bzip2 module before 2.018 for Perl allows context-dependent attackers to cause a denial of service (application hang or crash) via a crafted bzip2 compres...
    #     "version_range" : [   ]
    #     }
    #  ],

    if (-s $src) {
	open my $fh, "<", $src or croak "$src: $!\n";
	local $/;
	$self->{j}{db} = decode_json (<$fh>);
	close $fh;
	}
    else {
	my $r = HTTP::Tiny->new (verify_SSL => 1)->get ($src);
	$r->{success} or die "$src: $@\n";

	$self->{verbose} > 1 and warn "Got it. Decoding\n";
	if (my $c = $r->{content}) {
	    # Skip warning part
	    # CPANSA-perl-2023-47038 has more than 1 range bundled together in '>=5.30.0,<5.34.3,>=5.36.0,<5.36.3,>=5.38.0,<5.38.2'
	    # {"Alien-PCRE2":[{"affected_versions":["<0.016000"],"cpansa_id":"CPANSA-Alien-PCRE2-2019-20454","cves":["CVE-2019-20454"],"description":"An out-
	    $c =~ s/^\s*([^{]+?)[\s\r\n]*\{/{/s and warn "$1\n";
	    $self->{j}{db} = decode_json ($c);

	    ### JSON strings to JSON structs in new format
	    if (ref $self->{j}{db} eq "HASH" and my @jk = sort keys %{$self->{j}{db}}) {
		foreach my $k (@jk) {
		    foreach my $r (@{$self->{j}{db}{$k} || []}) {
			my $s = $r->{cve} or next;
			ref $s and next;
			$s =~ m/^{/ or next;
			$r->{cve} = decode_json ($s);
			}
		    }
		}
	    }
	else {
	    $self->{j}{db} = undef;
	    }
	}
    $self->{j}{mod} = [ sort keys %{$self->{j}{db} // {}} ];
    $self;
    } # _read_cpansa

sub _read_MakefilePL {
    my ($self, $mf) = @_;
    $mf ||= $self->{make_pl};

    $self->{verbose} and warn "Reading $mf ...\n";
    open my $fh, "<", $mf or return $self;
    my $mfc = do { local $/; <$fh> };
    close $fh;

    $mfc or return $self;

    my ($pv, $release, $nm, $v, $vf) = ("");
    foreach my $mfx (grep { m/=>/ }
		     map  { split m/\s*[;(){}]\s*/ }
		     map  { split m/\s*,(?!\s*=>)/ }
			    split m/[,;]\s*(?:#.*)?\r*\n/ => $mfc) {
	$mfx =~ s/[\s\r\n]+/ /g;
	$mfx =~ s/^\s+//;
	$mfx =~ s/^(['"])(.*?)\1/$2/;	# Unquote key
	my $a = qr{\s* (?:,\s*)? => \s* (?|"([^""]*)"|'([^'']*)'|([-\w.]+))}x;
	$mfx =~ m/^ VERSION          $a /ix and $v       //= $1;
	$mfx =~ m/^ VERSION_FROM     $a /ix and $vf      //= $1;
	$mfx =~ m/^     NAME         $a /ix and $nm      //= $1;
	$mfx =~ m/^ DISTNAME         $a /ix and $release //= $1;
	$mfx =~ m/^ MIN_PERL_VERSION $a /ix and $pv      ||= $1;
	}

    unless ($release || $nm) {
	carp "Cannot get either NAME or DISTNAME, so cowardly giving up\n";
	return $self;
	}
    unless ($pv) {
	$mfc =~ m/^\s*(?:use|require)\s+v?(5[.0-9]+)/m and $pv = $1;
	}
    $pv =~ m/^5\.(\d+)\.(\d+)$/ and $pv = sprintf "5.%03d%03d", $1, $2;
    $pv =~ m/^5\.(\d{1,3})$/    and $pv = sprintf "5.%03d000",  $1;

    $release //= $nm =~ s{-}{::}gr;
    $release eq "." && $nm and $release = $nm =~ s{::}{-}gr;
    if (!$v && $vf and open $fh, "<", $vf) {
	warn "Trying to fetch VERSION from $vf ...\n" if $self->{verbose};
	while (<$fh>) {
	    m/\b VERSION \s* = \s* ["']? ([^;'"\s]+) /x or next;
	    $v = $1;
	    last;
	    }
	close $fh;
	}
    unless ($v) {
	$mfc =~ m/\$\s*VERSION\s*=\s*["']?(\S+?)['"]?\s*;/ and $v = $1;
	}
    unless ($v) {
	carp "Could not derive a VERSION from Makefile.PL\n";
	carp "Please tell me where I did wrong\n";
	carp "(ideally this should be done by a CORE module)\n";
	}
    $self->{mf} = { name => $nm, version => $v, release => $release, mpv => $pv };
    $self->{verbose} and warn "Analysing for $release-", $v // "?", $pv ? " for minimum perl $pv\n" : "\n";
    $self->{prereq}{$release}{v}{$v // "-"} = "current";
    $self;
    } # _read_MakefilePL

sub _read_cpanfile {
    my ($self, $cpf) = @_;
    $cpf ||= $self->{cpanfile};

    -s $cpf or return; # warn "No cpanfile. Scan something else (Makefile.PL, META.json, ...\n";
    $self->{verbose} and warn "Reading $cpf ...\n";
    open my $fh, "<", $cpf or croak "$cpf: $!\n";
    while (<$fh>) {
	my ($t, $m, $v) = m{ \b
	  ( requires | recommends | suggest ) \s+
	  ["'] (\S+) ['"]
	  (?: \s*(?:=>|,)\s* ["'] (\S+) ['"])?
	  }x or next;
	$m =~ s/::/-/g;