App-DubiousHTTP
1 match

 view release on metacpan or  search on metacpan

lib/App/DubiousHTTP/Tests/Common.pm  view on Meta::CPAN 

FAVICON
);


my %cache;
sub content {
    my ($page,$spec) = @_;
    $page =~s{^/+}{};
    if (my $e = $cache{$page}) {
	return @$e;
    }

    my ($hdr,$data,$bad);
    if ( $basedir && -f "$basedir/$page" && open( my $fh,'<',"$basedir/$page" )) {
	$data = do { local $/; <$fh> };
	if ($data =~s{\A((?:\w+(?:-\w*)*:.*\r?\n){1,10})\r?\n}{}) {
	    # assume header + body
	    ( $hdr = $1 ) =~s{\r?\n}{\r\n}g;
	    $bad = $1 if $hdr =~s{^X-Virus:[ \t]*(.*\S)[ \t]*\r?\n}{}mi;
	    # check if we have a brotli compressed version
	    if (open($fh,'<',"$basedir/$page.brotli")
		and my $brotli = do { local $/; <$fh> }) {
		# remove optional header
		$brotli =~s{\A((?:\w+(?:-\w*)*:.*\r?\n){1,10})\r?\n}{};
		bro_compress($data,$brotli);
	    }
	} else {
	    $hdr =
		$page =~m{\.js$} ? "Content-type: application/javascript\r\n" :
		$page =~m{\.css$} ? "Content-type: text/css\r\n" :
		$page =~m{\.html?$} ? "Content-type: text/html\r\n" :
		$page =~m{\.(gif|png|jpeg)$} ? "Content-type: image/$1\r\n" :
		"Content-type: application/octet-stream\r\n";
	}
	$cache{$page} = [ $hdr,$data,$bad ];
	return ($hdr,$data,$bad);
    }
    if ( my $builtin = $builtin{$page} ) {
	$builtin = $builtin->($spec,"/$page") if ref($builtin) eq 'CODE';
	return @$builtin;
    }
    return;
}

sub html_escape {
    local $_ = shift;
    s{\&}{&amp;}g;
    s{<}{&lt;}g;
    s{>}{&gt;}g;
    return $_
}

sub url_encode {
    local $_ = shift;
    s{([^\w\-&/?=!$~.,;])}{ sprintf("%%%02X",ord($1)) }esg;
    return $_;
}

sub SETUP {
    my ($id,$desc,$ldesc,@tests) = @_;
    my $pkg = caller();
    my @tests_only;
    for my $t (@tests) {
	# title | valid,spec,desc
	if (@$t>1) {
	    $t = bless [ @{$t}[1,2,0] ], $pkg.'::Test';
	    push @tests_only, $t;
	}
    }

    no strict 'refs';
    *{$pkg.'::ID'} = sub { $id };
    *{$pkg.'::SHORT_DESC'} = sub { $desc };
    *{$pkg.'::LONG_DESC_HTML'} = sub { $ldesc };
    *{$pkg.'::TESTS'} = sub { @tests_only };
    *{$pkg.'::make_index_page'} = sub { 
	my ($self,$page,$spec,$rqhdr) = @_;
	return make_index_page($pkg,@tests) if ! $spec;
	return make_index_page($pkg,undef,grep { $_->[0] && $_->[0] eq $spec } @tests);
    };

    *{$pkg.'::Test::ID'} = sub { shift->[0] };
    *{$pkg.'::Test::LONG_ID'} = sub { "$id-" . shift->[0] };
    *{$pkg.'::Test::NUM_ID'} = sub { _path2num("$id/".shift->[0]) };
    *{$pkg.'::Test::DESCRIPTION'} = sub { shift->[1] };
    *{$pkg.'::Test::VALID'} = sub { shift->[2] };
    *{$pkg.'::Test::url'} = sub { 
	my ($self,$page) = @_;
	return garble_url("/$id/$page/$self->[0]");
    };
    *{$pkg.'::Test::make_response'} = sub { 
	my ($self,$page,$spec,$rqhdr) = @_;
	return $pkg->make_response($page,$self->[0],$rqhdr);
    };
}

sub make_index_page {
    my ($class,@tests) = @_;
    my $body = <<'BODY';
<!doctype html><html lang=en><body>
<script src=/ping.js></script>
<link rel="stylesheet" href="/stylesheet.css">
BODY
    if ($tests[0]) {
	$body .= "<h1>".$class->SHORT_DESC."</h1>";
	$body .= $class->LONG_DESC_HTML()."<hr>";
    } else {
	# skip header
	shift @tests
    }
    $body .= '<table style="width: 100%; border-style: none; border-spacing: 0px;">';
    for my $test (@tests) {
	if (!blessed($test)) {
	    $body .= "<tr><td colspan=6><h2>$test->[0]</h2></td></tr>";
	    next;
	} 
	my $valid = $test->VALID;
	my $base = $valid>0 ? 'ok' : $valid<0 ? 'warn' : 'bad';
	my $bg = $valid>0 ? '#e30e2c' : $valid<0 ? '#d0cfd1' : '#00e800';
	$body .= "<tr>";
	$body .= "<td>". html_escape($test->DESCRIPTION) ."</td>";



( run in 0.522 second using v1.01-cache-2.11-cpan-437f7b0c052 )