view release on metacpan or  search on metacpan

lib/CGI/Buffer.pm  view on Meta::CPAN

		return 0;
	}
	unless($cobject->value($key)) {
		if($logger) {
			$logger->warn('is_cached: object is in the cache but not the data');
		}
		$cobject = undef;
		return 0;
	}

	# If the script has changed, don't use the cache since we may produce
	# different output
	my $age = _my_age();
	unless(defined($age)) {
		if($logger) {
			$logger->debug("Can't determine script's age");
		}
		# Can't determine the age. Play it safe an assume we're not
		# cached
		$cobject = undef;
		return 0;
	}
	if($age > $cobject->created_at()) {
		# Script has been updated so it may produce different output
		if($logger) {
			$logger->debug('Script has been updated');
		}
		$cobject = undef;
		# Nothing will be in date and all new searches would miss
		# anyway, so may as well clear it all
		# FIXME: RT104471
		# $cache->clear();
		return 0;
	}
	if($logger) {
		$logger->debug('Script is in the cache');
	}
	return 1;
}

# Determine the last modification time of the script and cache it for subsequent calls
sub _my_age {
	if($script_mtime) {
		return $script_mtime;
	}
	unless(defined($info)) {
		if($cache) {
			$info = CGI::Info->new({ cache => $cache })
				or croak 'Failed to create CGI::Info object with cache';
		} else {
			$info = CGI::Info->new() or croak 'Failed to create CGI::Info object';
		}
	}

	my $path = $info->script_path();
	unless(defined($path)) {
		croak 'Failed to retrieve script path';
		return;
	}

	my @statb = stat($path);
	$script_mtime = $statb[9];	# Set script_mtime to the modification time of the script
	return $script_mtime;
}

sub _should_gzip
{
	if($compress_content && ($ENV{'HTTP_ACCEPT_ENCODING'} || $ENV{'HTTP_TE'})) {
		if(scalar(@content_type)) {
			if($content_type[0] ne 'text') {
				return '';
			}
		}
		my $accept = lc($ENV{'HTTP_ACCEPT_ENCODING'} ? $ENV{'HTTP_ACCEPT_ENCODING'} : $ENV{'HTTP_TE'});
		foreach my $method(split(/,\s?/, $accept)) {
			if(($method eq 'gzip') || ($method eq 'x-gzip') || ($method eq 'br') || ($method eq 'zstd')) {
				return $method;
			}
		}
	}

	return '';
}

sub _set_content_type
{
	my $headers = shift;

	foreach my $header (split(/\r?\n/, $headers)) {
		my ($header_name, $header_value) = split /\:\s*/, $header, 2;
		if (lc($header_name) eq 'content-type') {
			@content_type = split /\//, $header_value, 2;
			last;
		}
	}
}

sub _compress {
	my %params = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
	return unless defined $body;

	my $encoding = $params{encoding};
	return if(!$encoding || length($body) < $MIN_GZIP_LEN);

	# Ensure UTF-8 encoding is handled
	my $encode_utf8 = sub {
		# Avoid 'Wide character in memGzip'
		# state $encode_loaded = do {
			# require Encode;
			# 1;
		# };
		require Encode;
		Encode::encode_utf8(shift);
	};

	# Common logic for setting headers
	my $set_headers = sub {
		my $encoding = shift;
		push @o, "Content-Encoding: $encoding", 'Vary: Accept-Encoding';
	};