lib/CGI/Info.pm

Index
Structural Coverage (Approximate)

Statement: 87.57%
Branch: 76.33%
Approximate LCSAJ segments: 491

LCSAJ Legend

● Marks the start of an executed LCSAJ (Linear Code Sequence And Jump).

Multiple dots on a line indicate that multiple control-flow paths begin at that line.

Hovering over a dot shows: 

					start → end → jump

These markers help visualize which execution paths were exercised during testing.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package CGI::Info;
    2: 
    3: # TODO: remove the expect argument
    4: # TODO:	look into params::check or params::validate
    5: 
    6: use warnings;
    7: use strict;
    8: 
    9: use boolean;
   10: use Carp;
   11: use Object::Configure 0.19;
   12: use File::Spec;
   13: use Log::Abstraction 0.10;
   14: use Params::Get 0.13;
   15: use Params::Validate::Strict 0.21;
   16: use Net::CIDR;
   17: use Return::Set;
   18: use Scalar::Util;
   19: use Socket;	# For AF_INET
   20: use 5.008;
   21: # use Cwd;
   22: # use JSON::Parse;
   23: use List::Util ();	# Can go when expect goes
   24: # use Sub::Private;
   25: use Sys::Path;
   26: 
   27: use namespace::clean;
   28: 
   29: sub _sanitise_input($);
   30: 
   31: =head1 NAME
   32: 
   33: CGI::Info - Information about the CGI environment
   34: 
   35: =head1 VERSION
   36: 
   37: Version 1.11
   38: 
   39: =cut
   40: 
   41: our $VERSION = '1.11';
   42: 
   43: =head1 SYNOPSIS
   44: 
   45: The C<CGI::Info> module is a Perl library designed to provide information about the environment in which a CGI script operates.
   46: It aims to eliminate hard-coded script details,
   47: enhancing code readability and portability.
   48: Additionally, it offers a simple web application firewall to add a layer of security.
   49: 
   50: All too often,
   51: Perl programs have information such as the script's name
   52: hard-coded into their source.
   53: Generally speaking,
   54: hard-coding is a bad style since it can make programs difficult to read and reduces readability and portability.
   55: CGI::Info attempts to remove that.
   56: 
   57: Furthermore, to aid script debugging, CGI::Info attempts to do sensible
   58: things when you're not running the program in a CGI environment.
   59: 
   60: Whilst you shouldn't rely on it alone to provide security to your website,
   61: it is another layer and every little helps.
   62: 
   63:     use CGI::Info;
   64: 
   65:     my $info = CGI::Info->new(allow => { id => qr/^\d+$/ });
   66:     my $params = $info->params();
   67: 
   68:     if($info->is_mobile()) {
   69:         print "Mobile view\n";
   70:     } else {
   71:         print "Desktop view\n";
   72:     }
   73: 
   74:     my $id = $info->param('id');	# Validated against allow schema
   75: 
   76: =head1 SUBROUTINES/METHODS
   77: 
   78: =head2 new
   79: 
   80: Creates a CGI::Info object.
   81: 
   82: It takes four optional arguments: allow, logger, expect and upload_dir,
   83: which are documented in the params() method.
   84: 
   85: It takes other optional parameters:
   86: 
   87: =over 4
   88: 
   89: =item * C<auto_load>
   90: 
   91: Enable/disable the AUTOLOAD feature.
   92: The default is to have it enabled.
   93: 
   94: =item * C<config_dirs>
   95: 
   96: Where to look for C<config_file>
   97: 
   98: =item * C<config_file>
   99: 
  100: Points to a configuration file which contains the parameters to C<new()>.
  101: The file can be in any common format,
  102: including C<YAML>, C<XML>, and C<INI>.
  103: This allows the parameters to be set at run time.
  104: 
  105: On non-Windows system,
  106: the class can be configured using environment variables starting with "CGI::Info::".
  107: For example:
  108: 
  109:   export CGI::Info::max_upload_size=65536
  110: 
  111: It doesn't work on Windows because of the case-insensitive nature of that system.
  112: 
  113: If the configuration file has a section called C<CGI::Info>,
  114: only that section,
  115: and the C<global> section,
  116: if any exists,
  117: is used.
  118: 
  119: =item * C<syslog>
  120: 
  121: Takes an optional parameter syslog, to log messages to
  122: L<Sys::Syslog>.
  123: It can be a boolean to enable/disable logging to syslog, or a reference
  124: to a hash to be given to Sys::Syslog::setlogsock.
  125: 
  126: =item * C<cache>
  127: 
  128: An object that is used to cache IP lookups.
  129: This cache object is an object that understands get() and set() messages,
  130: such as a L<CHI> object.
  131: 
  132: =item * C<max_upload_size>
  133: 
  134: The maximum file size you can upload (-1 for no limit), the default is 512MB.
  135: 
  136: =back
  137: 
  138: The class can be configured at runtime using environments and configuration files,
  139: for example,
  140: setting C<$ENV{'CGI__INFO__carp_on_warn'}> causes warnings to use L<Carp>.
  141: For more information about configuring object constructors at runtime,
  142: see L<Object::Configure>.
  143: 
  144: =cut
  145: 
  146: our $stdin_data;	# Class variable storing STDIN in case the class
  147: 			# is instantiated more than once
  148: 
  149: sub new
  150: {
●151 → 156 → 170●151 → 156 → 0  151: 	my $class = shift;
  152: 
  153: 	# Handle hash or hashref arguments
  154: 	my $params = Params::Get::get_params(undef, @_) || {};
  155: 
  156: 	if(!defined($class)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  157: 		if((scalar keys %{$params}) > 0) {

					

					Mutants (Total: 5, Killed: 1, Survived: 4)
					

  158: 			# Using CGI::Info:new(), not CGI::Info->new()
  159: 			croak(__PACKAGE__, ' use ->new() not ::new() to instantiate');
  160: 		}
  161: 
  162: 		# FIXME: this only works when no arguments are given
  163: 		$class = __PACKAGE__;
  164: 	} elsif(Scalar::Util::blessed($class)) {
  165: 		# If $class is an object, clone it with new arguments
  166: 		return bless { %{$class}, %{$params} }, ref($class);
  167: 	}
  168: 
  169: 	# Load the configuration from a config file, if provided
●170 → 173 → 179●170 → 173 → 0●170 → 173 → 179●170 → 173 → 0  170: 	$params = Object::Configure::configure($class, $params);
  171: 
  172: 	# Validate logger object has required methods
  173: 	if(defined $params->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  174: 		unless(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn') && $params->{'logger'}->can('info') && $params->{'logger'}->can('error')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  175: 			Carp::croak("Logger must be an object with info() and error() methods");
  176: 		}
  177: 	}
  178: 
●179 → 179 → 191●179 → 179 → 0●179 → 179 → 191●179 → 179 → 0  179: 	if(defined($params->{'expect'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  180: 		# if(ref($params->{expect}) ne 'ARRAY') {
  181: 			# Carp::croak(__PACKAGE__, ': expect must be a reference to an array');
  182: 		# }
  183: 		# # warn __PACKAGE__, ': expect is deprecated, use allow instead';
  184: 		if(my $logger = $params->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  185: 			$logger->error("$class: expect has been deprecated, use allow instead");
  186: 		}
  187: 		Carp::croak("$class: expect has been deprecated, use allow instead");
  188: 	}
  189: 
  190: 	# Return the blessed object
●191 → 191 → 0●191 → 191 → 0  191: 	return bless {
  192: 		max_upload_size => 512 * 1024,
  193: 		allow => undef,
  194: 		upload_dir => undef,
  195: 		%{$params}	# Overwrite defaults with given arguments
  196: 	}, $class;
  197: }
  198: 
  199: =head2 script_name
  200: 
  201: Retrieves the name of the executing CGI script.
  202: This is useful for POSTing,
  203: thus avoiding hard-coded paths into forms.
  204: 
  205: 	use CGI::Info;
  206: 
  207: 	my $info = CGI::Info->new();
  208: 	my $script_name = $info->script_name();
  209: 	# ...
  210: 	print "<form method=\"POST\" action=$script_name name=\"my_form\">\n";
  211: 
  212: =head3 API SPECIFICATION
  213: 
  214: =head4 INPUT
  215: 
  216: None.
  217: 
  218: =head4 OUTPUT
  219: 
  220:   {
  221:     type => 'string',
  222:     'min' => 1,
  223:     'nomatch' => qr/^[\/\\]/	# Does not return absolute path
  224:   }
  225: 
  226: =cut
  227: 
  228: sub script_name
  229: {
●230 → 232 → 235●230 → 232 → 0  230: 	my $self = shift;
  231: 
  232: 	unless($self->{script_name}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  233: 		$self->_find_paths();
  234: 	}
●235 → 235 → 0●235 → 235 → 0  235: 	return $self->{script_name};
  236: }
  237: 
  238: sub _find_paths {
●239 → 241 → 245●239 → 241 → 0  239: 	my $self = shift;
  240: 
  241: 	if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  242: 		Carp::croak('Illegal Operation: This method can only be called by a subclass or ourself');
  243: 	}
  244: 
●245 → 256 → 289●245 → 256 → 0●245 → 256 → 289●245 → 256 → 0  245: 	$self->_trace(__PACKAGE__ . ': entering _find_paths');
  246: 
  247: 	require File::Basename && File::Basename->import() unless File::Basename->can('basename');
  248: 
  249: 	# Determine script name
  250: 	my $script_name = $self->_get_env('SCRIPT_NAME') // $0;
  251: 	$self->{script_name} = $self->_untaint_filename({
  252: 		filename => File::Basename::basename($script_name)
  253: 	});
  254: 
  255: 	# Determine script path
  256: 	if(my $script_path = $self->_get_env('SCRIPT_FILENAME')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  257: 		$self->{script_path} = $script_path;
  258: 	} elsif($script_name = $self->_get_env('SCRIPT_NAME')) {
  259: 		if(my $document_root = $self->_get_env('DOCUMENT_ROOT')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  260: 			$script_name = $self->_get_env('SCRIPT_NAME');
  261: 
  262: 			# It's usually the case, e.g. /cgi-bin/foo.pl
  263: 			$script_name =~ s{^/}{};
  264: 
  265: 			$self->{script_path} = File::Spec->catfile($document_root, $script_name);
  266: 		} else {
  267: 			if(File::Spec->file_name_is_absolute($script_name) && (-r $script_name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  268: 				# Called from a command line with a full path
  269: 				$self->{script_path} = $script_name;
  270: 			} else {
  271: 				require Cwd unless Cwd->can('abs_path');
  272: 
  273: 				if($script_name =~ /^\/(.+)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  274: 					# It's usually the case, e.g. /cgi-bin/foo.pl
  275: 					$script_name = $1;
  276: 				}
  277: 
  278: 				$self->{script_path} = File::Spec->catfile(Cwd::abs_path(), $script_name);
  279: 			}
  280: 		}
  281: 	} elsif(File::Spec->file_name_is_absolute($0)) {
  282: 		# Called from a command line with a full path
  283: 		$self->{script_path} = $0;
  284: 	} else {
  285: 		$self->{script_path} = File::Spec->rel2abs($0);
  286: 	}
  287: 
  288: 	# Untaint and finalize script path
●289 → 289 → 0●289 → 289 → 0  289: 	$self->{script_path} = $self->_untaint_filename({
  290: 		filename => $self->{script_path}
  291: 	});
  292: }
  293: 
  294: =head2 script_path
  295: 
  296: Finds the full path name of the script.
  297: 
  298: 	use CGI::Info;
  299: 
  300: 	my $info = CGI::Info->new();
  301: 	my $fullname = $info->script_path();
  302: 	my @statb = stat($fullname);
  303: 
  304: 	if(@statb) {
  305: 		my $mtime = localtime $statb[9];
  306: 		print "Last-Modified: $mtime\n";
  307: 		# TODO: only for HTTP/1.1 connections
  308: 		# $etag = Digest::MD5::md5_hex($html);
  309: 		printf "ETag: \"%x\"\n", $statb[9];
  310: 	}
  311: =cut
  312: 
  313: sub script_path {
●314 → 316 → 319●314 → 316 → 0  314: 	my $self = shift;
  315: 
  316: 	unless($self->{script_path}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  317: 		$self->_find_paths();
  318: 	}
●319 → 319 → 0●319 → 319 → 0  319: 	return $self->{script_path};
  320: }
  321: 
  322: =head2 script_dir
  323: 
  324: Returns the file system directory containing the script.
  325: 
  326: 	use CGI::Info;
  327: 	use File::Spec;
  328: 
  329: 	my $info = CGI::Info->new();
  330: 
  331: 	print 'HTML files are normally stored in ', $info->script_dir(), '/', File::Spec->updir(), "\n";
  332: 
  333: 	# or
  334: 	use lib CGI::Info::script_dir() . '../lib';
  335: 
  336: =cut
  337: 
  338: sub script_dir
  339: {
  340: 	my $self = shift;
  341: 
  342: 	# Ensure $self is an object
  343: 	$self = __PACKAGE__->new() unless ref $self;
  344: 
  345: 	# Set script path if it is not already defined
  346: 	$self->_find_paths() unless $self->{script_path};
  347: 
  348: 	# Extract directory from script path based on OS
  349: 	# Don't use File::Spec->splitpath() since that can leave the trailing slash
  350: 	my $dir_regex = $^O eq 'MSWin32' ? qr{(.+)\\.+?$} : qr{(.+)/.+?$};
  351: 
  352: 	return $self->{script_path} =~ $dir_regex ? $1 : $self->{script_path};
  353: }
  354: 
  355: =head2 host_name
  356: 
  357: Return the host-name of the current web server, according to CGI.
  358: If the name can't be determined from the web server, the system's host-name
  359: is used as a fall back.
  360: This may not be the same as the machine that the CGI script is running on,
  361: some ISPs and other sites run scripts on different machines from those
  362: delivering static content.
  363: There is a good chance that this will be domain_name() prepended with either
  364: 'www' or 'cgi'.
  365: 
  366: 	use CGI::Info;
  367: 
  368: 	my $info = CGI::Info->new();
  369: 	my $host_name = $info->host_name();
  370: 	my $protocol = $info->protocol();
  371: 	# ...
  372: 	print "Thank you for visiting our <A HREF=\"$protocol://$host_name\">Website!</A>";
  373: 
  374: =cut
  375: 
  376: sub host_name {
●377 → 379 → 383●377 → 379 → 0  377: 	my $self = shift;
  378: 
  379: 	unless($self->{site}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  380: 		$self->_find_site_details();
  381: 	}
  382: 
●383 → 383 → 0●383 → 383 → 0  383: 	return $self->{site};
  384: }
  385: 
  386: sub _find_site_details
  387: {
●388 → 396 → 417●388 → 396 → 0  388: 	my $self = shift;
  389: 
  390: 	# Log entry to the routine
  391: 	$self->_trace('Entering _find_site_details');
  392: 
  393: 	return if $self->{site} && $self->{cgi_site};
  394: 
  395: 	# Determine cgi_site using environment variables or hostname
  396: 	if (my $host = ($ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} || $ENV{'SSL_TLS_SNI'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  397: 		# Import necessary module
  398: 			require URI::Heuristic unless URI::Heuristic->can('uf_uristr');
  399: 
  400: 		$self->{cgi_site} = URI::Heuristic::uf_uristr($host);
  401: 		# Remove trailing dots from the name.  They are legal in URLs
  402: 		# and some sites link using them to avoid spoofing (nice)
  403: 		$self->{cgi_site} =~ s/(.*)\.+$/$1/;  # Trim trailing dots
  404: 
  405: 		if($ENV{'SERVER_NAME'} && ($host eq $ENV{'SERVER_NAME'}) && (my $protocol = $self->protocol()) && $self->protocol() ne 'http') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  406: 			$self->{cgi_site} =~ s/^http/$protocol/;
  407: 		}
  408: 	} else {
  409: 		# Import necessary module
  410: 		require Sys::Hostname unless Sys::Hostname->can('hostname');
  411: 
  412: 		$self->_debug('Falling back to using hostname');
  413: 		$self->{cgi_site} = Sys::Hostname::hostname();
  414: 	}
  415: 
  416: 	# Set site details if not already defined
●417 → 426 → 0●417 → 426 → 0  417: 	$self->{site} ||= $self->{cgi_site};
  418: 	$self->{site} =~ s/^https?:\/\/(.+)/$1/;
  419: 	$self->{cgi_site} = ($self->protocol() || 'http') . '://' . $self->{cgi_site}
  420: 		unless $self->{cgi_site} =~ /^https?:\/\//;
  421: 
  422: 	# Warn if site details could not be determined
  423: 	$self->_warn('Could not determine site name') unless($self->{site} && $self->{cgi_site});
  424: 
  425: 	# Log exit
  426: 	$self->_trace('Leaving _find_site_details');
  427: }
  428: 
  429: =head2 domain_name
  430: 
  431: Domain_name is the name of the controlling domain for this website.
  432: Usually it will be similar to host_name, but will lack the http:// or www prefixes.
  433: 
  434: Can be called as a class method.
  435: 
  436: =cut
  437: 
  438: sub domain_name {
●439 → 441 → 444●439 → 441 → 0  439: 	my $self = shift;
  440: 
  441: 	if(!ref($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  442: 		$self = __PACKAGE__->new();
  443: 	}
●444 → 448 → 452●444 → 448 → 0●444 → 448 → 452●444 → 448 → 0  444: 	return $self->{domain} if $self->{domain};
  445: 
  446: 	$self->_find_site_details();
  447: 
  448: 	if(my $site = $self->{site}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  449: 		$self->{domain} = ($site =~ /^www\.(.+)/) ? $1 : $site;
  450: 	}
  451: 
●452 → 452 → 0●452 → 452 → 0  452: 	return $self->{domain};
  453: }
  454: 
  455: =head2 cgi_host_url
  456: 
  457: Return the URL of the machine running the CGI script.
  458: 
  459: =cut
  460: 
  461: sub cgi_host_url {
●462 → 464 → 468●462 → 464 → 0  462: 	my $self = shift;
  463: 
  464: 	unless($self->{cgi_site}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  465: 		$self->_find_site_details();
  466: 	}
  467: 
●468 → 468 → 0●468 → 468 → 0  468: 	return $self->{cgi_site};
  469: }
  470: 
  471: =head2 params
  472: 
  473: Returns a reference to a hash list of the CGI arguments.
  474: 
  475: CGI::Info helps you to test your script before deployment on a website:
  476: if it is not in a CGI environment (e.g., the script is being tested from the
  477: command line), the program's command line arguments (a list of key=value pairs)
  478: are used, if there are no command line arguments,
  479: then they are read from stdin as a list of key=value lines.
  480: Also,
  481: you can give one of --tablet, --search-engine,
  482: --mobile and --robot to mimic those agents. For example:
  483: 
  484: 	./script.cgi --mobile name=Nigel
  485: 
  486: Returns undef if the parameters can't be determined or if none were given.
  487: 
  488: If an argument is given twice or more, then the values are put in a comma
  489: separated string.
  490: 
  491: The returned hash value can be passed into L<CGI::Untaint>.
  492: 
  493: Takes four optional parameters: allow, logger and upload_dir.
  494: The parameters are passed in a hash, or a reference to a hash.
  495: The latter is more efficient since it puts less on the stack.
  496: 
  497: Allow is a reference to a hash list of CGI parameters that you will allow.
  498: The value for each entry is either a permitted value,
  499: a regular expression of permitted values for
  500: the key,
  501: a code reference,
  502: or a hash of L<Params::Validate::Strict> rules.
  503: Subroutine exceptions propagate normally, allowing custom error handling.
  504: This works alongside existing regex and Params::Validate::Strict patterns.
  505: A undef value means that any value will be allowed.
  506: Arguments not in the list are silently ignored.
  507: This is useful to help to block attacks on your site.
  508: 
  509: Upload_dir is a string containing a directory where files being uploaded are to
  510: be stored.
  511: It must be a writeable directory in the temporary area.
  512: 
  513: Takes an optional parameter logger, which is used for warnings and traces.
  514: It can be an object that understands warn() and trace() messages,
  515: such as a L<Log::Log4perl> or L<Log::Any> object,
  516: a reference to code,
  517: a reference to an array,
  518: or a filename.
  519: 
  520: The allow, logger and upload_dir arguments can also be passed to the
  521: constructor.
  522: 
  523: 	use CGI::Info;
  524: 	use CGI::Untaint;
  525: 	# ...
  526: 	my $info = CGI::Info->new();
  527: 	my %params;
  528: 	if($info->params()) {
  529: 		%params = %{$info->params()};
  530: 	}
  531: 	# ...
  532: 	foreach(keys %params) {
  533: 		print "$_ => $params{$_}\n";
  534: 	}
  535: 	my $u = CGI::Untaint->new(%params);
  536: 
  537: 	use CGI::Info;
  538: 	use CGI::IDS;
  539: 	# ...
  540: 	my $info = CGI::Info->new();
  541: 	my $allowed = {
  542: 		foo => qr/^\d*$/,	# foo must be a number, or empty
  543: 		bar => undef,		# bar can be given and be any value
  544: 		xyzzy => qr/^[\w\s-]+$/,	# must be alphanumeric
  545: 						# to prevent XSS, and non-empty
  546: 						# as a sanity check
  547: 	};
  548: 	# or
  549: 	$allowed = {
  550: 		email => { type => 'string', matches => qr/^[^@]+@[^@]+\.[^@]+$/ }, # String, basic email format check
  551: 		age => { type => 'integer', min => 0, max => 150 }, # Integer between 0 and 150
  552: 		bio => { type => 'string', optional => 1 }, # String, optional
  553: 		ip_address => { type => 'string', matches => qr/^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ }, #Basic IPv4 validation
  554: 	};
  555: 	my $paramsref = $info->params(allow => $allowed);
  556: 	if(defined($paramsref)) {
  557: 		my $ids = CGI::IDS->new();
  558: 		$ids->set_scan_keys(scan_keys => 1);
  559: 		if($ids->detect_attacks(request => $paramsref) > 0) {
  560: 			die 'horribly';
  561: 		}
  562: 	}
  563: 
  564: If the request is an XML request (i.e. the content type of the POST is text/xml),
  565: CGI::Info will put the request into the params element 'XML', thus:
  566: 
  567: 	use CGI::Info;
  568: 	# ...
  569: 	my $info = CGI::Info->new();
  570: 	my $paramsref = $info->params();	# See BUGS below
  571: 	my $xml = $$paramsref{'XML'};
  572: 	# ... parse and process the XML request in $xml
  573: 
  574: Carp if logger is not set and we detect something serious.
  575: 
  576: Blocks some attacks,
  577: such as SQL and XSS injections,
  578: mustleak and directory traversals,
  579: thus creating a primitive web application firewall (WAF).
  580: Warning - this is an extra layer, not a replacement for your other security layers.
  581: 
  582: =head3 Validation Subroutine Support
  583: 
  584: The C<allow> parameter accepts subroutine references for dynamic validation,
  585: enabling complex parameter checks beyond static regex patterns.
  586: These callbacks:
  587: 
  588: =over 4
  589: 
  590: =item * Receive three arguments: the parameter key, value and the C<CGI::Info> instance
  591: 
  592: =item * Must return a true value to allow the parameter, false to reject
  593: 
  594: =item * Can access other parameters through the instance for contextual validation
  595: 
  596: =back
  597: 
  598: Basic usage:
  599: 
  600:     CGI::Info->new(
  601:         allow => {
  602:             # Simple value check
  603:             even_number => sub { ($_[1] % 2) == 0 },
  604: 
  605:             # Context-aware validation
  606:             child_age => sub {
  607:                 my ($key, $value, $info) = @_;
  608:                 $info->param('is_parent') ? $value <= 18 : 0
  609:             }
  610:         }
  611:     );
  612: 
  613: Advanced features:
  614: 
  615:     # Combine with regex validation
  616:     mixed_validation => {
  617:         email => qr/@/,  # Regex check
  618:         promo_code => \&validate_promo_code  # Subroutine check
  619:     }
  620: 
  621:     # Throw custom exceptions
  622:     dangerous_param => sub {
  623:         die 'Hacking attempt!' if $_[1] =~ /DROP TABLE/;
  624:         return 1;
  625:     }
  626: =cut
  627: 
  628: sub params {
●629 → 633 → 637●629 → 633 → 0  629: 	my $self = shift;
  630: 
  631: 	my $params = Params::Get::get_params(undef, @_);
  632: 
  633: 	if((defined($self->{paramref})) && ((!defined($params->{'allow'})) || defined($self->{allow}) && ($params->{'allow'} eq $self->{allow}))) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  634: 		return $self->{paramref};
  635: 	}
  636: 
●637 → 637 → 648●637 → 637 → 0●637 → 637 → 648●637 → 637 → 0  637: 	if(defined($params->{allow})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  638: 		$self->{allow} = $params->{allow};
  639: 	}
  640: 	# if(defined($params->{expect})) {
  641: 		# if(ref($params->{expect}) eq 'ARRAY') {
  642: 			# $self->{expect} = $params->{expect};
  643: 			# $self->_warn('expect is deprecated, use allow instead');
  644: 		# } else {
  645: 			# $self->_warn('expect must be a reference to an array');
  646: 		# }
  647: 	# }
●648 → 648 → 651●648 → 648 → 0●648 → 648 → 651●648 → 648 → 0  648: 	if(defined($params->{upload_dir})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  649: 		$self->{upload_dir} = $params->{upload_dir};
  650: 	}
●651 → 651 → 654●651 → 651 → 0●651 → 651 → 654●651 → 651 → 0  651: 	if(defined($params->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  652: 		$self->set_logger($params->{'logger'});
  653: 	}
●654 → 660 → 878●654 → 660 → 0●654 → 660 → 878●654 → 660 → 0  654: 	$self->_trace('Entering params');
  655: 
  656: 	my @pairs;
  657: 	my $content_type = $ENV{'CONTENT_TYPE'};
  658: 	my %FORM;
  659: 
  660: 	if((!$ENV{'GATEWAY_INTERFACE'}) || (!$ENV{'REQUEST_METHOD'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  661: 		# require IO::Interactive;
  662: 		# IO::Interactive->import();
  663: 
  664: 		if(@ARGV) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  665: 			@pairs = @ARGV;
  666: 			if(defined($pairs[0])) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  667: 				if($pairs[0] eq '--robot') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  668: 					$self->{is_robot} = 1;
  669: 					shift @pairs;
  670: 				} elsif($pairs[0] eq '--mobile') {
  671: 					$self->{is_mobile} = 1;
  672: 					shift @pairs;
  673: 				} elsif($pairs[0] eq '--search-engine') {
  674: 					$self->{is_search_engine} = 1;
  675: 					shift @pairs;
  676: 				} elsif($pairs[0] eq '--tablet') {
  677: 					$self->{is_tablet} = 1;
  678: 					shift @pairs;
  679: 				}
  680: 			}
  681: 		} elsif($stdin_data) {
  682: 			@pairs = split(/\n/, $stdin_data);
  683: 		# } elsif(IO::Interactive::is_interactive() && !$self->{args_read}) {
  684: 		} elsif(0) {
  685: 			# TODO:  Do I really need this anymore?
  686: 			my $oldfh = select(STDOUT);
  687: 			print "Entering debug mode\n",
  688: 				"Enter key=value pairs - end with quit\n";
  689: 			select($oldfh);
  690: 
  691: 			# Avoid prompting for the arguments more than once
  692: 			# if just 'quit' is entered
  693: 			$self->{args_read} = 1;
  694: 
  695: 			while(<STDIN>) {
  696: 				chop(my $line = $_);
  697: 				$line =~ s/[\r\n]//g;
  698: 				last if $line eq 'quit';
  699: 				push(@pairs, $line);
  700: 				$stdin_data .= "$line\n";
  701: 			}
  702: 		}
  703: 	} elsif(($ENV{'REQUEST_METHOD'} eq 'GET') || ($ENV{'REQUEST_METHOD'} eq 'HEAD')) {
  704: 		if(my $query = $ENV{'QUERY_STRING'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  705: 			if((defined($content_type)) && ($content_type =~ /multipart\/form-data/i)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  706: 				if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  707: 					$self->_warn({ warning => "$ENV{REMOTE_ADDR}: Multipart/form-data not supported for GET" });
  708: 				} else {
  709: 					$self->_warn('Multipart/form-data not supported for GET');
  710: 				}
  711: 				$self->{status} = 501;	# Not implemented
  712: 				return;
  713: 			}
  714: 			$query =~ s/\\u0026/\&/g;
  715: 			@pairs = split(/&/, $query);
  716: 		} else {
  717: 			return;
  718: 		}
  719: 	} elsif($ENV{'REQUEST_METHOD'} eq 'POST') {
  720: 		my $content_length = $self->_get_env('CONTENT_LENGTH');
  721: 		if((!defined($content_length)) || ($content_length =~ /\D/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  722: 			$self->{status} = 411;
  723: 			return;
  724: 		}
  725: 		if(($self->{max_upload_size} >= 0) && ($content_length > $self->{max_upload_size})) {	# Set maximum posts

					

					Mutants (Total: 8, Killed: 5, Survived: 3)
					

  726: 			# TODO: Design a way to tell the caller to send HTTP
  727: 			# status 413
  728: 			$self->{status} = 413;
  729: 			$self->_warn('Large upload prohibited');
  730: 			return;
  731: 		}
  732: 
  733: 		if((!defined($content_type)) || ($content_type =~ /application\/x-www-form-urlencoded/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  734: 			my $buffer;
  735: 			if($stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  736: 				$buffer = $stdin_data;
  737: 			} else {
  738: 				if(read(STDIN, $buffer, $content_length) != $content_length) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  739: 					$self->_warn('POST failed: something else may have read STDIN');
  740: 				}
  741: 				$stdin_data = $buffer;
  742: 			}
  743: 			@pairs = split(/&/, $buffer);
  744: 
  745: 			# if($ENV{'QUERY_STRING'}) {
  746: 				# my @getpairs = split(/&/, $ENV{'QUERY_STRING'});
  747: 				# push(@pairs, @getpairs);
  748: 			# }
  749: 		} elsif($content_type =~ /multipart\/form-data/i) {
  750: 			if(!defined($self->{upload_dir})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  751: 				if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  752: 					# This could be an attack
  753: 					$self->_warn({ warning => "$ENV{REMOTE_ADDR}: Attempt to upload a file when upload_dir has not been set" });
  754: 				} else {
  755: 					$self->_warn({ warning => 'Attempt to upload a file when upload_dir has not been set' });
  756: 				}
  757: 				return;
  758: 			}
  759: 
  760: 			# Validate 'upload_dir'
  761: 			# Ensure the upload directory is safe and accessible
  762: 			# - Check permissions
  763: 			# - Validate path to prevent directory traversal attacks
  764: 			# TODO: Consider using a temporary directory for uploads and moving them later
  765: 			if(!File::Spec->file_name_is_absolute($self->{upload_dir})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  766: 				$self->_warn({
  767: 					warning => "upload_dir $self->{upload_dir} isn't a full pathname"
  768: 				});
  769: 				$self->status(500);
  770: 				delete $self->{upload_dir};
  771: 				return;
  772: 			}
  773: 			if(!-d $self->{upload_dir}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  774: 				$self->_warn({
  775: 					warning => "upload_dir $self->{upload_dir} isn't a directory"
  776: 				});
  777: 				$self->status(500);
  778: 				delete $self->{upload_dir};
  779: 				return;
  780: 			}
  781: 			if(!-w $self->{upload_dir}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  782: 				delete $self->{paramref};
  783: 				$self->_warn({
  784: 					warning => "upload_dir $self->{upload_dir} isn't writeable"
  785: 				});
  786: 				$self->status(500);
  787: 				delete $self->{upload_dir};
  788: 				return;
  789: 			}
  790: 			my $tmpdir = $self->tmpdir();
  791: 			if($self->{'upload_dir'} !~ /^\Q$tmpdir\E/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  792: 				$self->_warn({
  793: 					warning => 'upload_dir ' . $self->{'upload_dir'} . " isn't somewhere in the temporary area $tmpdir"
  794: 				});
  795: 				$self->status(500);
  796: 				delete $self->{upload_dir};
  797: 				return;
  798: 			}
  799: 			if($content_type =~ /boundary=(\S+)$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  800: 				@pairs = $self->_multipart_data({
  801: 					length => $content_length,
  802: 					boundary => $1
  803: 				});
  804: 			}
  805: 		} elsif($content_type =~ /text\/xml/i) {
  806: 			my $buffer;
  807: 			if($stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  808: 				$buffer = $stdin_data;
  809: 			} else {
  810: 				if(read(STDIN, $buffer, $content_length) != $content_length) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  811: 					$self->_warn({
  812: 						warning => 'XML failed: something else may have read STDIN'
  813: 					});
  814: 				}
  815: 				$stdin_data = $buffer;
  816: 			}
  817: 
  818: 			$FORM{XML} = $buffer;
  819: 
  820: 			$self->{paramref} = \%FORM;
  821: 
  822: 			return \%FORM;
  823: 		} elsif($content_type =~ /application\/json/i) {
  824: 			require JSON::MaybeXS && JSON::MaybeXS->import() unless JSON::MaybeXS->can('parse_json');
  825: 			# require JSON::MaybeXS;
  826: 			# JSON::MaybeXS->import();
  827: 
  828: 			my $buffer;
  829: 
  830: 			if($stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  831: 				$buffer = $stdin_data;
  832: 			} else {
  833: 				if(read(STDIN, $buffer, $content_length) != $content_length) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  834: 					$self->_warn({
  835: 						warning => 'read failed: something else may have read STDIN'
  836: 					});
  837: 				}
  838: 				$stdin_data = $buffer;
  839: 			}
  840: 			# JSON::Parse::assert_valid_json($buffer);
  841: 			# my $paramref = JSON::Parse::parse_json($buffer);
  842: 			my $paramref = decode_json($buffer);
  843: 			foreach my $key(keys(%{$paramref})) {
  844: 				push @pairs, "$key=" . $paramref->{$key};
  845: 			}
  846: 		} else {
  847: 			my $buffer;
  848: 			if($stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  849: 				$buffer = $stdin_data;
  850: 			} else {
  851: 				if(read(STDIN, $buffer, $content_length) != $content_length) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  852: 					$self->_warn({
  853: 						warning => 'read failed: something else may have read STDIN'
  854: 					});
  855: 				}
  856: 				$stdin_data = $buffer;
  857: 			}
  858: 
  859: 			$self->_warn({
  860: 				warning => "POST: Invalid or unsupported content type: $content_type: $buffer",
  861: 			});
  862: 		}
  863: 	} elsif($ENV{'REQUEST_METHOD'} eq 'OPTIONS') {
  864: 		$self->{status} = 405;
  865: 		return;
  866: 	} elsif($ENV{'REQUEST_METHOD'} eq 'DELETE') {
  867: 		$self->{status} = 405;
  868: 		return;
  869: 	} else {
  870: 		# TODO: Design a way to tell the caller to send HTTP
  871: 		# status 501
  872: 		$self->{status} = 501;
  873: 		$self->_warn({
  874: 			warning => 'Use POST, GET or HEAD'
  875: 		});
  876: 	}
  877: 
●878 → 878 → 882●878 → 878 → 0●878 → 878 → 882●878 → 878 → 0  878: 	unless(scalar @pairs) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  879: 		return;
  880: 	}
  881: 
●882 → 887 → 1030●882 → 887 → 0●882 → 887 → 1030●882 → 887 → 0  882: 	require String::Clean::XSS;
  883: 	String::Clean::XSS->import();
  884: 	# require String::EscapeCage;
  885: 	# String::EscapeCage->import();
  886: 
  887: 	foreach my $arg (@pairs) {
  888: 		my($key, $value) = split(/=/, $arg, 2);
  889: 
  890: 		next unless($key);
  891: 
  892: 		$key =~ s/\0//g;	# Strip encoded NUL byte poison
  893: 		$key =~ s/%00//g;	# Strip NUL byte poison
  894: 		$key =~ s/%([a-fA-F\d][a-fA-F\d])/pack("C", hex($1))/eg;
  895: 		$key =~ tr/+/ /;
  896: 		if(defined($value)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  897: 			$value =~ s/\0//g;	# Strip NUL byte poison
  898: 			$value =~ s/%00//g;	# Strip encoded NUL byte poison
  899: 			$value =~ s/%([a-fA-F\d][a-fA-F\d])/pack("C", hex($1))/eg;
  900: 			$value =~ tr/+/ /;
  901: 		} else {
  902: 			$value = '';
  903: 		}
  904: 
  905: 		$key = _sanitise_input($key);
  906: 
  907: 		if($self->{allow}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  908: 			# Is this a permitted argument?
  909: 			if(!exists($self->{allow}->{$key})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  910: 				$self->_info("Discard unallowed argument '$key'");
  911: 				$self->status(422);
  912: 				next;	# Skip to the next parameter
  913: 			}
  914: 
  915: 			# Do we allow any value, or must it be validated?
  916: 			if(defined(my $schema = $self->{allow}->{$key})) {	# Get the schema for this key

  Mutants (Total: 1, Killed: 1, Survived: 0)
  917: 				if(!ref($schema)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  918: 					# Can only contain one value
  919: 					if($value ne $schema) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  920: 						$self->_info("Block $key = $value");
  921: 						$self->status(422);
  922: 						next;	# Skip to the next parameter
  923: 					}
  924: 				} elsif(ref($schema) eq 'Regexp') {
  925: 					if($value !~ $schema) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  926: 						# Simple regex
  927: 						$self->_info("Block $key = $value");
  928: 						$self->status(422);
  929: 						next;	# Skip to the next parameter
  930: 					}
  931: 				} elsif(ref($schema) eq 'CODE') {
  932: 					unless($schema->($key, $value, $self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  933: 						$self->_info("Block $key = $value");
  934: 						next;
  935: 					}
  936: 				} else {
  937: 					# Set of rules
  938: 					eval {
  939: 						$value = Params::Validate::Strict::validate_strict({
  940: 							schema => { $key => $schema },
  941: 							args => { $key => $value },
  942: 							unknown_parameter_handler => 'die',
  943: 							logger => $self->{'logger'}
  944: 						});
  945: 					};
  946: 					if($@) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  947: 						$self->_info("Block $key = $value: $@");
  948: 						$self->status(422);
  949: 						next;	# Skip to the next parameter
  950: 					}
  951: 					if(scalar keys %{$value}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  952: 						$value = $value->{$key};
  953: 					} else {
  954: 						$self->_info("Block $key = $value");
  955: 						$self->status(422);
  956: 						next;	# Skip to the next parameter
  957: 					}
  958: 				}
  959: 			}
  960: 		}
  961: 
  962: 		# if($self->{expect} && (List::Util::none { $_ eq $key } @{$self->{expect}})) {
  963: 			# next;
  964: 		# }
  965: 		my $orig_value = $value;
  966: 		$value = _sanitise_input($value);
  967: 
  968: 		if((!defined($ENV{'REQUEST_METHOD'})) || ($ENV{'REQUEST_METHOD'} eq 'GET')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  969: 			# From http://www.symantec.com/connect/articles/detection-sql-injection-and-cross-site-scripting-attacks
  970: 			# Facebook FBCLID can have "--"
  971: 			# if(($value =~ /(\%27)|(\')|(\-\-)|(\%23)|(\#)/ix) ||
  972: 			if(($value =~ /(\%27)|(\')|(\%23)|(\#)/ix) ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
  973: 			   ($value =~ /((\%3D)|(=))[^\n]*((\%27)|(\')|(\-\-)|(\%3B)|(;))/i) ||
  974: 			   ($value =~ /\w*((\%27)|(\'))((\%6F)|o|(\%4F))((\%72)|r|(\%52))\s*(OR|AND|UNION|SELECT|--)/ix) ||
  975: 			   ($value =~ /((\%27)|(\'))union/ix) ||
  976: 			   ($value =~ /select[[a-z]\s\*]from/ix) ||
  977: 			   ($value =~ /\sAND\s1=1/ix) ||
  978: 			   ($value =~ /\sOR\s.+\sAND\s/) ||
  979: 			   ($value =~ /\/\*\*\/ORDER\/\*\*\/BY\/\*\*/ix) ||
  980: 			   ($value =~ /\/AND\/.+\(SELECT\//) ||	# United/**/States)/**/AND/**/(SELECT/**/6734/**/FROM/**/(SELECT(SLEEP(5)))lRNi)/**/AND/**/(8984=8984
  981: 			   ($value =~ /exec(\s|\+)+(s|x)p\w+/ix)) {
  982: 				$self->status(403);
  983: 				if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  984: 					$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$key=$value'");
  985: 				} else {
  986: 					$self->_warn("SQL injection attempt blocked for '$key=$value'");
  987: 				}
  988: 				return;
  989: 			}
  990: 			if(my $agent = $ENV{'HTTP_USER_AGENT'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  991: 				if(($agent =~ /SELECT.+AND.+/) || ($agent =~ /ORDER BY /) || ($agent =~ / OR NOT /) || ($agent =~ / AND \d+=\d+/) || ($agent =~ /THEN.+ELSE.+END/) || ($agent =~ /.+AND.+SELECT.+/) || ($agent =~ /\sAND\s.+\sAND\s/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  992: 					$self->status(403);
  993: 					if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  994: 						$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
  995: 					} else {
  996: 						$self->_warn("SQL injection attempt blocked for '$agent'");
  997: 					}
  998: 					return;
  999: 				}
 1000: 			}
 1001: 			if(($value =~ /((\%3C)|<)((\%2F)|\/)*[a-z0-9\%]+((\%3E)|>)/ix) ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1002: 			   ($value =~ /((\%3C)|<)[^\n]+((\%3E)|>)/i) ||
 1003: 			   ($orig_value =~ /((\%3C)|<)((\%2F)|\/)*[a-z0-9\%]+((\%3E)|>)/ix) ||
 1004: 			   ($orig_value =~ /((\%3C)|<)[^\n]+((\%3E)|>)/i)) {
 1005: 				$self->status(403);
 1006: 				$self->_warn("XSS injection attempt blocked for '$value'");
 1007: 				return;
 1008: 			}
 1009: 			if($value =~ /mustleak\.com\//) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1010: 				$self->status(403);
 1011: 				$self->_warn("Blocked mustleak attack for '$key'");
 1012: 				return;
 1013: 			}
 1014: 			if($value =~ /\.\.\//) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1015: 				$self->status(403);
 1016: 				$self->_warn("Blocked directory traversal attack for '$key'");
 1017: 				return;
 1018: 			}
 1019: 		}
 1020: 		if(length($value) > 0) {

  Mutants (Total: 5, Killed: 5, Survived: 0)
 1021: 			# Don't add if it's already there
 1022: 			if($FORM{$key} && ($FORM{$key} ne $value)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1023: 				$FORM{$key} .= ",$value";
 1024: 			} else {
 1025: 				$FORM{$key} = $value;
 1026: 			}
 1027: 		}
 1028: 	}
 1029: 
●1030 → 1030 → 1034●1030 → 1030 → 0●1030 → 1030 → 1034●1030 → 1030 → 0 1030: 	unless(%FORM) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1031: 		return;
 1032: 	}
 1033: 
●1034 → 1034 → 1040●1034 → 1034 → 0●1034 → 1034 → 1040●1034 → 1034 → 0 1034: 	if($self->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1035: 		while(my ($key,$value) = each %FORM) {
 1036: 			$self->_debug("$key=$value");
 1037: 		}
 1038: 	}
 1039: 
●1040 → 1042 → 0●1040 → 1042 → 0 1040: 	$self->{paramref} = \%FORM;
 1041: 
 1042: 	return Return::Set::set_return(\%FORM, { type => 'hashref', min => 1 });
 1043: }
 1044: 
 1045: =head2 param($field)
 1046: 
 1047: Get a single parameter from the query string.
 1048: Takes an optional single string parameter which is the argument to return. If
 1049: that parameter is not given param() is a wrapper to params() with no arguments.
 1050: 
 1051: 	use CGI::Info;
 1052: 	# ...
 1053: 	my $info = CGI::Info->new();
 1054: 	my $bar = $info->param('foo');
 1055: 
 1056: If the requested parameter isn't in the allowed list, an error message will
 1057: be thrown:
 1058: 
 1059: 	use CGI::Info;
 1060: 	my $allowed = {
 1061: 		foo => qr/\d+/
 1062: 	};
 1063: 	my $xyzzy = $info->params(allow => $allowed);
 1064: 	my $bar = $info->param('bar');  # Gives an error message
 1065: 
 1066: Returns undef if the requested parameter was not given
 1067: 
 1068: =over 4
 1069: 
 1070: =item $field
 1071: 
 1072: Optional field to be retrieved.
 1073: If omitted, all the parameters are returned.
 1074: 
 1075: =back
 1076: 
 1077: =cut
 1078: 
 1079: sub param {
●1080 → 1082 → 1086●1080 → 1082 → 0 1080: 	my ($self, $field) = @_;
 1081: 
 1082: 	if(!defined($field)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1083: 		return $self->params();
 1084: 	}
 1085: 	# Is this a permitted argument?
●1086 → 1086 → 1094●1086 → 1086 → 0●1086 → 1086 → 1094●1086 → 1086 → 0 1086: 	if($self->{allow} && !exists($self->{allow}->{$field})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1087: 		$self->_warn({
 1088: 			warning => "param: $field isn't in the allow list"
 1089: 		});
 1090: 		return;
 1091: 	}
 1092: 
 1093: 	# Prevent deep recursion which can happen when a validation routine calls param()
●1094 → 1095 → 1098●1094 → 1095 → 0●1094 → 1095 → 1098●1094 → 1095 → 0 1094: 	my $allow;
 1095: 	if($self->{in_param} && $self->{allow}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1096: 		$allow = delete $self->{allow};
 1097: 	}
●1098 → 1105 → 0●1098 → 1105 → 0●1098 → 1105 → 0●1098 → 1105 → 0 1098: 	$self->{in_param} = 1;
 1099: 
 1100: 	my $params = $self->params();
 1101: 
 1102: 	$self->{in_param} = 0;
 1103: 	$self->{allow} = $allow if($allow);
 1104: 
 1105: 	if($params) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1106: 		return Return::Set::set_return($params->{$field}, { type => 'string' });
 1107: 	}
 1108: }
 1109: 
 1110: sub _sanitise_input($) {
 1111: 	my $arg = shift;
 1112: 
 1113: 	return if(!defined($arg));
 1114: 
 1115: 	# Remove hacking attempts and spaces
 1116: 	$arg =~ s/[\r\n]//g;
 1117: 	$arg =~ s/\s+$//;
 1118: 	$arg =~ s/^\s//;
 1119: 
 1120: 	$arg =~ s/<!--.*-->//g;
 1121: 	# Allow :
 1122: 	# $arg =~ s/[;<>\*|`&\$!?#\(\)\[\]\{\}'"\\\r]//g;
 1123: 
 1124: 	# return $arg;
 1125: 	# return String::EscapeCage->new(convert_XSS($arg))->escapecstring();
 1126: 	return convert_XSS($arg);
 1127: }
 1128: 
 1129: sub _multipart_data {
●1130 → 1138 → 1142●1130 → 1138 → 0 1130: 	my ($self, $args) = @_;
 1131: 
 1132: 	$self->_trace('Entering _multipart_data');
 1133: 
 1134: 	my $total_bytes = $$args{length};
 1135: 
 1136: 	$self->_debug("_multipart_data: total_bytes = $total_bytes");
 1137: 
 1138: 	if($total_bytes == 0) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1139: 		return;
 1140: 	}
 1141: 
●1142 → 1142 → 1153●1142 → 1142 → 0●1142 → 1142 → 1153●1142 → 1142 → 0 1142: 	unless($stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1143: 		while(<STDIN>) {
 1144: 			chop(my $line = $_);
 1145: 			$line =~ s/[\r\n]//g;
 1146: 			$stdin_data .= "$line\n";
 1147: 		}
 1148: 		if(!$stdin_data) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1149: 			return;
 1150: 		}
 1151: 	}
 1152: 
●1153 → 1162 → 1216●1153 → 1162 → 0●1153 → 1162 → 1216●1153 → 1162 → 0 1153: 	my $boundary = $$args{boundary};
 1154: 
 1155: 	my @pairs;
 1156: 	my $writing_file = 0;
 1157: 	my $key;
 1158: 	my $value;
 1159: 	my $in_header = 0;
 1160: 	my $fout;
 1161: 
 1162: 	foreach my $line(split(/\n/, $stdin_data)) {
 1163: 		if($line =~ /^--\Q$boundary\E--$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1164: 			last;
 1165: 		}
 1166: 		if($line =~ /^--\Q$boundary\E$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1167: 			if($writing_file) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1168: 				close $fout;
 1169: 				$writing_file = 0;
 1170: 			} elsif(defined($key)) {
 1171: 				push(@pairs, "$key=$value");
 1172: 				$value = undef;
 1173: 			}
 1174: 			$in_header = 1;
 1175: 		} elsif($in_header) {
 1176: 			if(length($line) == 0) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1177: 				$in_header = 0;
 1178: 			} elsif($line =~ /^Content-Disposition: (.+)/i) {
 1179: 				my $field = $1;
 1180: 				if($field =~ /name="(.+?)"/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1181: 					$key = $1;
 1182: 				}
 1183: 				if($field =~ /filename="(.+)?"/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1184: 					my $filename = $1;
 1185: 					unless(defined($filename)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1186: 						$self->_warn('No upload filename given');
 1187: 					} elsif($filename =~ /[\\\/\|]/) {
 1188: 						$self->_warn("Disallowing invalid filename: $filename");
 1189: 					} else {
 1190: 						$filename = $self->_create_file_name({
 1191: 							filename => $filename
 1192: 						});
 1193: 
 1194: 						# Don't do this since it taints the string and I can't work out how to untaint it
 1195: 						# my $full_path = Cwd::realpath(File::Spec->catfile($self->{upload_dir}, $filename));
 1196: 						# $full_path =~ m/^(\/[\w\.]+)$/;
 1197: 						my $full_path = File::Spec->catfile($self->{upload_dir}, $filename);
 1198: 						unless(open($fout, '>', $full_path)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1199: 							$self->_warn("Can't open $full_path");
 1200: 						}
 1201: 						$writing_file = 1;
 1202: 						push(@pairs, "$key=$filename");
 1203: 					}
 1204: 				}
 1205: 			}
 1206: 			# TODO: handle Content-Type: text/plain, etc.
 1207: 		} else {
 1208: 			if($writing_file) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1209: 				print $fout "$line\n";
 1210: 			} else {
 1211: 				$value .= $line;
 1212: 			}
 1213: 		}
 1214: 	}
 1215: 
●1216 → 1216 → 1220●1216 → 1216 → 0●1216 → 1216 → 1220●1216 → 1216 → 0 1216: 	if($writing_file) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1217: 		close $fout;
 1218: 	}
 1219: 
●1220 → 1222 → 0●1220 → 1222 → 0 1220: 	$self->_trace('Leaving _multipart_data');
 1221: 
 1222: 	return @pairs;
 1223: }
 1224: 
 1225: # Robust filename generation (preventing overwriting)
 1226: sub _create_file_name {
 1227: 	my ($self, $args) = @_;
 1228: 	my $filename = $$args{filename} . '_' . time;
 1229: 
 1230: 	my $counter = 0;
 1231: 	my $rc;
 1232: 
 1233: 	do {
 1234: 		$rc = $filename . ($counter ? "_$counter" : '');
 1235: 		$counter++;
 1236: 	} until(! -e $rc);	# Check if file exists
 1237: 
 1238: 	return $rc;
 1239: }
 1240: 
 1241: # Untaint a filename. Regex from CGI::Untaint::Filenames
 1242: sub _untaint_filename {
●1243 → 1245 → 0●1243 → 1245 → 0 1243: 	my ($self, $args) = @_;
 1244: 
 1245: 	if($$args{filename} =~ /(^[\w\+_\040\#\(\)\{\}\[\]\/\-\^,\.:;&%@\\~]+\$?$)/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1246: 		return $1;
 1247: 	}
 1248: 	# return undef;
 1249: }
 1250: 
 1251: =head2 is_mobile
 1252: 
 1253: Returns a boolean if the website is being viewed on a mobile
 1254: device such as a smartphone.
 1255: All tablets are mobile, but not all mobile devices are tablets.
 1256: 
 1257: Can be overriden by the IS_MOBILE environment setting
 1258: 
 1259: =cut
 1260: 
 1261: sub is_mobile {
●1262 → 1264 → 1268●1262 → 1264 → 0 1262: 	my $self = shift;
 1263: 
 1264: 	if(defined($self->{is_mobile})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1265: 		return $self->{is_mobile};
 1266: 	}
 1267: 
●1268 → 1268 → 1273●1268 → 1268 → 0●1268 → 1268 → 1273●1268 → 1268 → 0 1268: 	if($ENV{'IS_MOBILE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1269: 		return $ENV{'IS_MOBILE'}
 1270: 	}
 1271: 
 1272: 	# Support Sec-CH-UA-Mobile
●1273 → 1273 → 1280●1273 → 1273 → 0●1273 → 1273 → 1280●1273 → 1273 → 0 1273: 	if(my $ch_ua_mobile = $ENV{'HTTP_SEC_CH_UA_MOBILE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1274: 		if($ch_ua_mobile eq '?1') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1275: 			$self->{is_mobile} = 1;
 1276: 			return 1;
 1277: 		}
 1278: 	}
 1279: 
●1280 → 1280 → 1287●1280 → 1280 → 0●1280 → 1280 → 1287●1280 → 1280 → 0 1280: 	if($ENV{'HTTP_X_WAP_PROFILE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1281: 		# E.g. Blackberry
 1282: 		# TODO: Check the sanity of this variable
 1283: 		$self->{is_mobile} = 1;
 1284: 		return 1;
 1285: 	}
 1286: 
●1287 → 1287 → 1325●1287 → 1287 → 0●1287 → 1287 → 1325●1287 → 1287 → 0 1287: 	if(my $agent = $ENV{'HTTP_USER_AGENT'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1288: 		if($agent =~ /.+(Android|iPhone).+/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1289: 			$self->{is_mobile} = 1;
 1290: 			return 1;
 1291: 		}
 1292: 
 1293: 		# From http://detectmobilebrowsers.com/
 1294: 		if($agent =~ m/(android|bb\d+|meego).+mobile|avantgo|bada\/|blackberry|blazer|compal|elaine|fennec|hiptop|iemobile|ip(hone|od)|iris|kindle|lge |maemo|midp|mmp|mobile.+firefox|netfront|opera m(ob|in)i|palm( os)?|phone|p(ixi|re)\/|plucker|pocket|psp|series(4|6)0|symbian|treo|up\.(browser|link)|vodafone|wap|windows ce|xda|xiino/i || substr($ENV{'HTTP_USER_AGENT'}, 0, 4) =~ m/1207|6310|6590|3gso|4thp|50[1-6]i|770s|802s|a wa|abac|ac(er|oo|s\-)|ai(ko|rn)|al(av|ca|co)|amoi|an(ex|ny|yw)|aptu|ar(ch|go)|as(te|us)|attw|au(di|\-m|r |s )|avan|be(ck|ll|nq)|bi(lb|rd)|bl(ac|az)|br(e|v)w|bumb|bw\-(n|u)|c55\/|capi|ccwa|cdm\-|cell|chtm|cldc|cmd\-|co(mp|nd)|craw|da(it|ll|ng)|dbte|dc\-s|devi|dica|dmob|do(c|p)o|ds(12|\-d)|el(49|ai)|em(l2|ul)|er(ic|k0)|esl8|ez([4-7]0|os|wa|ze)|fetc|fly(\-|_)|g1 u|g560|gene|gf\-5|g\-mo|go(\.w|od)|gr(ad|un)|haie|hcit|hd\-(m|p|t)|hei\-|hi(pt|ta)|hp( i|ip)|hs\-c|ht(c(\-| |_|a|g|p|s|t)|tp)|hu(aw|tc)|i\-(20|go|ma)|i230|iac( |\-|\/)|ibro|idea|ig01|ikom|im1k|inno|ipaq|iris|ja(t|v)a|jbro|jemu|jigs|kddi|keji|kgt( |\/)|klon|kpt |kwc\-|kyo(c|k)|le(no|xi)|lg( g|\/(k|l|u)|50|54|\-[a-w])|libw|lynx|m1\-w|m3ga|m50\/|ma(te|ui|xo)|mc(01|21|ca)|m\-cr|me(rc|ri)|mi(o8|oa|ts)|mmef|mo(01|02|bi|de|do|t(\-| |o|v)|zz)|mt(50|p1|v )|mwbp|mywa|n10[0-2]|n20[2-3]|n30(0|2)|n50(0|2|5)|n7(0(0|1)|10)|ne((c|m)\-|on|tf|wf|wg|wt)|nok(6|i)|nzph|o2im|op(ti|wv)|oran|owg1|p800|pan(a|d|t)|pdxg|pg(13|\-([1-8]|c))|phil|pire|pl(ay|uc)|pn\-2|po(ck|rt|se)|prox|psio|pt\-g|qa\-a|qc(07|12|21|32|60|\-[2-7]|i\-)|qtek|r380|r600|raks|rim9|ro(ve|zo)|s55\/|sa(ge|ma|mm|ms|ny|va)|sc(01|h\-|oo|p\-)|sdk\/|se(c(\-|0|1)|47|mc|nd|ri)|sgh\-|shar|sie(\-|m)|sk\-0|sl(45|id)|sm(al|ar|b3|it|t5)|so(ft|ny)|sp(01|h\-|v\-|v )|sy(01|mb)|t2(18|50)|t6(00|10|18)|ta(gt|lk)|tcl\-|tdg\-|tel(i|m)|tim\-|t\-mo|to(pl|sh)|ts(70|m\-|m3|m5)|tx\-9|up(\.b|g1|si)|utst|v400|v750|veri|vi(rg|te)|vk(40|5[0-3]|\-v)|vm40|voda|vulc|vx(52|53|60|61|70|80|81|83|85|98)|w3c(\-| )|webc|whit|wi(g |nc|nw)|wmlb|wonu|x700|yas\-|your|zeto|zte\-/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1295: 			$self->{is_mobile} = 1;
 1296: 			return 1;
 1297: 		}
 1298: 
 1299: 		# Save loading and calling HTTP::BrowserDetect
 1300: 		my $remote = $ENV{'REMOTE_ADDR'};
 1301: 		if(defined($remote) && $self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1302: 			if(my $type = $self->{cache}->get("$remote/$agent")) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1303: 				return $self->{is_mobile} = ($type eq 'mobile');
 1304: 			}
 1305: 		}
 1306: 
 1307: 		unless($self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1308: 			if(eval { require HTTP::BrowserDetect; }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1309: 				HTTP::BrowserDetect->import();
 1310: 				$self->{browser_detect} = HTTP::BrowserDetect->new($agent);
 1311: 			}
 1312: 		}
 1313: 
 1314: 		if($self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1315: 			my $device = $self->{browser_detect}->device();
 1316: 			# Without the ?1:0 it will set to the empty string not 0
 1317: 			my $is_mobile = (defined($device) && ($device =~ /blackberry|webos|iphone|ipod|ipad|android/i)) ? 1 : 0;
 1318: 			if($is_mobile && $self->{cache} && defined($remote)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1319: 				$self->{cache}->set("$remote/$agent", 'mobile', '1 day');
 1320: 			}
 1321: 			return $self->{is_mobile} = $is_mobile;
 1322: 		}
 1323: 	}
 1324: 
●1325 → 1325 → 0●1325 → 1325 → 0 1325: 	return 0;
 1326: }
 1327: 
 1328: =head2 is_tablet
 1329: 
 1330: Returns a boolean if the website is being viewed on a tablet such as an iPad.
 1331: 
 1332: =cut
 1333: 
 1334: sub is_tablet {
●1335 → 1337 → 1341●1335 → 1337 → 0 1335: 	my $self = shift;
 1336: 
 1337: 	if(defined($self->{is_tablet})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1338: 		return $self->{is_tablet};
 1339: 	}
 1340: 
●1341 → 1341 → 1348●1341 → 1341 → 0●1341 → 1341 → 1348●1341 → 1341 → 0 1341: 	if($ENV{'HTTP_USER_AGENT'} && ($ENV{'HTTP_USER_AGENT'} =~ /.+(iPad|TabletPC).+/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1342: 		# TODO: add others when I see some nice user_agents
 1343: 		$self->{is_tablet} = 1;
 1344: 	} else {
 1345: 		$self->{is_tablet} = 0;
 1346: 	}
 1347: 
●1348 → 1348 → 0●1348 → 1348 → 0 1348: 	return $self->{is_tablet};
 1349: }
 1350: 
 1351: =head2 as_string
 1352: 
 1353: Converts CGI parameters into a formatted string representation with optional raw mode (no escaping of special characters).
 1354: Useful for debugging or generating keys for a cache.
 1355: 
 1356:     my $string_representation = $info->as_string();
 1357:     my $raw_string = $info->as_string({ raw => 1 });
 1358: 
 1359: =head3 API SPECIFICATION
 1360: 
 1361: =head4 INPUT
 1362: 
 1363:   {
 1364:     raw => {
 1365:       'type' => 'boolean',
 1366:       'optional' => 1,
 1367:     }
 1368:   }
 1369: 
 1370: =head4 OUTPUT
 1371: 
 1372:   {
 1373:     type => 'string',
 1374:     optional => 1,
 1375:   }
 1376: 
 1377: =cut
 1378: 
 1379: sub as_string
 1380: {
●1381 → 1398 → 1414●1381 → 1398 → 0 1381: 	my $self = shift;
 1382: 
 1383: 	my $args = Params::Validate::Strict::validate_strict({
 1384: 		args => Params::Get::get_params(undef, @_) || {},
 1385: 		schema => {
 1386: 			raw => {
 1387: 				'type' => 'boolean',
 1388: 				'optional' => 1
 1389: 			}
 1390: 		}
 1391: 	});
 1392: 
 1393: 	# Retrieve object parameters
 1394: 	my $params = $self->params() || return '';
 1395: 
 1396: 	my $rc;
 1397: 
 1398: 	if($args->{'raw'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1399: 		# Raw mode: return key=value pairs without escaping
 1400: 		$rc = join '; ', map {
 1401: 			"$_=" . $params->{$_}
 1402: 		} sort keys %{$params};
 1403: 	} else {
 1404: 		# Escaped mode: escape special characters
 1405: 		$rc = join '; ', map {
 1406: 			my $value = $params->{$_};
 1407: 
 1408: 			$value =~ s/\\/\\\\/g;	# Escape backslashes
 1409: 			$value =~ s/(;|=)/\\$1/g;	# Escape semicolons and equals signs
 1410: 			"$_=$value"
 1411: 		} sort keys %{$params};
 1412: 	}
 1413: 
●1414 → 1418 → 0●1414 → 1418 → 0 1414: 	$rc ||= '';
 1415: 
 1416: 	$self->_trace("as_string: returning '$rc'");
 1417: 
 1418: 	return $rc;
 1419: }
 1420: 
 1421: =head2 protocol
 1422: 
 1423: Returns the connection protocol, presumably 'http' or 'https', or undef if
 1424: it can't be determined.
 1425: 
 1426: =cut
 1427: 
 1428: sub protocol {
●1429 → 1431 → 1434●1429 → 1431 → 0 1429: 	my $self = shift;
 1430: 
 1431: 	if($ENV{'SCRIPT_URI'} && ($ENV{'SCRIPT_URI'} =~ /^(.+):\/\/.+/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1432: 		return $1;
 1433: 	}
●1434 → 1434 → 1438●1434 → 1434 → 0●1434 → 1434 → 1438●1434 → 1434 → 0 1434: 	if($ENV{'SERVER_PROTOCOL'} && ($ENV{'SERVER_PROTOCOL'} =~ /^HTTP\//)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1435: 		return 'http';
 1436: 	}
 1437: 
●1438 → 1438 → 1455●1438 → 1438 → 0●1438 → 1438 → 1455●1438 → 1438 → 0 1438: 	if(my $port = $ENV{'SERVER_PORT'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1439: 		if(defined(my $name = getservbyport($port, 'tcp'))) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1440: 			if($name =~ /https?/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1441: 				return $name;
 1442: 			} elsif($name eq 'www') {
 1443: 				# e.g. NetBSD and OpenBSD
 1444: 				return 'http';
 1445: 			}
 1446: 			# Return an error, maybe missing something
 1447: 		} elsif($port == 80) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1448: 			# e.g. Solaris
 1449: 			return 'http';
 1450: 		} elsif($port == 443) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1451: 			return 'https';
 1452: 		}
 1453: 	}
 1454: 
●1455 → 1455 → 1458●1455 → 1455 → 0●1455 → 1455 → 1458●1455 → 1455 → 0 1455: 	if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1456: 		$self->_warn("Can't determine the calling protocol");
 1457: 	}
●1458 → 1458 → 0●1458 → 1458 → 0 1458: 	return;
 1459: }
 1460: 
 1461: =head2 tmpdir
 1462: 
 1463: Returns the name of a directory that you can use to create temporary files
 1464: in.
 1465: 
 1466: The routine is preferable to L<File::Spec/tmpdir> since CGI programs are
 1467: often running on shared servers.  Having said that, tmpdir will fall back
 1468: to File::Spec->tmpdir() if it can't find somewhere better.
 1469: 
 1470: If the parameter 'default' is given, then use that directory as a
 1471: fall-back rather than the value in File::Spec->tmpdir().
 1472: No sanity tests are done, so if you give the default value of
 1473: '/non-existant', that will be returned.
 1474: 
 1475: Tmpdir allows a reference of the options to be passed.
 1476: 
 1477: 	use CGI::Info;
 1478: 
 1479: 	my $info = CGI::Info->new();
 1480: 	my $dir = $info->tmpdir(default => '/var/tmp');
 1481: 	$dir = $info->tmpdir({ default => '/var/tmp' });
 1482: 
 1483: 	# or
 1484: 
 1485: 	my $dir = CGI::Info->tmpdir();
 1486: =cut
 1487: 
 1488: sub tmpdir {
●1489 → 1492 → 1496●1489 → 1492 → 0 1489: 	my $self = shift;
 1490: 
 1491: 	my $name = 'tmp';
 1492: 	if($^O eq 'MSWin32') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1493: 		$name = 'temp';
 1494: 	}
 1495: 
●1496 → 1498 → 1501●1496 → 1498 → 0●1496 → 1498 → 1501●1496 → 1498 → 0 1496: 	my $dir;
 1497: 
 1498: 	if(!ref($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1499: 		$self = __PACKAGE__->new();
 1500: 	}
●1501 → 1503 → 1513●1501 → 1503 → 0●1501 → 1503 → 1513●1501 → 1503 → 0 1501: 	my $params = Params::Get::get_params(undef, @_);
 1502: 
 1503: 	if($ENV{'C_DOCUMENT_ROOT'} && (-d $ENV{'C_DOCUMENT_ROOT'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1504: 		$dir = File::Spec->catdir($ENV{'C_DOCUMENT_ROOT'}, $name);
 1505: 		if((-d $dir) && (-w $dir)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1506: 			return $self->_untaint_filename({ filename => $dir });
 1507: 		}
 1508: 		$dir = $ENV{'C_DOCUMENT_ROOT'};
 1509: 		if((-d $dir) && (-w $dir)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1510: 			return $self->_untaint_filename({ filename => $dir });
 1511: 		}
 1512: 	}
●1513 → 1513 → 1519●1513 → 1513 → 0●1513 → 1513 → 1519●1513 → 1513 → 0 1513: 	if($ENV{'DOCUMENT_ROOT'} && (-d $ENV{'DOCUMENT_ROOT'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1514: 		$dir = File::Spec->catdir($ENV{'DOCUMENT_ROOT'}, File::Spec->updir(), $name);
 1515: 		if((-d $dir) && (-w $dir)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1516: 			return $self->_untaint_filename({ filename => $dir });
 1517: 		}
 1518: 	}
●1519 → 1519 → 1522●1519 → 1519 → 0●1519 → 1519 → 1522●1519 → 1519 → 0 1519: 	if($params->{'default'} && ref($params->{'default'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1520: 		croak(ref($self), ': tmpdir must be given a scalar');
 1521: 	}
●1522 → 1522 → 0●1522 → 1522 → 0 1522: 	return $params->{default} ? $params->{default} : File::Spec->tmpdir();
 1523: }
 1524: 
 1525: =head2 rootdir
 1526: 
 1527: Returns the document root.  This is preferable to looking at DOCUMENT_ROOT
 1528: in the environment because it will also work when we're not running as a CGI
 1529: script, which is useful for script debugging.
 1530: 
 1531: This can be run as a class or object method.
 1532: 
 1533: 	use CGI::Info;
 1534: 
 1535: 	print CGI::Info->rootdir();
 1536: 
 1537: =cut
 1538: 
 1539: sub rootdir {
●1540 → 1540 → 1545●1540 → 1540 → 0 1540: 	if($ENV{'C_DOCUMENT_ROOT'} && (-d $ENV{'C_DOCUMENT_ROOT'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1541: 		return $ENV{'C_DOCUMENT_ROOT'};
 1542: 	} elsif($ENV{'DOCUMENT_ROOT'} && (-d $ENV{'DOCUMENT_ROOT'})) {
 1543: 		return $ENV{'DOCUMENT_ROOT'};
 1544: 	}
●1545 → 1547 → 1550●1545 → 1547 → 0●1545 → 1547 → 1550●1545 → 1547 → 0 1545: 	my $script_name = $0;
 1546: 
 1547: 	unless(File::Spec->file_name_is_absolute($script_name)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1548: 		$script_name = File::Spec->rel2abs($script_name);
 1549: 	}
●1550 → 1550 → 1553●1550 → 1550 → 0●1550 → 1550 → 1553●1550 → 1550 → 0 1550: 	if($script_name =~ /.cgi\-bin.*/) {	# kludge for outside CGI environment

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1551: 		$script_name =~ s/.cgi\-bin.*//;
 1552: 	}
●1553 → 1553 → 1564●1553 → 1553 → 0●1553 → 1553 → 1564●1553 → 1553 → 0 1553: 	if(-f $script_name) {	# More kludge

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1554: 		if($^O eq 'MSWin32') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1555: 			if($script_name =~ /(.+)\\.+?$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1556: 				return $1;
 1557: 			}
 1558: 		} else {
 1559: 			if($script_name =~ /(.+)\/.+?$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1560: 				return $1;
 1561: 			}
 1562: 		}
 1563: 	}
●1564 → 1564 → 0●1564 → 1564 → 0 1564: 	return $script_name;
 1565: }
 1566: 
 1567: =head2 root_dir
 1568: 
 1569: Synonym of rootdir(), for compatibility with L<CHI>.
 1570: 
 1571: =cut
 1572: 
 1573: sub root_dir
 1574: {
●1575 → 1575 → 1580●1575 → 1575 → 0 1575: 	if($_[0] && ref($_[0])) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1576: 		my $self = shift;
 1577: 
 1578: 		return $self->rootdir(@_);
 1579: 	}
●1580 → 1580 → 0●1580 → 1580 → 0 1580: 	return __PACKAGE__->rootdir(@_);
 1581: }
 1582: 
 1583: =head2 documentroot
 1584: 
 1585: Synonym of rootdir(), for compatibility with Apache.
 1586: 
 1587: =cut
 1588: 
 1589: sub documentroot
 1590: {
●1591 → 1591 → 1596●1591 → 1591 → 0 1591: 	if($_[0] && ref($_[0])) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1592: 		my $self = shift;
 1593: 
 1594: 		return $self->rootdir(@_);
 1595: 	}
●1596 → 1596 → 0●1596 → 1596 → 0 1596: 	return __PACKAGE__->rootdir(@_);
 1597: }
 1598: 
 1599: =head2 logdir($dir)
 1600: 
 1601: Gets and sets the name of a directory where you can store logs.
 1602: 
 1603: =over 4
 1604: 
 1605: =item $dir
 1606: 
 1607: Path to the directory where logs will be stored.
 1608: 
 1609: =back
 1610: 
 1611: =cut
 1612: 
 1613: sub logdir {
●1614 → 1617 → 1621●1614 → 1617 → 0 1614: 	my $self = shift;
 1615: 	my $dir = shift;
 1616: 
 1617: 	if(!ref($self)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1618: 		$self = __PACKAGE__->new();
 1619: 	}
 1620: 
●1621 → 1621 → 1629●1621 → 1621 → 0●1621 → 1621 → 1629●1621 → 1621 → 0 1621: 	if($dir) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1622: 		if(length($dir) && (-d $dir) && (-w $dir)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1623: 			return $self->{'logdir'} = $dir;
 1624: 		}
 1625: 		$self->_warn("Invalid logdir: $dir");
 1626: 		Carp::croak("Invalid logdir: $dir");
 1627: 	}
 1628: 
●1629 → 1629 → 1635●1629 → 1629 → 0●1629 → 1629 → 1635●1629 → 1629 → 0 1629: 	foreach my $rc($self->{logdir}, $ENV{'LOGDIR'}, Sys::Path->logdir(), $self->tmpdir()) {
 1630: 		if(defined($rc) && length($rc) && (-d $rc) && (-w $rc)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1631: 			$dir = $rc;
 1632: 			last;
 1633: 		}
 1634: 	}
●1635 → 1638 → 0●1635 → 1638 → 0 1635: 	$self->_warn("Can't determine logdir") if((!defined($dir)) || (length($dir) == 0));

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1636: 	$self->{logdir} ||= $dir;
 1637: 
 1638: 	return $dir;
 1639: }
 1640: 
 1641: =head2 is_robot
 1642: 
 1643: Is the visitor a real person or a robot?
 1644: 
 1645: 	use CGI::Info;
 1646: 
 1647: 	my $info = CGI::Info->new();
 1648: 	unless($info->is_robot()) {
 1649: 		# update site visitor statistics
 1650: 	}
 1651: 
 1652: If the client is seen to be attempting an SQL injection,
 1653: set the HTTP status to 403,
 1654: and return 1.
 1655: 
 1656: =cut
 1657: 
 1658: sub is_robot {
●1659 → 1661 → 1665●1659 → 1661 → 0 1659: 	my $self = shift;
 1660: 
 1661: 	if(defined($self->{is_robot})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1662: 		return $self->{is_robot};
 1663: 	}
 1664: 
●1665 → 1668 → 1674●1665 → 1668 → 0●1665 → 1668 → 1674●1665 → 1668 → 0 1665: 	my $agent = $ENV{'HTTP_USER_AGENT'};
 1666: 	my $remote = $ENV{'REMOTE_ADDR'};
 1667: 
 1668: 	unless($remote && $agent) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1669: 		# Probably not running in CGI - assume real person
 1670: 		return 0;
 1671: 	}
 1672: 
 1673: 	# See also params()
●1674 → 1674 → 1684●1674 → 1674 → 0●1674 → 1674 → 1684●1674 → 1674 → 0 1674: 	if(($agent =~ /SELECT.+AND.+/) || ($agent =~ /ORDER BY /) || ($agent =~ / OR NOT /) || ($agent =~ / AND \d+=\d+/) || ($agent =~ /THEN.+ELSE.+END/) || ($agent =~ /.+AND.+SELECT.+/) || ($agent =~ /\sAND\s.+\sAND\s/)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1675: 		$self->status(403);
 1676: 		$self->{is_robot} = 1;
 1677: 		if($ENV{'REMOTE_ADDR'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1678: 			$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
 1679: 		} else {
 1680: 			$self->_warn("SQL injection attempt blocked for '$agent'");
 1681: 		}
 1682: 		return 1;
 1683: 	}
●1684 → 1684 → 1693●1684 → 1684 → 0●1684 → 1684 → 1693●1684 → 1684 → 0 1684: 	if($agent =~ /.+bot|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|nova\.6scan\.com|Twitterbot|adscanner|Go-http-client|python-requests|Mediatoolkitbot|NetcraftSurveyAgent|Expanse|serpstatbot|DreamHost SiteMonitor|techiaith.cymru|trendictionbot|ias_crawler|WPsec|Yak\/1\.0|ZoominfoBot/i) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1685: 		$self->{is_robot} = 1;
 1686: 		return 1;
 1687: 	}
 1688: 
 1689: 	# TODO:
 1690: 	# Download and use list from
 1691: 	#	https://raw.githubusercontent.com/mitchellkrogza/apache-ultimate-bad-bot-blocker/refs/heads/master/_generator_lists/bad-user-agents.list
 1692: 
●1693 → 1695 → 1748●1693 → 1695 → 0●1693 → 1695 → 1748●1693 → 1695 → 0 1693: 	my $key = "$remote/$agent";
 1694: 
 1695: 	if(my $referrer = $ENV{'HTTP_REFERER'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1696: 		# https://agency.ohow.co/google-analytics-implementation-audit/google-analytics-historical-spam-list/
 1697: 		my @crawler_lists = (
 1698: 			'http://fix-website-errors.com',
 1699: 			'http://keywords-monitoring-your-success.com',
 1700: 			'http://free-video-tool.com',
 1701: 			'http://magnet-to-torrent.com',
 1702: 			'http://torrent-to-magnet.com',
 1703: 			'http://dogsrun.net',
 1704: 			'http://###.responsive-test.net',
 1705: 			'http://uptime.com',
 1706: 			'http://uptimechecker.com',
 1707: 			'http://top1-seo-service.com',
 1708: 			'http://fast-wordpress-start.com',
 1709: 			'http://wordpress-crew.net',
 1710: 			'http://dbutton.net',
 1711: 			'http://justprofit.xyz',
 1712: 			'http://video--production.com',
 1713: 			'http://buttons-for-website.com',
 1714: 			'http://buttons-for-your-website.com',
 1715: 			'http://success-seo.com',
 1716: 			'http://videos-for-your-business.com',
 1717: 			'http://semaltmedia.com',
 1718: 			'http://dailyrank.net',
 1719: 			'http://uptimebot.net',
 1720: 			'http://sitevaluation.org',
 1721: 			'http://100dollars-seo.com',
 1722: 			'http://forum69.info',
 1723: 			'http://partner.semalt.com',
 1724: 			'http://best-seo-offer.com',
 1725: 			'http://best-seo-solution.com',
 1726: 			'http://semalt.semalt.com',
 1727: 			'http://semalt.com',
 1728: 			'http://7makemoneyonline.com',
 1729: 			'http://anticrawler.org',
 1730: 			'http://baixar-musicas-gratis.com',
 1731: 			'http://descargar-musica-gratis.net',
 1732: 
 1733: 			# Mine
 1734: 			'http://www.seokicks.de/robot.html',
 1735: 		);
 1736: 		$referrer =~ s/\\/_/g;
 1737: 		if(($referrer =~ /\)/) || (List::Util::any { $_ =~ /^$referrer/ } @crawler_lists)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1738: 			$self->_debug("is_robot: blocked trawler $referrer");
 1739: 
 1740: 			if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1741: 				$self->{cache}->set($key, 'robot', '1 day');
 1742: 			}
 1743: 			$self->{is_robot} = 1;
 1744: 			return 1;
 1745: 		}
 1746: 	}
 1747: 
●1748 → 1748 → 1756●1748 → 1748 → 0●1748 → 1748 → 1756●1748 → 1748 → 0 1748: 	if(defined($remote) && $self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1749: 		if(my $type = $self->{cache}->get("$remote/$agent")) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1750: 			return $self->{is_robot} = ($type eq 'robot');
 1751: 		}
 1752: 	}
 1753: 
 1754: 	# Don't use HTTP_USER_AGENT to detect more than we really have to since
 1755: 	# that is easily spoofed
●1756 → 1756 → 1764●1756 → 1756 → 0●1756 → 1756 → 1764●1756 → 1756 → 0 1756: 	if($agent =~ /www\.majestic12\.co\.uk|facebookexternal/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1757: 		# Mark Facebook as a search engine, not a robot
 1758: 		if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1759: 			$self->{cache}->set($key, 'search', '1 day');
 1760: 		}
 1761: 		return 0;
 1762: 	}
 1763: 
●1764 → 1764 → 1770●1764 → 1764 → 0●1764 → 1764 → 1770●1764 → 1764 → 0 1764: 	unless($self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1765: 		if(eval { require HTTP::BrowserDetect; }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1766: 			HTTP::BrowserDetect->import();
 1767: 			$self->{browser_detect} = HTTP::BrowserDetect->new($agent);
 1768: 		}
 1769: 	}
●1770 → 1770 → 1787●1770 → 1770 → 0●1770 → 1770 → 1787●1770 → 1770 → 0 1770: 	if($self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1771: 		my $is_robot = $self->{browser_detect}->robot();
 1772: 		if(defined($is_robot)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1773: 			$self->_debug("HTTP::BrowserDetect '$ENV{HTTP_USER_AGENT}' returns $is_robot");
 1774: 		}
 1775: 		$is_robot = (defined($is_robot) && ($is_robot)) ? 1 : 0;
 1776: 		$self->_debug("is_robot: $is_robot");
 1777: 
 1778: 		if($is_robot) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1779: 			if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1780: 				$self->{cache}->set($key, 'robot', '1 day');
 1781: 			}
 1782: 			$self->{is_robot} = $is_robot;
 1783: 			return $is_robot;
 1784: 		}
 1785: 	}
 1786: 
●1787 → 1787 → 1790●1787 → 1787 → 0●1787 → 1787 → 1790●1787 → 1787 → 0 1787: 	if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1788: 		$self->{cache}->set($key, 'unknown', '1 day');
 1789: 	}
●1790 → 1791 → 0●1790 → 1791 → 0 1790: 	$self->{is_robot} = 0;
 1791: 	return 0;
 1792: }
 1793: 
 1794: =head2 is_search_engine
 1795: 
 1796: Is the visitor a search engine?
 1797: 
 1798:     if(CGI::Info->new()->is_search_engine()) {
 1799: 	# display generic information about yourself
 1800:     } else {
 1801: 	# allow the user to pick and choose something to display
 1802:     }
 1803: 
 1804: Can be overriden by the IS_SEARCH_ENGINE environment setting
 1805: 
 1806: =cut
 1807: 
 1808: sub is_search_engine
 1809: {
●1810 → 1812 → 1816●1810 → 1812 → 0 1810: 	my $self = shift;
 1811: 
 1812: 	if(defined($self->{is_search_engine})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1813: 		return $self->{is_search_engine};
 1814: 	}
 1815: 
●1816 → 1816 → 1820●1816 → 1816 → 0●1816 → 1816 → 1820●1816 → 1816 → 0 1816: 	if($ENV{'IS_SEARCH_ENGINE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1817: 		return $ENV{'IS_SEARCH_ENGINE'}
 1818: 	}
 1819: 
●1820 → 1823 → 1828●1820 → 1823 → 0●1820 → 1823 → 1828●1820 → 1823 → 0 1820: 	my $remote = $ENV{'REMOTE_ADDR'};
 1821: 	my $agent = $ENV{'HTTP_USER_AGENT'};
 1822: 
 1823: 	unless($remote && $agent) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1824: 		# Probably not running in CGI - assume not a search engine
 1825: 		return 0;
 1826: 	}
 1827: 
●1828 → 1830 → 1841●1828 → 1830 → 0●1828 → 1830 → 1841●1828 → 1830 → 0 1828: 	my $key;
 1829: 
 1830: 	if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1831: 		$key = "$remote/$agent";
 1832: 		if(defined($remote) && $self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1833: 			if(my $type = $self->{cache}->get("$remote/$agent")) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1834: 				return $self->{is_search} = ($type eq 'search');
 1835: 			}
 1836: 		}
 1837: 	}
 1838: 
 1839: 	# Don't use HTTP_USER_AGENT to detect more than we really have to since
 1840: 	# that is easily spoofed
●1841 → 1841 → 1849●1841 → 1841 → 0●1841 → 1841 → 1849●1841 → 1841 → 0 1841: 	if($agent =~ /www\.majestic12\.co\.uk|facebookexternal/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1842: 		# Mark Facebook as a search engine, not a robot
 1843: 		if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1844: 			$self->{cache}->set($key, 'search', '1 day');
 1845: 		}
 1846: 		return 1;
 1847: 	}
 1848: 
●1849 → 1849 → 1855●1849 → 1849 → 0●1849 → 1849 → 1855●1849 → 1849 → 0 1849: 	unless($self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1850: 		if(eval { require HTTP::BrowserDetect; }) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1851: 			HTTP::BrowserDetect->import();
 1852: 			$self->{browser_detect} = HTTP::BrowserDetect->new($agent);
 1853: 		}
 1854: 	}
●1855 → 1855 → 1871●1855 → 1855 → 0●1855 → 1855 → 1871●1855 → 1855 → 0 1855: 	if(my $browser = $self->{browser_detect}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1856: 		my $is_search = ($browser->google() || $browser->msn() || $browser->baidu() || $browser->altavista() || $browser->yahoo() || $browser->bingbot());
 1857: 		if(!$is_search) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1858: 			if(($agent =~ /SeznamBot\//) ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1859: 			   ($agent =~ /Google-InspectionTool\//) ||
 1860: 			   ($agent =~ /Googlebot\//)) {
 1861: 				$is_search = 1;
 1862: 			}
 1863: 		}
 1864: 		if($is_search && $self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1865: 			$self->{cache}->set($key, 'search', '1 day');
 1866: 		}
 1867: 		return $self->{is_search_engine} = $is_search;
 1868: 	}
 1869: 
 1870: 	# TODO: DNS lookup, not gethostbyaddr - though that will be slow
●1871 → 1875 → 1884●1871 → 1875 → 0●1871 → 1875 → 1884●1871 → 1875 → 0 1871: 	my $hostname = gethostbyaddr(inet_aton($remote), AF_INET) || $remote;
 1872: 
 1873: 	my @cidr_blocks = ('47.235.0.0/12');	# Alibaba
 1874: 
 1875: 	if((defined($hostname) && ($hostname =~ /google|msnbot|bingbot|amazonbot|GPTBot/) && ($hostname !~ /^google-proxy/)) ||

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1876: 	   (Net::CIDR::cidrlookup($remote, @cidr_blocks))) {
 1877: 		if($self->{cache}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1878: 			$self->{cache}->set($key, 'search', '1 day');
 1879: 		}
 1880: 		$self->{is_search_engine} = 1;
 1881: 		return 1;
 1882: 	}
 1883: 
●1884 → 1885 → 0●1884 → 1885 → 0 1884: 	$self->{is_search_engine} = 0;
 1885: 	return 0;
 1886: }
 1887: 
 1888: =head2 browser_type
 1889: 
 1890: Returns one of 'web', 'search', 'robot' and 'mobile'.
 1891: 
 1892:     # Code to display a different web page for a browser, search engine and
 1893:     # smartphone
 1894:     use Template;
 1895:     use CGI::Info;
 1896: 
 1897:     my $info = CGI::Info->new();
 1898:     my $dir = $info->rootdir() . '/templates/' . $info->browser_type();
 1899: 
 1900:     my $filename = ref($self);
 1901:     $filename =~ s/::/\//g;
 1902:     $filename = "$dir/$filename.tmpl";
 1903: 
 1904:     if((!-f $filename) || (!-r $filename)) {
 1905: 	die "Can't open $filename";
 1906:     }
 1907:     my $template = Template->new();
 1908:     $template->process($filename, {}) || die $template->error();
 1909: 
 1910: =cut
 1911: 
 1912: sub browser_type {
●1913 → 1915 → 1918●1913 → 1915 → 0 1913: 	my $self = shift;
 1914: 
 1915: 	if($self->is_mobile()) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1916: 		return 'mobile';
 1917: 	}
●1918 → 1918 → 1921●1918 → 1918 → 0●1918 → 1918 → 1921●1918 → 1918 → 0 1918: 	if($self->is_search_engine()) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1919: 		return 'search';
 1920: 	}
●1921 → 1921 → 1924●1921 → 1921 → 0●1921 → 1921 → 1924●1921 → 1921 → 0 1921: 	if($self->is_robot()) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1922: 		return 'robot';
 1923: 	}
●1924 → 1924 → 0●1924 → 1924 → 0 1924: 	return 'web';
 1925: }
 1926: 
 1927: =head2 get_cookie
 1928: 
 1929: Returns a cookie's value, or undef if no name is given, or the requested
 1930: cookie isn't in the jar.
 1931: 
 1932: Deprecated - use cookie() instead.
 1933: 
 1934:     use CGI::Info;
 1935: 
 1936:     my $i = CGI::Info->new();
 1937:     my $name = $i->get_cookie(cookie_name => 'name');
 1938:     print "Your name is $name\n";
 1939:     my $address = $i->get_cookie('address');
 1940:     print "Your address is $address\n";
 1941: 
 1942: =cut
 1943: 
 1944: sub get_cookie {
 1945: 	my $self = shift;
 1946: 
 1947: 	return $self->cookie(\@_);
 1948: }
 1949: 
 1950: =head2 cookie
 1951: 
 1952: Returns a cookie's value, or undef if no name is given, or the requested
 1953: cookie isn't in the jar.
 1954: API is the same as "param",
 1955: it will replace the "get_cookie" method in the future.
 1956: 
 1957:     use CGI::Info;
 1958: 
 1959:     my $name = CGI::Info->new()->cookie('name');
 1960:     print "Your name is $name\n";
 1961: 
 1962: 
 1963: =head3 API SPECIFICATION
 1964: 
 1965: =head4 INPUT
 1966: 
 1967:   {
 1968:     cookie_name => {
 1969:       'type' => 'string',
 1970:       'min' => 1,
 1971:       'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/	# RFC6265
 1972:     }
 1973:   }
 1974: 
 1975: =head4 OUTPUT
 1976: 
 1977: Cookie not set: C<undef>
 1978: 
 1979: Cookie set:
 1980: 
 1981:   {
 1982:     type => 'string',
 1983:     optional => 1,
 1984:     matches => qr/	# RFC6265
 1985:       ^
 1986:       (?:
 1987:         "[\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*"   # quoted
 1988:       | [\x21\x23-\x2B\x2D-\x3A\x3C-\x5B\x5D-\x7E]*     # unquoted
 1989:       )
 1990:       $
 1991:     /x
 1992:   }
 1993: 
 1994: =cut
 1995: 
 1996: sub cookie
 1997: {
●1998 → 2013 → 2018●1998 → 2013 → 0 1998: 	my $self = shift;
 1999: 	my $params = Params::Validate::Strict::validate_strict({
 2000: 		args => Params::Get::get_params('cookie_name', @_),
 2001: 		schema => {
 2002: 			cookie_name => {
 2003: 				'type' => 'string',
 2004: 				'min' => 1,
 2005: 				'matches' => qr/^[!#-'*+\-.\^_`|~0-9A-Za-z]+$/	# RFC6265
 2006: 			}
 2007: 		}
 2008: 	});
 2009: 
 2010: 	my $field = $params->{'cookie_name'};
 2011: 
 2012: 	# Validate field argument
 2013: 	if(!defined($field)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2014: 		$self->_error('what cookie do you want?');
 2015: 		Carp::croak('what cookie do you want?');
 2016: 		return;
 2017: 	}
●2018 → 2018 → 2025●2018 → 2018 → 0●2018 → 2018 → 2025●2018 → 2018 → 0 2018: 	if(ref($field)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2019: 		$self->_error('Cookie name should be a string');
 2020: 		Carp::croak('Cookie name should be a string');
 2021: 		return;
 2022: 	}
 2023: 
 2024: 	# Load cookies if not already loaded
●2025 → 2025 → 2032●2025 → 2025 → 0●2025 → 2025 → 2032●2025 → 2025 → 0 2025: 	unless($self->{jar}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2026: 		if(defined $ENV{'HTTP_COOKIE'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2027: 			$self->{jar} = { map { split(/=/, $_, 2) } split(/; /, $ENV{'HTTP_COOKIE'}) };
 2028: 		}
 2029: 	}
 2030: 
 2031: 	# Return the cookie value if it exists, otherwise return undef
●2032 → 2032 → 0●2032 → 2032 → 0 2032: 	return $self->{jar}{$field};
 2033: }
 2034: 
 2035: =head2 status($status)
 2036: 
 2037: Sets or returns the status of the object,
 2038: 200 for OK,
 2039: otherwise an HTTP error code
 2040: 
 2041: =over 4
 2042: 
 2043: =item $status
 2044: 
 2045: Optional integer value to be set or retrieved.
 2046: If omitted, the value is retrieved.
 2047: 
 2048: =back
 2049: 
 2050: =cut
 2051: 
 2052: sub status
 2053: {
●2054 → 2061 → 2071●2054 → 2061 → 0 2054: 	my $self = shift;
 2055: 	my $status = shift;
 2056: 
 2057: 	# Set status if provided
 2058: 	return $self->{status} = $status if(defined($status));
 2059: 
 2060: 	# Determine status based on request method if status is not set
 2061: 	unless (defined $self->{status}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2062: 		my $method = $ENV{'REQUEST_METHOD'};
 2063: 
 2064: 		return 405 if $method && ($method eq 'OPTIONS' || $method eq 'DELETE');
 2065: 		return 411 if $method && ($method eq 'POST' && !defined $ENV{'CONTENT_LENGTH'});
 2066: 
 2067: 		return 200;
 2068: 	}
 2069: 
 2070: 	# Return current status or 200 by default
●2071 → 2071 → 0●2071 → 2071 → 0 2071: 	return $self->{status} || 200;
 2072: }
 2073: 
 2074: =head2 messages
 2075: 
 2076: Returns the messages that the object has generated as a ref to an array of hashes.
 2077: 
 2078:     my @messages;
 2079:     if(my $w = $info->messages()) {
 2080:         @messages = map { $_->{'message'} } @{$w};
 2081:     } else {
 2082:         @messages = ();
 2083:     }
 2084:     print STDERR join(';', @messages), "\n";
 2085: 
 2086: =cut
 2087: 
 2088: sub messages
 2089: {
 2090: 	my $self = shift;
 2091: 
 2092: 	return $self->{'messages'};
 2093: }
 2094: 
 2095: =head2	messages_as_string
 2096: 
 2097: Returns the messages of that the object has generated as a string.
 2098: 
 2099: =cut
 2100: 
 2101: sub messages_as_string
 2102: {
●2103 → 2105 → 2109●2103 → 2105 → 0 2103: 	my $self = shift;
 2104: 
 2105: 	if(scalar($self->{'messages'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2106: 		my @messages = map { $_->{'message'} } @{$self->{'messages'}};
 2107: 		return join('; ', @messages);
 2108: 	}
●2109 → 2109 → 0●2109 → 2109 → 0 2109: 	return '';
 2110: }
 2111: 
 2112: =head2 cache($cache)
 2113: 
 2114: Get/set the internal cache system.
 2115: 
 2116: Use this rather than pass the cache argument to C<new()> if you see these error messages,
 2117: "(in cleanup) Failed to get MD5_CTX pointer".
 2118: It's some obscure problem that I can't work out,
 2119: but calling this after C<new()> works.
 2120: 
 2121: =over 4
 2122: 
 2123: =item $cache
 2124: 
 2125: Optional cache object.
 2126: When not given,
 2127: returns the current cache object.
 2128: 
 2129: =back
 2130: 
 2131: =cut
 2132: 
 2133: sub cache
 2134: {
●2135 → 2138 → 2142●2135 → 2138 → 0 2135: 	my $self = shift;
 2136: 	my $cache = shift;
 2137: 
 2138: 	if($cache) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2139: 		croak(ref($self), ':cache($cache) is not an object') if(!Scalar::Util::blessed($cache));
 2140: 		$self->{'cache'} = $cache;
 2141: 	}
●2142 → 2142 → 0●2142 → 2142 → 0 2142: 	return $self->{'cache'};
 2143: }
 2144: 
 2145: =head2 set_logger
 2146: 
 2147: Sets the class, array, code reference, or file that will be used for logging.
 2148: 
 2149: Sometimes you don't know what the logger is until you've instantiated the class.
 2150: This function fixes the catch-22 situation.
 2151: 
 2152: =cut
 2153: 
 2154: sub set_logger
 2155: {
●2156 → 2159 → 2168●2156 → 2159 → 0 2156: 	my $self = shift;
 2157: 	my $params = Params::Get::get_params('logger', @_);
 2158: 
 2159: 	if(my $logger = $params->{'logger'}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2160: 		if(Scalar::Util::blessed($logger)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2161: 			$self->{'logger'} = $logger;
 2162: 		} else {
 2163: 			$self->{'logger'} = Log::Abstraction->new($logger);
 2164: 		}
 2165: 	} else {
 2166: 		$self->{'logger'} = Log::Abstraction->new();
 2167: 	}
●2168 → 2168 → 0●2168 → 2168 → 0 2168: 	return $self;
 2169: }
 2170: 
 2171: # Log and remember a message
 2172: sub _log
 2173: {
●2174 → 2176 → 0●2174 → 2176 → 0 2174: 	my ($self, $level, @messages) = @_;
 2175: 
 2176: 	if(scalar(@messages)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2177: 		# FIXME: add caller's function
 2178: 		# if(($level eq 'warn') || ($level eq 'info')) {
 2179: 			push @{$self->{'messages'}}, { level => $level, message => join(' ', grep defined, @messages) };
 2180: 		# }
 2181: 
 2182: 		if(scalar(@messages) && (my $logger = $self->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2183: 			$self->{'logger'}->$level(join('', grep defined, @messages));
 2184: 		}
 2185: 	}
 2186: }
 2187: 
 2188: sub _debug {
 2189: 	my $self = shift;
 2190: 	$self->_log('debug', @_);
 2191: }
 2192: 
 2193: sub _info {
 2194: 	my $self = shift;
 2195: 	$self->_log('info', @_);
 2196: }
 2197: 
 2198: sub _notice {
 2199: 	my $self = shift;
 2200: 	$self->_log('notice', @_);
 2201: }
 2202: 
 2203: sub _trace {
 2204: 	my $self = shift;
 2205: 	$self->_log('trace', @_);
 2206: }
 2207: 
 2208: # Emit a warning message somewhere
 2209: sub _warn {
●2210 → 2214 → 0●2210 → 2214 → 0 2210: 	my $self = shift;
 2211: 	my $params = Params::Get::get_params('warning', @_);
 2212: 
 2213: 	$self->_log('warn', $params->{'warning'});
 2214: 	if(!defined($self->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2215: 		Carp::carp($params->{'warning'});
 2216: 	}
 2217: }
 2218: 
 2219: # Emit an error message somewhere
 2220: sub _error {
●2221 → 2225 → 0●2221 → 2225 → 0 2221: 	my $self = shift;
 2222: 	my $params = Params::Get::get_params('warning', @_);
 2223: 
 2224: 	$self->_log('error', $params->{'warning'});
 2225: 	if(!defined($self->{'logger'})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2226: 		Carp::croak($params->{'warning'});
 2227: 	}
 2228: }
 2229: 
 2230: # Ensure all environment variables are sanitized and validated before use.
 2231: # Use regular expressions to enforce strict input formats.
 2232: sub _get_env
 2233: {
●2234 → 2239 → 2242●2234 → 2239 → 0 2234: 	my ($self, $var) = @_;
 2235: 
 2236: 	return unless defined $ENV{$var};
 2237: 
 2238: 	# Strict sanitization: allow alphanumeric and limited special characters
 2239: 	if($ENV{$var} =~ /^[\w\.\-\/:\\]+$/) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2240: 		return $ENV{$var};
 2241: 	}
●2242 → 2244 → 0●2242 → 2244 → 0 2242: 	$self->_warn("Invalid value in environment variable: $var");
 2243: 
 2244: 	return undef;
 2245: }
 2246: 
 2247: =head2 reset
 2248: 
 2249: Class method to reset the class.
 2250: You should do this in an FCGI environment before instantiating,
 2251: but nowhere else.
 2252: 
 2253: =cut
 2254: 
 2255: sub reset {
●2256 → 2258 → 2263●2256 → 2258 → 0 2256: 	my $class = shift;
 2257: 
 2258: 	unless($class eq __PACKAGE__) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 2259: 		carp('Reset is a class method');
 2260: 		return;
 2261: 	}
 2262: 
●2263 → 2263 → 0●2263 → 2263 → 0 2263: 	$stdin_data = undef;
 2264: }
 2265: 
 2266: sub AUTOLOAD
 2267: {
 2268: 	our $AUTOLOAD;
 2269: 
 2270: 	my $self = shift or return;
 2271: 
 2272: 	return if(!defined($AUTOLOAD));
 2273: 
 2274: 	# Extract the method name from the AUTOLOAD variable
 2275: 	my ($method) = $AUTOLOAD =~ /::(\w+)$/;
 2276: 
 2277: 	# Skip if called on destruction
 2278: 	return if($method eq 'DESTROY');
 2279: 
 2280: 	Carp::croak(__PACKAGE__, ": Unknown method $method") if(!ref($self));
 2281: 
 2282: 	# Allow the AUTOLOAD feature to be disabled
 2283: 	Carp::croak(__PACKAGE__, ": Unknown method $method") if(exists($self->{'auto_load'}) && boolean($self->{'auto_load'})->isFalse());
 2284: 
 2285: 	# Ensure the method is called on the correct package object or a subclass
 2286: 	return unless((ref($self) eq __PACKAGE__) || (UNIVERSAL::isa((caller)[0], __PACKAGE__)));
 2287: 
 2288: 	# Validate method name - only allow safe parameter names
 2289: 	Carp::croak(__PACKAGE__, ": Invalid method name: $method") unless $method =~ /^[a-zA-Z_][a-zA-Z0-9_]*$/;
 2290: 
 2291: 	# Delegate to the param method
 2292: 	return $self->param($method);
 2293: }
 2294: 
 2295: =head1 AUTHOR
 2296: 
 2297: Nigel Horne, C<< <njh at nigelhorne.com> >>
 2298: 
 2299: =head1 BUGS
 2300: 
 2301: is_tablet() only currently detects the iPad and Windows PCs. Android strings
 2302: don't differ between tablets and smartphones.
 2303: 
 2304: params() returns a ref which means that calling routines can change the hash
 2305: for other routines.
 2306: Take a local copy before making amendments to the table if you don't want unexpected
 2307: things to happen.
 2308: 
 2309: =head1 SEE ALSO
 2310: 
 2311: =over 4
 2312: 
 2313: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-Info/coverage/>
 2314: 
 2315: =item * L<Object::Configure>
 2316: 
 2317: =item * L<HTTP::BrowserDetect>
 2318: 
 2319: =item * L<https://github.com/mitchellkrogza/apache-ultimate-bad-bot-blocker>
 2320: 
 2321: =back
 2322: 
 2323: =head1 REPOSITORY
 2324: 
 2325: L<https://github.com/nigelhorne/CGI-Info>
 2326: 
 2327: =head1 SUPPORT
 2328: 
 2329: This module is provided as-is without any warranty.
 2330: 
 2331: Please report any bugs or feature requests to C<bug-cgi-info at rt.cpan.org>,
 2332: or through the web interface at
 2333: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Info>.
 2334: I will be notified, and then you'll
 2335: automatically be notified of progress on your bug as I make changes.
 2336: 
 2337: You can find documentation for this module with the perldoc command.
 2338: 
 2339:     perldoc CGI::Info
 2340: 
 2341: You can also look for information at:
 2342: 
 2343: =over 4
 2344: 
 2345: =item * MetaCPAN
 2346: 
 2347: L<https://metacpan.org/dist/CGI-Info>
 2348: 
 2349: =item * RT: CPAN's request tracker
 2350: 
 2351: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Info>
 2352: 
 2353: =item * CPAN Testers' Matrix
 2354: 
 2355: L<http://matrix.cpantesters.org/?dist=CGI-Info>
 2356: 
 2357: =item * CPAN Testers Dependencies
 2358: 
 2359: L<http://deps.cpantesters.org/?module=CGI::Info>
 2360: 
 2361: =back
 2362: 
 2363: =head1 LICENCE AND COPYRIGHT
 2364: 
 2365: Copyright 2010-2026 Nigel Horne.
 2366: 
 2367: Usage is subject to licence terms.
 2368: 
 2369: The licence terms of this software are as follows:
 2370: 
 2371: =over 4
 2372: 
 2373: =item * Personal single user, single computer use: GPL2
 2374: 
 2375: =item * All other users (including Commercial, Charity, Educational, Government)
 2376:   must apply in writing for a licence for use from Nigel Horne at the
 2377:   above e-mail.
 2378: 
 2379: =back
 2380: 
 2381: =cut
 2382: 
 2383: 1;