CGI-Info
view release on metacpan or search on metacpan
lib/CGI/Info.pm view on Meta::CPAN
package CGI::Info;
use warnings;
use strict;
use autodie qw(:all);
use 5.010; # Minimum version for features used here
# Core modules
use boolean;
use Carp;
use Readonly;
use Scalar::Util;
use Socket; # AF_INET constant
# CPAN modules
use Object::Configure 0.19;
use File::Spec;
use Log::Abstraction 0.10;
use Net::CIDR;
use Params::Get 0.13;
use Params::Validate::Strict 0.35;
use Return::Set;
use Sys::Path;
use Sub::Protected;
use namespace::clean;
# ---------------------------------------------------------------------------
# Module-level constants -- avoids magic numbers scattered through the code
# ---------------------------------------------------------------------------
Readonly my $MAX_UPLOAD_SIZE_DEFAULT => 512 * 1024; # 512 KB default upload cap
Readonly my $CACHE_TTL_ROBOT => '1 day'; # TTL for robot-detection cache entries
Readonly my $CACHE_TTL_SEARCH => '1 day'; # TTL for search-engine cache entries
# Compiled once at module-load time: replaces the 29-element @crawler_lists array
# that was re-allocated on every is_robot() call. Building the alternation with
# quotemeta() is equivalent to the former List::Util::any { /^\Q$_\E/i } loop
# but avoids both per-call array construction and per-element regex compilation.
Readonly my $CRAWLER_REFERER_RE => do {
my @domains = (
'http://fix-website-errors.com',
'http://keywords-monitoring-your-success.com',
'http://free-video-tool.com',
'http://magnet-to-torrent.com',
'http://torrent-to-magnet.com',
'http://dogsrun.net',
'http://###.responsive-test.net',
'http://uptime.com',
'http://uptimechecker.com',
'http://top1-seo-service.com',
'http://fast-wordpress-start.com',
'http://wordpress-crew.net',
'http://dbutton.net',
'http://justprofit.xyz',
'http://video--production.com',
'http://buttons-for-website.com',
'http://buttons-for-your-website.com',
'http://success-seo.com',
'http://videos-for-your-business.com',
'http://semaltmedia.com',
'http://dailyrank.net',
'http://uptimebot.net',
'http://sitevaluation.org',
'http://100dollars-seo.com',
'http://forum69.info',
'http://partner.semalt.com',
'http://best-seo-offer.com',
'http://best-seo-solution.com',
'http://semalt.semalt.com',
'http://semalt.com',
'http://7makemoneyonline.com',
'http://anticrawler.org',
'http://baixar-musicas-gratis.com',
'http://descargar-musica-gratis.net',
'http://www.seokicks.de/robot.html',
);
my $alt = join '|', map { quotemeta $_ } @domains;
qr/^(?:$alt)/i;
};
sub _sanitise_input;
=head1 NAME
CGI::Info - Information about the CGI environment
=head1 VERSION
Version 1.14
=cut
our $VERSION = '1.14';
=head1 SYNOPSIS
The C<CGI::Info> module is a Perl library designed to provide information about the environment in which a CGI script operates.
It aims to eliminate hard-coded script details,
enhancing code readability and portability.
Additionally, it offers a simple web application firewall to add a layer of security.
All too often,
Perl programs have information such as the script's name
hard-coded into their source.
Generally speaking,
hard-coding is a bad style since it can make programs difficult to read and reduces readability and portability.
CGI::Info attempts to remove that.
Furthermore, to aid script debugging, CGI::Info attempts to do sensible
things when you're not running the program in a CGI environment.
Whilst you shouldn't rely on it alone to provide security to your website,
it is another layer and every little helps.
use CGI::Info;
my $info = CGI::Info->new(allow => { id => qr/^\d+$/ });
my $params = $info->params();
if($info->is_mobile()) {
print "Mobile view\n";
} else {
print "Desktop view\n";
}
my $id = $info->param('id'); # Validated against allow schema
=head1 SUBROUTINES/METHODS
=head2 new
Creates a CGI::Info object.
It takes four optional arguments: allow, logger, expect and upload_dir,
which are documented in the params() method.
It takes other optional parameters:
=over 4
=item * C<auto_load>
Enable/disable the AUTOLOAD feature.
The default is to have it enabled.
=item * C<config_dirs>
Where to look for C<config_file>
=item * C<config_file>
Points to a configuration file which contains the parameters to C<new()>.
The file can be in any common format,
including C<YAML>, C<XML>, and C<INI>.
This allows the parameters to be set at run time.
On non-Windows system,
the class can be configured using environment variables starting with "CGI::Info::".
For example:
export CGI::Info::max_upload_size=65536
It doesn't work on Windows because of the case-insensitive nature of that system.
If the configuration file has a section called C<CGI::Info>,
only that section,
and the C<global> section,
if any exists,
is used.
=item * C<syslog>
Takes an optional parameter syslog, to log messages to
L<Sys::Syslog>.
It can be a boolean to enable/disable logging to syslog, or a reference
to a hash to be given to Sys::Syslog::setlogsock.
=item * C<cache>
An object that is used to cache IP lookups.
This cache object is an object that understands get() and set() messages,
such as a L<CHI> object.
=item * C<max_upload_size>
The maximum file size in bytes you can upload.
Use C<-1> for no limit.
The default is 512 KB (524288 bytes).
=back
The class can be configured at runtime using environment variables and configuration
files; for example, setting C<$ENV{'CGI__INFO__carp_on_warn'}> causes warnings to
use L<Carp>. For more information see L<Object::Configure>.
=head3 API SPECIFICATION
=head4 INPUT
{
allow => { type => 'hashref', optional => 1 },
auto_load => { type => 'boolean', optional => 1 },
cache => { type => 'object', optional => 1 },
carp_on_warn => { type => 'boolean', optional => 1 },
config_dirs => { type => 'arrayref', optional => 1 },
config_file => { type => 'string', optional => 1 },
logger => { type => 'object', optional => 1 },
max_upload_size=> { type => 'integer', optional => 1, min => -1 },
upload_dir => { type => 'string', optional => 1 },
}
=head4 OUTPUT
{ type => 'object', isa => 'CGI::Info' }
=head3 MESSAGES
=over 4
=item C<< use ->new() not ::new() to instantiate >>
B<Level>: fatal (croak).
B<Cause>: called as C<CGI::Info::new()> (double-colon) instead of C<< CGI::Info->new() >>.
B<Action>: change the call-site to use the arrow notation.
=item C<< Logger must be an object with info() and error() methods >>
B<Level>: fatal (croak).
B<Cause>: the C<logger> argument is not a blessed object, or does not
implement C<info()>, C<warn()>, and C<error()> methods.
B<Action>: pass a compliant logger such as a L<Log::Abstraction>-based object.
=item C<< expect has been deprecated, use allow instead >>
B<Level>: fatal (croak).
B<Cause>: the removed C<expect> parameter was passed to C<new()>.
B<Action>: replace C<expect =E<gt> [...]> with C<allow =E<gt> { key =E<gt> qr/.../ }>.
=back
=cut
our $stdin_data; # Class variable storing STDIN in case the class
# is instantiated more than once
sub new
{
my $class = shift;
# Handle hash or hashref arguments
my $params = Params::Get::get_params(undef, \@_);
if (defined($class)) {
my $is_valid = Scalar::Util::blessed($class) || (eval { $class->isa(__PACKAGE__) });
unless ($is_valid) {
# Called as CGI::Info::new(...) or similar wrong function call
croak(__PACKAGE__, ' use ->new() not ::new() to instantiate');
}
} else {
# If class is undef, but there are arguments/params passed
if (defined($params) && keys %{$params}) {
croak(__PACKAGE__, ' use ->new() not ::new() to instantiate');
}
# Called as CGI::Info::new() with 0 arguments (undef $class)
$class = __PACKAGE__;
}
if(Scalar::Util::blessed($class)) {
# If $class is an object, clone it with new arguments
$params ||= {};
# Validate any new logger passed to the clone
if(defined $params->{'logger'}) {
unless(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn') && $params->{'logger'}->can('info') && $params->{'logger'}->can('error')) {
Carp::croak('Logger must be an object with info() and error() methods');
}
}
# expect is deprecated even when cloning
if(defined($params->{'expect'})) {
my $logger = $params->{'logger'} // $class->{'logger'};
$logger->error(ref($class) . ': expect has been deprecated, use allow instead') if $logger;
Carp::croak(ref($class) . ': expect has been deprecated, use allow instead');
}
# Drop cached params so a new allow schema is applied on next call
my %merged = (%{$class}, %{$params});
delete $merged{'paramref'};
return bless \%merged, ref($class);
}
# Load the configuration from a config file, if provided
$params = Object::Configure::configure($class, $params);
# Validate logger object has required methods
if(defined $params->{'logger'}) {
unless(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn') && $params->{'logger'}->can('info') && $params->{'logger'}->can('error')) {
Carp::croak("Logger must be an object with info() and error() methods");
}
}
if(defined($params->{'expect'})) {
# if(ref($params->{expect}) ne 'ARRAY') {
# Carp::croak(__PACKAGE__, ': expect must be a reference to an array');
# }
# # warn __PACKAGE__, ': expect is deprecated, use allow instead';
if(my $logger = $params->{'logger'}) {
$logger->error("$class: expect has been deprecated, use allow instead");
}
Carp::croak("$class: expect has been deprecated, use allow instead");
}
# Return the blessed object with sensible defaults
return bless {
max_upload_size => $MAX_UPLOAD_SIZE_DEFAULT,
allow => undef,
upload_dir => undef,
%{$params} # Caller-supplied args override the defaults above
}, $class;
}
=head2 script_name
Retrieves the name of the executing CGI script.
This is useful for POSTing,
thus avoiding hard-coded paths into forms.
use CGI::Info;
my $info = CGI::Info->new();
my $script_name = $info->script_name();
# ...
print "<form method=\"POST\" action=$script_name name=\"my_form\">\n";
=head3 API SPECIFICATION
=head4 INPUT
None.
=head4 OUTPUT
{
type => 'string',
'min' => 1,
'nomatch' => qr/^[\/\\]/ # Does not return absolute path
}
=cut
sub script_name
{
my $self = shift;
unless($self->{script_name}) {
$self->_find_paths();
}
return $self->{script_name};
}
sub _find_paths :Protected {
my $self = shift;
$self->_trace(__PACKAGE__ . ': entering _find_paths');
require File::Basename && File::Basename->import() unless File::Basename->can('basename');
# Determine script name
my $script_name = $self->_get_env('SCRIPT_NAME') // $0;
$self->{script_name} = $self->_untaint_filename({
filename => File::Basename::basename($script_name)
});
# Determine script path
if(my $script_path = $self->_get_env('SCRIPT_FILENAME')) {
$self->{script_path} = $script_path;
} elsif($script_name = $self->_get_env('SCRIPT_NAME')) {
lib/CGI/Info.pm view on Meta::CPAN
Can be called as a class method.
=cut
sub domain_name {
my $self = shift;
if(!ref($self)) {
$self = __PACKAGE__->new();
}
return $self->{domain} if $self->{domain};
$self->_find_site_details();
if(my $site = $self->{site}) {
$self->{domain} = ($site =~ /^www\.(.+)/) ? $1 : $site;
}
return $self->{domain};
}
=head2 cgi_host_url
Return the URL of the machine running the CGI script.
=cut
sub cgi_host_url {
my $self = shift;
unless($self->{cgi_site}) {
$self->_find_site_details();
}
return $self->{cgi_site};
}
=head2 params
Returns a reference to a hash list of the CGI arguments.
CGI::Info helps you to test your script before deployment on a website:
if it is not in a CGI environment (e.g., the script is being tested from the
command line), the program's command line arguments (a list of key=value pairs)
are used, if there are no command line arguments,
then they are read from stdin as a list of key=value lines.
Also,
you can give one of --tablet, --search-engine,
--mobile and --robot to mimic those agents. For example:
./script.cgi --mobile name=Nigel
Returns undef if the parameters can't be determined or if none were given.
If an argument is given twice or more, then the values are put in a comma
separated string.
The returned hash value can be passed into L<CGI::Untaint>.
Takes four optional parameters: allow, logger and upload_dir.
The parameters are passed in a hash, or a reference to a hash.
The latter is more efficient since it puts less on the stack.
Allow is a reference to a hash list of CGI parameters that you will allow.
The value for each entry is either a permitted value,
a regular expression of permitted values for
the key,
a code reference,
or a hash of L<Params::Validate::Strict> rules.
Subroutine exceptions propagate normally, allowing custom error handling.
This works alongside existing regex and Params::Validate::Strict patterns.
A undef value means that any value will be allowed.
Arguments not in the list are silently ignored.
This is useful to help to block attacks on your site.
Upload_dir is a string containing a directory where files being uploaded are to
be stored.
It must be a writeable directory in the temporary area.
Takes an optional parameter logger, which is used for warnings and traces.
It can be an object that understands warn() and trace() messages,
such as a L<Log::Log4perl> or L<Log::Any> object,
a reference to code,
a reference to an array,
or a filename.
The allow, logger and upload_dir arguments can also be passed to the
constructor.
use CGI::Info;
use CGI::Untaint;
# ...
my $info = CGI::Info->new();
my %params;
if($info->params()) {
%params = %{$info->params()};
}
# ...
foreach(keys %params) {
print "$_ => $params{$_}\n";
}
my $u = CGI::Untaint->new(%params);
use CGI::Info;
use CGI::IDS;
# ...
my $info = CGI::Info->new();
my $allowed = {
foo => qr/^\d*$/, # foo must be a number, or empty
bar => undef, # bar can be given and be any value
xyzzy => qr/^[\w\s-]+$/, # must be alphanumeric
# to prevent XSS, and non-empty
# as a sanity check
};
# or
$allowed = {
email => { type => 'string', matches => qr/^[^@]+@[^@]+\.[^@]+$/ }, # String, basic email format check
age => { type => 'integer', min => 0, max => 150 }, # Integer between 0 and 150
bio => { type => 'string', optional => 1 }, # String, optional
ip_address => { type => 'string', matches => qr/^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ }, #Basic IPv4 validation
};
my $paramsref = $info->params(allow => $allowed);
if(defined($paramsref)) {
my $ids = CGI::IDS->new();
$ids->set_scan_keys(scan_keys => 1);
if($ids->detect_attacks(request => $paramsref) > 0) {
die 'horribly';
}
}
If the request is an XML request (i.e. the content type of the POST is text/xml),
CGI::Info will put the request into the params element 'XML', thus:
use CGI::Info;
# ...
my $info = CGI::Info->new();
my $paramsref = $info->params(); # See BUGS below
my $xml = $$paramsref{'XML'};
# ... parse and process the XML request in $xml
Carp if logger is not set and we detect something serious.
Blocks some attacks,
such as SQL and XSS injections,
mustleak and directory traversals,
thus creating a primitive web application firewall (WAF).
Warning - this is an extra layer, not a replacement for your other security layers.
=head3 Validation Subroutine Support
The C<allow> parameter accepts subroutine references for dynamic validation,
enabling complex parameter checks beyond static regex patterns.
These callbacks:
=over 4
=item * Receive three arguments: the parameter key, value and the C<CGI::Info> instance
=item * Must return a true value to allow the parameter, false to reject
=item * Can access other parameters through the instance for contextual validation
=back
Basic usage:
CGI::Info->new(
allow => {
# Simple value check
even_number => sub { ($_[1] % 2) == 0 },
# Context-aware validation
child_age => sub {
my ($key, $value, $info) = @_;
$info->param('is_parent') ? $value <= 18 : 0
}
}
);
Advanced features:
# Combine with regex validation
mixed_validation => {
email => qr/@/, # Regex check
promo_code => \&validate_promo_code # Subroutine check
}
# Throw custom exceptions
dangerous_param => sub {
die 'Hacking attempt!' if $_[1] =~ /DROP TABLE/;
return 1;
}
=cut
sub params {
my $self = shift;
my $params = Params::Get::get_params(undef, @_);
if((defined($self->{paramref})) && ((!defined($params->{'allow'})) || defined($self->{allow}) && ($params->{'allow'} eq $self->{allow}))) {
return $self->{paramref};
}
if(defined($params->{allow})) {
$self->{allow} = $params->{allow};
}
if(defined($params->{upload_dir})) {
$self->{upload_dir} = $params->{upload_dir};
}
if(defined($params->{'logger'})) {
$self->set_logger($params->{'logger'});
}
$self->_trace('Entering params');
my @pairs;
my $content_type = $ENV{'CONTENT_TYPE'};
my %FORM;
if((!$ENV{'GATEWAY_INTERFACE'}) || (!$ENV{'REQUEST_METHOD'})) {
# require IO::Interactive;
# IO::Interactive->import();
if(@ARGV) {
@pairs = @ARGV;
if(defined($pairs[0])) {
if($pairs[0] eq '--robot') {
$self->{is_robot} = 1;
shift @pairs;
} elsif($pairs[0] eq '--mobile') {
$self->{is_mobile} = 1;
shift @pairs;
} elsif($pairs[0] eq '--search-engine') {
$self->{is_search_engine} = 1;
shift @pairs;
} elsif($pairs[0] eq '--tablet') {
$self->{is_tablet} = 1;
shift @pairs;
}
}
} elsif($stdin_data) {
# Re-use previously read STDIN (class variable shared across instances)
@pairs = split(/\n/, $stdin_data);
}
} elsif(($ENV{'REQUEST_METHOD'} eq 'GET') || ($ENV{'REQUEST_METHOD'} eq 'HEAD')) {
if(my $query = $ENV{'QUERY_STRING'}) {
if((defined($content_type)) && ($content_type =~ /multipart\/form-data/i)) {
if($ENV{'REMOTE_ADDR'}) {
$self->_warn({ warning => "$ENV{REMOTE_ADDR}: Multipart/form-data not supported for GET (query string = $query)" });
} else {
$self->_warn('Multipart/form-data not supported for GET');
}
$self->status(501); # Not implemented
return;
}
$query =~ s/\\u0026/\&/g;
@pairs = split(/&/, $query);
} else {
return;
}
} elsif($ENV{'REQUEST_METHOD'} eq 'POST') {
my $content_length = $self->_get_env('CONTENT_LENGTH');
if((!defined($content_length)) || ($content_length =~ /\D/)) {
$self->{status} = 411;
return;
}
if(($self->{max_upload_size} >= 0) && ($content_length > $self->{max_upload_size})) { # Set maximum posts
# TODO: Design a way to tell the caller to send HTTP
# status 413
$self->{status} = 413;
$self->_warn('Large upload prohibited');
return;
}
if((!defined($content_type)) || ($content_type =~ /application\/x-www-form-urlencoded/)) {
my $buffer;
if($stdin_data) {
$buffer = $stdin_data;
} else {
if(read(STDIN, $buffer, $content_length) != $content_length) {
$self->_warn('POST failed: something else may have read STDIN');
}
$stdin_data = $buffer;
}
@pairs = split(/&/, $buffer);
# if($ENV{'QUERY_STRING'}) {
# my @getpairs = split(/&/, $ENV{'QUERY_STRING'});
# push(@pairs, @getpairs);
# }
} elsif($content_type =~ /multipart\/form-data/i) {
if(!defined($self->{upload_dir})) {
if($ENV{'REMOTE_ADDR'}) {
# This could be an attack
$self->_warn({ warning => "$ENV{REMOTE_ADDR}: Attempt to upload a file of $content_length bytes when upload_dir has not been set" });
} else {
$self->_warn({ warning => 'Attempt to upload a file when upload_dir has not been set' });
}
$self->status(501); # Not implemented
return;
}
# Validate 'upload_dir'
# Ensure the upload directory is safe and accessible
# - Check permissions
# - Validate path to prevent directory traversal attacks
# TODO: Consider using a temporary directory for uploads and moving them later
if(!File::Spec->file_name_is_absolute($self->{upload_dir})) {
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't a full pathname"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if(!-d $self->{upload_dir}) {
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't a directory"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if(!-w $self->{upload_dir}) {
delete $self->{paramref};
$self->_warn({
warning => "upload_dir $self->{upload_dir} isn't writeable"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
my $tmpdir = $self->tmpdir();
if($self->{'upload_dir'} !~ /^\Q$tmpdir\E/) {
$self->_warn({
warning => 'upload_dir ' . $self->{'upload_dir'} . " isn't somewhere in the temporary area $tmpdir"
});
$self->status(500);
delete $self->{upload_dir};
return;
}
if($content_type =~ /boundary=(\S+)$/) {
@pairs = $self->_multipart_data({
length => $content_length,
boundary => $1
});
}
} elsif($content_type =~ /text\/xml/i) {
my $buffer;
if($stdin_data) {
$buffer = $stdin_data;
} else {
if(read(STDIN, $buffer, $content_length) != $content_length) {
$self->_warn({
warning => 'XML failed: something else may have read STDIN'
});
}
$stdin_data = $buffer;
}
$FORM{XML} = $buffer;
$self->{paramref} = \%FORM;
return \%FORM;
} elsif($content_type =~ /application\/json/i) {
require JSON::MaybeXS && JSON::MaybeXS->import() unless JSON::MaybeXS->can('parse_json');
# require JSON::MaybeXS;
# JSON::MaybeXS->import();
my $buffer;
if($stdin_data) {
$buffer = $stdin_data;
} else {
if(read(STDIN, $buffer, $content_length) != $content_length) {
$self->_warn({
warning => 'read failed: something else may have read STDIN'
});
}
$stdin_data = $buffer;
}
# JSON::Parse::assert_valid_json($buffer);
# my $paramref = JSON::Parse::parse_json($buffer);
my $paramref = decode_json($buffer);
foreach my $key(keys(%{$paramref})) {
push @pairs, "$key=" . $paramref->{$key};
}
} else {
my $buffer;
if($stdin_data) {
$buffer = $stdin_data;
} else {
if(read(STDIN, $buffer, $content_length) != $content_length) {
$self->_warn({
warning => 'read failed: something else may have read STDIN'
});
}
$stdin_data = $buffer;
lib/CGI/Info.pm view on Meta::CPAN
sub _multipart_data :Protected {
my ($self, $args) = @_;
$self->_trace('Entering _multipart_data');
my $total_bytes = $$args{length};
$self->_debug("_multipart_data: total_bytes = $total_bytes");
if($total_bytes == 0) {
return;
}
unless($stdin_data) {
while(<STDIN>) {
chop(my $line = $_);
$line =~ s/[\r\n]//g;
$stdin_data .= "$line\n";
}
if(!$stdin_data) {
return;
}
}
my $boundary = $$args{boundary};
my @pairs;
my $writing_file = 0;
my $key;
my $value;
my $in_header = 0;
my $fout;
foreach my $line(split(/\n/, $stdin_data)) {
if($line =~ /^--\Q$boundary\E--$/) {
last;
}
if($line =~ /^--\Q$boundary\E$/) {
if($writing_file) {
close $fout;
$writing_file = 0;
} elsif(defined($key)) {
push(@pairs, "$key=$value");
$value = undef;
}
$in_header = 1;
} elsif($in_header) {
if(length($line) == 0) {
$in_header = 0;
} elsif($line =~ /^Content-Disposition: (.+)/i) {
my $field = $1;
if($field =~ /name="(.+?)"/) {
$key = $1;
}
# [^"]+ instead of .+ : stops at first '"' without backtracking,
# and cannot accidentally capture across the closing delimiter.
if($field =~ /filename="([^"]+)?"/) {
my $filename = $1;
unless(defined($filename)) {
$self->_warn('No upload filename given');
} elsif($filename =~ /[\\\/\|]/) {
$self->_warn("Disallowing invalid filename: $filename");
} else {
$filename = $self->_create_file_name({
filename => $filename
});
# Don't do this since it taints the string and I can't work out how to untaint it
# my $full_path = Cwd::realpath(File::Spec->catfile($self->{upload_dir}, $filename));
# $full_path =~ m/^(\/[\w\.]+)$/;
my $full_path = File::Spec->catfile($self->{upload_dir}, $filename);
unless(open($fout, '>', $full_path)) {
$self->_warn("Can't open $full_path");
}
$writing_file = 1;
push(@pairs, "$key=$filename");
}
}
}
# TODO: handle Content-Type: text/plain, etc.
} else {
if($writing_file) {
print $fout "$line\n";
} else {
$value .= $line;
}
}
}
if($writing_file) {
close $fout;
}
$self->_trace('Leaving _multipart_data');
return @pairs;
}
# Robust filename generation (preventing overwriting).
# Previously used "! -e $rc" which checked existence in the CURRENT WORKING
# DIRECTORY, not the upload directory — a logic bug and a TOCTOU race.
# Now checks in the actual upload directory and caps iterations to avoid
# an infinite loop if the directory fills up.
sub _create_file_name :Protected {
my ($self, $args) = @_;
my $upload_dir = $self->{upload_dir};
my $filename = $$args{filename} . '_' . time;
my $counter = 0;
my $rc;
do {
$rc = $filename . ($counter ? "_$counter" : '');
$counter++;
# Check in upload_dir when set; otherwise check relative to CWD.
# File::Spec->catfile('', ...) produces an absolute path, so we
# must not pass an empty string as the directory component.
} until(
! -e ($upload_dir ? File::Spec->catfile($upload_dir, $rc) : $rc)
|| $counter > 1000
);
if($counter > 1000) {
Carp::croak('_create_file_name: unable to find a unique filename after 1000 attempts');
}
return $rc;
}
# Untaint a filename. Regex from CGI::Untaint::Filenames
sub _untaint_filename :Protected {
my ($self, $args) = @_;
if($$args{filename} =~ /(^[\w\+_\040\#\(\)\{\}\[\]\/\-\^,\.:;&%@\\~]+\$?$)/) {
return $1;
}
return;
}
=head2 is_mobile
Returns a boolean if the website is being viewed on a mobile
device such as a smartphone.
All tablets are mobile, but not all mobile devices are tablets.
Can be overridden by the IS_MOBILE environment setting
=cut
sub is_mobile {
my $self = shift;
if(defined($self->{is_mobile})) {
return $self->{is_mobile};
}
if($ENV{'IS_MOBILE'}) {
return $ENV{'IS_MOBILE'}
}
# Support Sec-CH-UA-Mobile
if(my $ch_ua_mobile = $ENV{'HTTP_SEC_CH_UA_MOBILE'}) {
if($ch_ua_mobile eq '?1') {
$self->{is_mobile} = 1;
return 1;
}
}
if($ENV{'HTTP_X_WAP_PROFILE'}) {
# E.g. Blackberry
# TODO: Check the sanity of this variable
$self->{is_mobile} = 1;
return 1;
}
if(my $agent = $ENV{'HTTP_USER_AGENT'}) {
# Was '.+(Android|iPhone).+' — .+ before and after adds no useful
# constraint but causes ReDoS on long UAs without those tokens.
if($agent =~ /\b(?:Android|iPhone)\b/) {
$self->{is_mobile} = 1;
lib/CGI/Info.pm view on Meta::CPAN
=item * L<HTTP::BrowserDetect>
=item * L<https://github.com/mitchellkrogza/apache-ultimate-bad-bot-blocker>
=back
=head1 REPOSITORY
L<https://github.com/nigelhorne/CGI-Info>
=head1 SUPPORT
This module is provided as-is without any warranty.
Please report any bugs or feature requests to C<bug-cgi-info at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Info>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
You can find documentation for this module with the perldoc command.
perldoc CGI::Info
You can also look for information at:
=over 4
=item * MetaCPAN
L<https://metacpan.org/dist/CGI-Info>
=item * RT: CPAN's request tracker
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Info>
=item * CPAN Testers' Matrix
L<http://matrix.cpantesters.org/?dist=CGI-Info>
=item * CPAN Testers Dependencies
L<http://deps.cpantesters.org/?module=CGI::Info>
=back
=encoding utf-8
=head2 FORMAL SPECIFICATION
=head3 new
-- CGI::Info construction
new : ClassName x Params --> CGIInfo
-- Normal (non-clone) path
new(class, params) ^=
let configured == Object::Configure::configure(class, params)
in CGIInfo {
max_upload_size |-> configured.max_upload_size ?? MAX_UPLOAD_SIZE_DEFAULT,
allow |-> configured.allow ?? null,
upload_dir |-> configured.upload_dir ?? null,
...configured
}
-- Pre-conditions
pre new(class, params) ^=
params.logger = null
v (blessed(params.logger)
^ params.logger.can('warn')
^ params.logger.can('info')
^ params.logger.can('error'))
^ params.expect = null
-- Clone path (invocant is an existing object)
clone : CGIInfo x Params --> CGIInfo
clone(self, params) ^=
let merged == (self (+) params) \ {paramref}
in CGIInfo { ...merged }
=head3 param
Let F be the set of all possible CGI field names, V be the set of all
possible (sanitised) scalar values, and allow : F -> Regex | undef be the
current allow-list schema (undef means all fields are permitted).
param : F? -> V | HashRef | undef
param() = params()
param(f) =
f not in dom(allow) /\ allow /= undef => warn; undef
f in params() => params()(f)
otherwise => undef
Safety invariant: for all f, param(f) /= undef => f in dom(allow) \/ allow = undef.
=head2 is_ai
-- is_ai ---------------------------------------------------------
-- Given CGIInfo state i, returns a boolean result.
--
-- AI_PAT is the set of known AI crawler token strings.
--
-- ENV denotes the process environment (a partial function from
-- name to value).
--
AI_PAT == {ClaudeBot, Claude-Web, anthropic-ai, GPTBot,
ChatGPT-User, OAI-SearchBot, Google-Extended,
meta-externalagent, FacebookBot, Applebot-Extended,
PerplexityBot, Amazonbot, YouBot, Diffbot,
cohere-ai, CCBot, Bytespider, AI2Bot, TimpiBot}
is_ai ≜ λ i : CGIInfo •
-- Environment override takes absolute priority
IS_AI ∈ dom ENV ⟹
(ENV IS_AI ≠'0' ∧ ENV IS_AI ≠'')
-- Without both IP and UA we cannot classify
∧ IS_AI ∉ dom ENV ∧
(REMOTE_ADDR ∉ dom ENV ∨ HTTP_USER_AGENT ∉ dom ENV)
⟹ false
( run in 0.778 second using v1.01-cache-2.11-cpan-b16cb0d3907 )