CGI-Info
view release on metacpan or search on metacpan
lib/CGI/Info.pm view on Meta::CPAN
args => { $key => $value },
unknown_parameter_handler => 'die',
logger => $self->{'logger'}
});
};
if($@) {
$self->_info("Block $key = $value: $@");
$self->status(422);
next; # Skip to the next parameter
}
if(scalar keys %{$value}) {
$value = $value->{$key};
} else {
$self->_info("Block $key = $value");
$self->status(422);
next; # Skip to the next parameter
}
}
}
}
# if($self->{expect} && (List::Util::none { $_ eq $key } @{$self->{expect}})) {
# next;
# }
my $orig_value = $value;
$value = _sanitise_input($value);
# WAF: inspect all methods (GET and POST) for injection patterns.
# Previously gated on GET only, which allowed POST to bypass all checks.
{
# ($value =~ /\/AND\/.++\(SELECT\//) || # United/**/States)/**/AND/**/(SELECT/**/6734/**/FROM/**/(SELECT(SLEEP(5)))lRNi)/**/AND/**/(8984=8984
# From http://www.symantec.com/connect/articles/detection-sql-injection-and-cross-site-scripting-attacks
# Facebook FBCLID can have "--"
# Pre-filter: only run quote-based regexes if value contains injection chars.
# Compute pre-filter flags from orig_value so quotes stripped by
# convert_XSS don't cause injection patterns to be missed
my $has_quote = index($orig_value, "'") >= 0 || index($orig_value, '%27') >= 0;
my $has_hash = index($orig_value, '#') >= 0 || index($orig_value, '%23') >= 0;
my $has_equals = index($orig_value, '=') >= 0 || index($orig_value, '%3D') >= 0;
my $has_semi = index($orig_value, ';') >= 0 || index($orig_value, '%3B') >= 0;
my $has_dash = index($orig_value, '--') >= 0;
# All WAF patterns run on $orig_value (pre-XSS-sanitisation)
# convert_XSS encodes ', =, < etc. as HTML entities, which would hide
# injection patterns from the WAF if we checked $value instead.
if($has_quote || $has_hash || ($has_equals && $has_dash)) {
if(($orig_value =~ /(?:%27|'|%23|#)/i) ||
(($has_equals && ($has_quote || $has_semi || $has_dash)) &&
$orig_value =~ /(?:%3D|=)[^-]*+(?:%27|'|--|%3B|;)/i) ||
($has_quote &&
# Detect 'or'-style injection: word + quote + url-encoded or literal 'or' + SQL keyword.
# (?:%6F|o|%4F) = 'o', (?:%72|r|%52) = 'r', both case-folded via /i.
$orig_value =~ /\w*(?:%27|')(?:%6F|o|%4F)(?:%72|r|%52)\s*(?:OR|AND|UNION|SELECT|--)/ix) ||
($has_quote &&
$orig_value =~ /(?:%27|')union/ix)) {
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$key=$orig_value'");
} else {
$self->_warn("SQL injection attempt blocked for '$key=$orig_value'");
}
return;
}
}
my $has_select = index($orig_value, 'SELECT') >= 0 || index($orig_value, 'select') >= 0;
my $has_dump = index($orig_value, 'var_dump') >= 0;
my $has_exec = index($orig_value, 'exec') >= 0;
my $has_or = index($orig_value, ' OR ') >= 0;
my $has_and = index($orig_value, ' AND ') >= 0;
my $has_slash = index($orig_value, '/**/') >= 0 || index($orig_value, '/AND/') >= 0;
if(# \b anchors prevent matching inside longer words.
# {1,500}? is lazy+bounded: avoids catastrophic backtracking on
# "SELECT aaaa...aaaa" (no FROM) while still catching real queries.
($has_select && $orig_value =~ /\bselect\b.{1,500}?\bfrom\b/is) ||
($has_and && $orig_value =~ /\sAND\s1=1/ix) ||
# Numeric tautology without quotes: OR 1=1, OR 2=2, etc.
($has_or && $orig_value =~ /\bOR\s+\d+\s*=\s*\d+/i) ||
# Bounded lazy .{1,500}? avoids backtracking on "OR aaaa..." with no AND.
($has_or && $has_and && $orig_value =~ /\sOR\s.{1,500}?\sAND\s/) ||
($has_slash && $orig_value =~ /\/\*\*\/ORDER\/\*\*\/BY\/\*\*/ix) ||
($has_dump && $orig_value =~ /var_dump[^m]*+md5/) ||
($has_slash && $has_select && $orig_value =~ /\/AND\/[^(]*+\(SELECT\//) ||
($has_exec && $orig_value =~ /exec[\s+]++[sx]p\w+/ix)) {
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$key=$orig_value'");
} else {
$self->_warn("SQL injection attempt blocked for '$key=$orig_value'");
}
return;
}
if(my $agent = $ENV{'HTTP_USER_AGENT'}) {
# Bounded lazy .{1,500}? separates SQL keyword pairs without catastrophic backtracking.
# Possessive .++ would consume the trailing anchor — never match. Unbounded .+ risks ReDoS.
if(($agent =~ /\bSELECT\b.{1,500}?\bAND\b/i) || ($agent =~ /\bORDER\s+BY\b/i) || ($agent =~ /\bOR\s+NOT\b/i) || ($agent =~ /\bAND\b\s+\d+=\d+/) || ($agent =~ /\bTHEN\b.{1,300}?\bELSE\b.{1,300}?\bEND\b/i) || ($agent =~ /\bAND\b.{1,500}?\bSELECT\b/i...
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
} else {
$self->_warn("SQL injection attempt blocked for '$agent'");
}
return;
}
}
# XSS detection using [^>]+ instead of .+ or .++ :
# - [^>]+ stops naturally at '>' — no backtracking, no ReDoS.
# - [^>] also matches '\n', so multi-line payloads like
# "<img\nsrc=x\nonerror=alert(1)>" are caught without /s.
# - Replaces both the old [^\n]+ (stopped at newline — bypass)
# and the broken .++ (possessive consumed '>' — never matched).
if(($value =~ /(?:%3C|<)(?:%2F|\/)*[a-z0-9%]+(?:%3E|>)/ix) ||
($value =~ /(?:%3C|<)[^>]+(?:%3E|>)/i) ||
($orig_value =~ /(?:%3C|<)(?:%2F|\/)*[a-z0-9%]+(?:%3E|>)/ix) ||
($orig_value =~ /(?:%3C|<)[^>]+(?:%3E|>)/i)) {
$self->status(403);
$self->_warn("XSS injection attempt blocked for '$value'");
return;
}
# Block javascript: URI scheme — no angle brackets, but still executes
# script when used in href or src attributes.
if($orig_value =~ /\bjavascript\s*:/i) {
$self->status(403);
$self->_warn("XSS injection attempt blocked for '$value'");
return;
}
if($value =~ /mustleak\.com\//) {
$self->status(403);
$self->_warn("Blocked mustleak attack for '$key'");
return;
}
if($value =~ /\.\.\//) {
$self->status(403);
$self->_warn("Blocked directory traversal attack for '$key'");
return;
}
}
if(length($value) > 0) {
# Don't add if it's already there
if($FORM{$key} && ($FORM{$key} ne $value)) {
$FORM{$key} .= ",$value";
} else {
$FORM{$key} = $value;
}
}
}
unless(%FORM) {
return;
}
if($self->{'logger'}) {
while(my ($key,$value) = each %FORM) {
$self->_debug("$key=$value");
}
}
$self->{paramref} = \%FORM;
return Return::Set::set_return(\%FORM, { type => 'hashref', min => 1 });
}
=head2 param($field)
Get a single CGI parameter value by name.
When called without arguments it delegates to C<params()> and returns all parameters.
When called with a field name it returns that parameter's (sanitised) value,
or C<undef> if the parameter was not supplied or is not in the allow list.
use CGI::Info;
my $info = CGI::Info->new();
my $bar = $info->param('foo');
# With an allow list:
my $info2 = CGI::Info->new();
my $allowed = { foo => qr/\d+/ };
$info2->params(allow => $allowed);
my $bar2 = $info2->param('bar'); # logs a warning; returns undef
=over 4
=item $field
Optional. The name of the CGI parameter to retrieve.
If omitted, all parameters (as a hash-ref) are returned via C<params()>.
=back
=head3 API SPECIFICATION
=head4 Input
{
field => { type => 'scalar', optional => 1 },
lib/CGI/Info.pm view on Meta::CPAN
foreach my $rc($self->{logdir}, $ENV{'LOGDIR'}, Sys::Path->logdir(), $self->tmpdir()) {
if(defined($rc) && length($rc) && (-d $rc) && (-w $rc)) {
$dir = $rc;
last;
}
}
$self->_warn("Can't determine logdir") if((!defined($dir)) || (length($dir) == 0));
$self->{logdir} ||= $dir;
return $dir;
}
=head2 is_robot
Is the visitor a real person or a robot?
use CGI::Info;
my $info = CGI::Info->new();
unless($info->is_robot()) {
# update site visitor statistics
}
If the client is seen to be attempting an SQL injection,
set the HTTP status to 403,
and return 1.
=cut
sub is_robot {
my $self = shift;
if(defined($self->{is_robot})) {
return $self->{is_robot};
}
my $agent = $ENV{'HTTP_USER_AGENT'};
my $remote = $ENV{'REMOTE_ADDR'};
unless($remote && $agent) {
# Probably not running in CGI - assume real person
return 0;
}
# SQL injection check MUST run before is_ai(): a WAF block must never be
# bypassed just because the UA also identifies itself as an AI crawler.
# See also params() — patterns here MUST stay in sync with those in params().
# Bounded-lazy .{1,N}? replaces unbounded .+ to prevent O(n²/n³) backtracking
# on long UAs that contain SQL keywords but not the complete injection sequence.
# \b word boundaries prevent false positives on tokens like "SELECTFOO".
if(($agent =~ /\bSELECT\b.{1,500}?\bAND\b/i) ||
($agent =~ /\bORDER\s+BY\b/i) ||
($agent =~ /\bOR\s+NOT\b/i) ||
($agent =~ /\bAND\b\s+\d+=\d+/) ||
($agent =~ /\bTHEN\b.{1,300}?\bELSE\b.{1,300}?\bEND\b/i) ||
($agent =~ /\bAND\b.{1,500}?\bSELECT\b/i) ||
($agent =~ /\sAND\s.{1,500}?\sAND\s/)) {
$self->status(403);
$self->{is_robot} = 1;
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
} else {
$self->_warn("SQL injection attempt blocked for '$agent'");
}
return 1;
}
# is_ai implies is_robot: check AI crawlers before the generic bot regex so
# that UAs like ChatGPT-User or Google-Extended (no "bot"/"spider" token)
# are still caught here.
if($self->is_ai()) {
return $self->{is_robot} = 1;
}
# '.+bot' was replaced with '\bbot\b' — the leading .+ caused catastrophic
# backtracking on long UAs that contain no 'bot' substring.
if($agent =~ /\bbot\b|axios\/1\.6\.7|bidswitchbot|bytespider|ClaudeBot|Clickagy\.Intelligence\.Bot|msnptc|CriteoBot|is_archiver|backstreet|fuzz faster|linkfluence\.com|spider|scoutjet|gingersoftware|heritrix|dodnetdotcom|yandex|nutch|ezooms|plukkie|...
$self->{is_robot} = 1;
return 1;
}
# TODO:
# Download and use list from
# https://raw.githubusercontent.com/mitchellkrogza/apache-ultimate-bad-bot-blocker/refs/heads/master/_generator_lists/bad-user-agents.list
my $key = "$remote/$agent";
# Check the shared cache BEFORE the referrer scan: the 29-domain referrer
# check is the most expensive path in is_robot() and is unnecessary when a
# prior request already classified this remote/agent pair.
# The SQL injection check above MUST remain before this (security gate).
if($self->{cache}) {
if(my $type = $self->{cache}->get($key)) {
return $self->{is_robot} = ($type eq 'robot');
}
}
if(my $referrer = $ENV{'HTTP_REFERER'}) {
# $CRAWLER_REFERER_RE is compiled once at module load (see top of file):
# replaces List::Util::any { /^\Q$_\E/i } @crawler_lists (29 per-call
# regex compilations + array allocation eliminated).
$referrer =~ s/\\/_/g;
if(($referrer =~ /\)/) || ($referrer =~ $CRAWLER_REFERER_RE)) {
$self->_debug("is_robot: blocked trawler $referrer");
if($self->{cache}) {
$self->{cache}->set($key, 'robot', $CACHE_TTL_ROBOT);
}
$self->{is_robot} = 1;
return 1;
}
}
# Don't use HTTP_USER_AGENT to detect more than we really have to since
# that is easily spoofed
if($agent =~ /www\.majestic12\.co\.uk|facebookexternal/) {
# Mark Facebook as a search engine, not a robot
if($self->{cache}) {
$self->{cache}->set($key, 'search', $CACHE_TTL_SEARCH);
}
return 0;
}
unless($self->{browser_detect}) {
if(eval { require HTTP::BrowserDetect; }) {
HTTP::BrowserDetect->import();
$self->{browser_detect} = HTTP::BrowserDetect->new($agent);
}
}
if($self->{browser_detect}) {
my $is_robot = $self->{browser_detect}->robot();
if(defined($is_robot)) {
$self->_debug("HTTP::BrowserDetect '$ENV{HTTP_USER_AGENT}' returns $is_robot");
}
$is_robot = (defined($is_robot) && ($is_robot)) ? 1 : 0;
$self->_debug("is_robot: $is_robot");
if($is_robot) {
if($self->{cache}) {
$self->{cache}->set($key, 'robot', $CACHE_TTL_ROBOT);
}
$self->{is_robot} = $is_robot;
return $is_robot;
}
}
if($self->{cache}) {
$self->{cache}->set($key, 'unknown', $CACHE_TTL_ROBOT);
}
$self->{is_robot} = 0;
return 0;
}
=head2 is_search_engine
Is the visitor a search engine?
if(CGI::Info->new()->is_search_engine()) {
# display generic information about yourself
} else {
# allow the user to pick and choose something to display
}
Can be overridden by the IS_SEARCH_ENGINE environment setting
( run in 1.460 second using v1.01-cache-2.11-cpan-c221a9de4ec )