CGI-Info
3 results

 view release on metacpan or  search on metacpan

scripts/generate_index.pl  view on Meta::CPAN 

      matching survivors are skipped (with a note if --verbose is active).
      New boundary values are merged into whichever edge key already
      exists in the schema (edge_case_array or edge_cases), with
      deduplication against existing values.

      This flag is independent of --generate_test and can be used alone.

=head1 DASHBOARD SECTIONS

  Coverage Table    - Per-file statement/branch/condition/subroutine
                      percentages with delta vs previous snapshot,
                      sortable columns, and sparkline trend per file
  Coverage Trend    - Chart of total coverage over recent commits with
                      linear regression line, zoom and pan support
  RT Issues         - Count of open RT tickets for the distribution
  CPAN Testers      - Failure table for the current release, with
                      Perl version cliff detection, locale analysis,
                      dependency version cliff detection, and root
                      cause confidence scoring
  Mutation Report   - Per-file mutation score (killed/survived/total),
                      cyclomatic complexity, and TER3 (LCSAJ path

scripts/generate_index.pl  view on Meta::CPAN 

# Dependency correlation analysis
# -------------------------------
my $MAX_REPORTS_PER_GRADE = 20;	# safety rail
my $ENABLE_DEP_ANALYSIS = 1;

# Read and decode data
my $cover_db = eval { decode_json(read_file($config{cover_db})) };
my $mutation_db = eval { decode_json(read_file($config{mutation_db})) };

# --------------------------------------------------
# Compute coverage percentage from only our own files,
# excluding absolute paths (installed CPAN modules)
# which inflate Devel::Cover's pre-aggregated Total.
# --------------------------------------------------
my ($coverage_pct, $badge_color) = (0, 'red');

if($cover_db->{summary}) {
	my ($sum, $count) = (0, 0);
	for my $f (keys %{ $cover_db->{summary} }) {
		next if $f eq 'Total';
		next if $f =~ /^\//;    # skip absolute paths
		$sum += $cover_db->{summary}{$f}{total}{percentage} // 0;
		$count++;
	}
	if($count) {
		my $pct = _own_file_coverage_pct($cover_db->{summary});

		$coverage_pct = defined $pct ? int($pct) : 0;
		$badge_color  = $coverage_pct > $config{med_threshold} ? 'brightgreen'
			: $coverage_pct > $config{low_threshold} ? 'yellow'
			: 'red';
	}

scripts/generate_index.pl  view on Meta::CPAN 

		next if $file eq 'Total';
		next if $file =~ /^\//;    # skip absolute paths

		# Normalise blib/ paths and deduplicate against lib/ entries
		my $delta_key = $file;
		if($file =~ /^blib\/lib\/(.+)$/) {
			next if exists $cover_db->{summary}{"lib/$1"};
			$delta_key = "lib/$1";
		}

		my $curr = $cover_db->{summary}{$file}{total}{percentage} // 0;
		my $prev = $prev_data->{summary}{$file}{total}{percentage}
			// $prev_data->{summary}{$delta_key}{total}{percentage}
			// 0;
		my $delta = sprintf('%.1f', $curr - $prev);
		$deltas{$delta_key} = $delta;
	}
}

# Check if we're in a git repository first
unless (run_git('rev-parse', '--git-dir')) {
	die 'Error: Not in a git repository or git is not available';
}

scripts/generate_index.pl  view on Meta::CPAN 

		$display_file = $lib_path;
	}

	my $info = $cover_db->{summary}{$file};
	my $html_file = $display_file;
	$html_file =~ s|/|-|g;
	$html_file =~ s|\.pm$|-pm|;
	$html_file =~ s|\.pl$|-pl|;
	$html_file .= '.html';

	my $total = $info->{total}{percentage} // 0;
	$total_files++;
	$total_coverage += $total;
	$low_coverage_count++ if $total < $config{low_threshold};

	my $badge_class = $total >= $config{med_threshold} ? 'badge-good'
					: $total >= $config{low_threshold} ? 'badge-warn'
					: 'badge-bad';

	my $tooltip = $total >= $config{med_threshold} ? 'Excellent coverage'
				 : $total >= $config{low_threshold} ? 'Moderate coverage'

scripts/generate_index.pl  view on Meta::CPAN 

	my $badge_html = sprintf(
		'<span class="coverage-badge %s" title="%s">%.1f%%</span>',
		$badge_class, $tooltip, $total
	);

	my $delta_html;
	if (exists $deltas{$file}) {
		my $delta = $deltas{$file};
		my $delta_class = $delta > 0 ? 'positive' : $delta < 0 ? 'negative' : 'neutral';
		my $delta_icon = $delta > 0 ? '&#9650;' : $delta < 0 ? '&#9660;' : '&#9679;';
		my $prev_pct = $prev_data->{summary}{$file}{total}{percentage} // 0;

		$delta_html = sprintf(
			'<td class="%s" title="Previous: %.1f%%">%s %.1f%%</td>',
			$delta_class, $prev_pct, $delta_icon, abs($delta)
		);
	} else {
		$delta_html = '<td class="neutral" title="No previous data">&#9679;</td>';
	}

	my $source_url = $github_base . $display_file;
	my $has_coverage = (
		defined $info->{statement}{percentage} ||
		defined $info->{branch}{percentage} ||
		defined $info->{condition}{percentage} ||
		defined $info->{subroutine}{percentage}
	);

	my $source_link = $has_coverage
		? sprintf('<a href="%s" class="icon-link" title="View source on GitHub">&#128269;</a>', $source_url)
		: '<span class="disabled-icon" title="No coverage data">&#128269;</span>';

	# Create the sparkline - limit to last N points like the main trend chart
	my @file_history;

	# Get the last max_points history files (same as trend chart)
	my @limited_history = (scalar(@history_files) > $config{max_points})
		? @history_files[-$config{max_points} .. -1]
		: @history_files;

	# Use the already-cached historical data
	for my $hist_file (sort @limited_history) {
		my $json = $historical_cache{$hist_file};
		next unless $json;	# Skip if not cached (shouldn't happen, but be safe)

		if($json->{summary}{$file}) {
			my $pct = $json->{summary}{$file}{total}{percentage} // 0;
			push @file_history, sprintf('%.1f', $pct);
		}
	}

	my $points_attr = join(',', @file_history);

	push @html, sprintf(
		qq{<tr class="%s"><td><a href="%s" title="View coverage line by line" target="_blank">%s</a> %s<canvas class="sparkline" width="80" height="20" data-points="$points_attr"></canvas></td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%s</td>...
		$row_class, $html_file, $display_file, $source_link,
		$info->{statement}{percentage} // 0,
		$info->{branch}{percentage} // 0,
		$info->{condition}{percentage} // 0,
		$info->{subroutine}{percentage} // 0,
		$badge_html,
		$delta_html
	);
}

# Summary row
my $avg_coverage = $total_files ? int($total_coverage / $total_files) : 0;

push @html, sprintf(
	qq{<tr class="summary-row nosort"><td colspan="2"><strong>Summary</strong></td><td colspan="2">%d files</td><td colspan="3">Avg: %d%%, Low: %d</td></tr>},

scripts/generate_index.pl  view on Meta::CPAN 

	next if $file eq 'Total';
	next if $file =~ /^\//;	# skip absolute paths (installed modules)

	# Skip blib/ entries that have a corresponding lib/ entry
	# to avoid counting the same file twice in the totals
	if($file =~ /^blib\/lib\/(.+)$/) {
		next if exists $cover_db->{summary}{"lib/$1"};
	}

	my $info = $cover_db->{summary}{$file};
	$sum_stmt   += $info->{statement}{percentage}  // 0;
	$sum_branch += $info->{branch}{percentage} // 0;
	$sum_cond   += $info->{condition}{percentage}  // 0;
	$sum_sub    += $info->{subroutine}{percentage} // 0;
	$sum_total  += $info->{total}{percentage}      // 0;
	$counted++;
}

if($counted) {
	my $avg_total = $sum_total / $counted;
	my $class = $avg_total > 80 ? 'high' : $avg_total > 50 ? 'med' : 'low';

	push @html, sprintf(
		qq{<tr class="%s nosort"><td><strong>Total</strong></td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td colspan="2"><strong>%.1f</strong></td></tr>},
		$class,

scripts/generate_index.pl  view on Meta::CPAN 

	# e.g. YYYY-MM-DD-XXXXXXX.json — $sha will be undef otherwise
	next unless defined $sha;
	next unless $commit_messages{$sha};	# skip merge commits

	# Compute average across our own files only
	my ($sum, $count) = (0, 0);
	for my $f (keys %{ $json->{summary} }) {
		next if $f eq 'Total';
		next if $f =~ /^\//;
		next unless $f =~ /^(?:lib|blib|bin)\//;	# only own project files
		$sum += $json->{summary}{$f}{total}{percentage} // 0;
		$count++;
	}
	next unless $count;

	my $timestamp = $commit_times{$sha} // strftime('%Y-%m-%dT%H:%M:%S', localtime((stat($file))->mtime));

	# Git log returns format like: "2024-01-15 14:30:45 -0500" or "2024-01-15 14:30:45 +0000"
	# We need ISO 8601 format: "2024-01-15T14:30:45-05:00"

	# Replace space between date and time with 'T'

scripts/generate_index.pl  view on Meta::CPAN 

sub confidence_score {
	my (%args) = @_;

	my $fail = $args{fail} // 0;
	my $pass = $args{pass} // 0;

	return (0, 'none') if ($fail + $pass) == 0;

	my $score = $fail / ($fail + $pass);

	# Convert config thresholds from percent → fraction
	my $med = ($config{med_threshold} // 90) / 100;
	my $low = ($config{low_threshold} // 70) / 100;

	my $label =
		$score >= $med ? 'strong' :
		$score >= $low ? 'moderate' :
		'weak';

	return ($score, $label);
}

scripts/generate_index.pl  view on Meta::CPAN 

	my $killed = scalar @{ $file_data->{killed} || [] };
	my $survived = scalar @{ $file_data->{survived} || [] };
	my $total = $killed + $survived;

	return $total ? ($killed / $total) * 100 : 0;
}

# --------------------------------------------------
# _ter_badge
#
# Purpose:    Format a single TER percentage value as
#             a colour-coded HTML badge, consistent
#             with the coverage badge style used
#             elsewhere in the dashboard.
#
# Entry:      $pct   - percentage value (0-100), or
#                      undef if data is unavailable
#             $label - fallback text to display when
#                      $pct is undef (e.g. 'n/a')
#
# Exit:       Returns an HTML span string. Never
#             returns undef.
#
# Side effects: None.
#
# Notes:      Thresholds are taken from %config:

scripts/generate_index.pl  view on Meta::CPAN 

				$file, $lcsaj_dir, $lcsaj_hits, []
			);
			my $ter3_str;
			if (!defined $lcsaj_cov) {
				# .lcsaj.json not found — TER3 unavailable for this file
				$ter3_str = 'n/a';
			} elsif (!$lcsaj_total) {
				# File found but no paths defined
				$ter3_str = '-';
			} else {
				# Format as percentage with raw fraction for clarity
				$ter3_str = sprintf('%.1f%% (%d/%d)',
					($lcsaj_cov / $lcsaj_total) * 100,
					$lcsaj_cov,
					$lcsaj_total
				);
			}

			# Display TER1/TER2/TER3 coverage metrics in the summary block.
			# TER1 = statement, TER2 = branch, TER3 = LCSAJ path coverage.
			print $out "<div class='summary'>\n";

scripts/generate_index.pl  view on Meta::CPAN 

#
#   ($statement_total, $statement_hit,
#    $branch_total,    $branch_hit)
#
# This matches how the routine is used elsewhere in this file.
#
# NOTE:
# Devel::Cover's pre-aggregated Total key includes all
# instrumented files — CPAN dependencies, blib/ copies,
# and absolute paths — which massively deflates the
# reported percentage. We recompute from individual file
# entries, applying the same own-file filter used in the
# coverage table and badge calculation.
# ------------------------------------------------------------
sub _coverage_totals
{
	my $cov = $_[0];

	# Defensive checks to avoid warnings
	return (0,0,0,0) unless $cov;
	return (0,0,0,0) unless ref $cov eq 'HASH';

scripts/generate_index.pl  view on Meta::CPAN 

            }
        }
    }

	return ($covered, $total);
}

# --------------------------------------------------
# _own_file_coverage_pct
#
# Compute average coverage percentage across only the
# project's own files in a Devel::Cover summary hashref,
# excluding Devel::Cover's pre-aggregated Total key and
# any absolute paths (installed CPAN modules) which
# would otherwise inflate the reported figure.
#
# Arguments:
#   $summary - hashref of Devel::Cover summary data
#
# Returns:
#   Average total coverage percentage, or undef if no
#   qualifying files found
# --------------------------------------------------
sub _own_file_coverage_pct {
	my ($summary) = @_;

	return undef unless $summary;

	my ($sum, $count) = (0, 0);
	for my $f (keys %$summary) {
		next if $f eq 'Total';
		next if $f =~ /^\//;	# skip absolute paths
		next unless $f =~ /^(?:lib|blib|bin)\//;	# only own project files
		$sum += $summary->{$f}{total}{percentage} // 0;
		$count++;
	}

	return $count ? $sum / $count : undef;
}

t/edge_cases.t  view on Meta::CPAN 


    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on key with no equals sign');
};

# ============================================================
# 2. URL encoding edge cases
# ============================================================

subtest 'URL encoding: double-encoded percent signs' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'val=%2525';    # %25 => %, so %2525 => %25

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on double-encoded percent');
};

subtest 'URL encoding: incomplete percent sequence at end' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'val=hello%2';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on truncated percent sequence');
};

subtest 'URL encoding: NUL byte poison attempts' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    $ENV{QUERY_STRING}      = 'key%00=value&other=val%00ue';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };

t/edge_cases.t  view on Meta::CPAN 


    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on NUL in key');
    # key with embedded NUL should either be dropped or have NUL removed
    if(defined $p) {
        ok(!exists $p->{"ke\x00y"}, 'key with NUL byte not stored raw');
    }
};

subtest 'URL encoding: Unicode sequences via percent encoding' => sub {
    reset_env();
    $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
    $ENV{REQUEST_METHOD}    = 'GET';
    # %C3%A9 = UTF-8 for é
    $ENV{QUERY_STRING}      = 'name=caf%C3%A9';

    my $info = CGI::Info->new();
    my $p    = eval { $info->params() };
    ok(!$@, 'does not die on UTF-8 encoded unicode in value');
};

t/waf.t  view on Meta::CPAN 

};

subtest 'WAF: %00 NUL byte in value stripped' => sub {
	local %ENV = (
		GATEWAY_INTERFACE => 'CGI/1.1',
		REQUEST_METHOD    => 'GET',
		QUERY_STRING      => 'data=hello%2500world',
	);
	$info = new_ok('CGI::Info');
	my $params = $info->params();
	# %2500 URL-decodes to literal %00 (percent-zero-zero).
	# The fix applies the %00 strip a second time after URL-decoding,
	# so %2500 -> %00 -> '' and the value becomes 'helloworld'.
	if(defined $params && defined $params->{data}) {
		unlike($params->{data}, qr/\x00/, 'NUL byte not present after fix');
		unlike($params->{data}, qr/%00/,  'literal %00 stripped after URL-decode');
	} else {
		pass('params blocked or value empty after strip (acceptable)');
	}
};



( run in 1.589 second using v1.01-cache-2.11-cpan-39bf76dae61 )