view release on metacpan or  search on metacpan

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

	}
	if($generate_etag && ((!defined($headers)) || ($headers !~ /^ETag: /m))) {
		if(defined($etag)) {
			push @o, "ETag: $etag";
			if($logger) {
				$logger->debug("Set ETag to $etag");
			}
		} elsif($logger && (($status == 200) || $status == 304) && $body && !is_cached()) {
			$logger->warn("BUG: ETag not generated, status $status");
		}
	}

	my $body_length;
	if(defined($body)) {
		if(utf8::is_utf8($body)) {
			utf8::encode($body);
		}
		$body_length = length($body);
	} else {
		$body_length = 0;
	}

	if(defined($headers) && length($headers)) {
		# Put the original headers first, then those generated within
		# CGI::Buffer
		unshift @o, split(/\r\n/, $headers);
		if($body && $send_body) {
			if(scalar(grep(/^Content-Length: \d/, @o)) == 0) {
				push @o, "Content-Length: $body_length";
			}
		}
		if(scalar(grep(/^Status: \d/, @o)) == 0) {
			require HTTP::Status;
			HTTP::Status->import();

			push @o, "Status: $status " . HTTP::Status::status_message($status);
			if($info) {
				$info->status($status);
			}
		}
	} else {
		push @o, "X-CGI-Buffer-$VERSION: No headers";
	}

	if($body_length && $send_body) {
		push @o, ('', $body);
	}

	# XXXXXXXXXXXXXXXXXXXXXXX
	if(0) {
		# This code helps to debug Wide character prints
		my $wideCharWarningsIssued = 0;
		my $widemess;
		$SIG{__WARN__} = sub {
			$wideCharWarningsIssued += "@_" =~ /Wide character in .../;
			$widemess = "@_";
			if($logger) {
				$logger->fatal($widemess);
				my $i = 1;
				$logger->trace('Stack Trace');
				while((my @call_details = (caller($i++)))) {
					$logger->trace($call_details[1] . ':' . $call_details[2] . ' in function ' . $call_details[3]);
				}
			}
			CORE::warn(@_);	# call the builtin warn as usual
		};

		if(scalar @o) {
			print join("\r\n", @o);
			if($wideCharWarningsIssued) {
				my $mess = join("\r\n", @o);
				$mess =~ /[^\x00-\xFF]/;
				open(my $fout, '>>', '/tmp/NJH');
				print $fout "$widemess:\n";
				print $fout $mess;
				print $fout 'x' x 40, "\n";
				close $fout;
			}
		}
	} elsif(scalar @o) {
		print join("\r\n", @o);
	}
	# XXXXXXXXXXXXXXXXXXXXXXX

	if((!$send_body) || !defined($body)) {
		print "\r\n\r\n";
	}
}

sub _check_modified_since {
	if($logger) {
		$logger->trace('In _check_modified_since');
	}

	if(!$generate_304) {
		return;
	}
	my $params = shift;

	if(!defined($$params{since})) {
		return;
	}
	my $s = HTTP::Date::str2time($$params{since});
	if(!defined($s)) {
		# IF_MODIFIED_SINCE isn't a valid data
		return;
	}

	my $age = _my_age();
	if(!defined($age)) {
		return;
	}
	if($age > $s) {
		if($logger) {
			$logger->debug('_check_modified_since: script has been modified');
		}
		# Script has been updated so it may produce different output
		return;
	}

	if($logger) {

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

Items stay in the server-side cache by default for 10 minutes.
This can be overridden by the cache_control HTTP header in the request, and
the default can be changed by the cache_duration argument to init().

Logger will be an object that understands debug() such as an L<Log::Log4perl>
object.

To generate a last_modified header, you must give a cache object.

Init allows a reference of the options to be passed. So both of these work:
    use CGI::Buffer;
    #...
    CGI::Buffer::init(generate_etag => 1);
    CGI::Buffer::init({ generate_etag => 1, info => CGI::Info->new() });

Generally speaking, passing by reference is better since it copies less on to
the stack.

Alternatively you can give the options when loading the package:
    use CGI::Buffer { optimise_content => 1 };

=cut

sub init {
	my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;

	# Safe options - can be called at any time
	if(defined($params{generate_etag})) {
		$generate_etag = $params{generate_etag};
	}
	if(defined($params{generate_last_modified})) {
		$generate_last_modified = $params{generate_last_modified};
	}
	if(defined($params{compress_content})) {
		$compress_content = $params{compress_content};
	}
	if(defined($params{optimise_content})) {
		$optimise_content = $params{optimise_content};
	}
	if(defined($params{lint_content})) {
		$lint_content = $params{lint_content};
	}
	if(defined($params{logger})) {
		$logger = $params{logger};
	}
	if(defined($params{lingua})) {
		$lingua = $params{lingua};
	}
	if(defined($params{generate_304})) {
		$generate_304 = $params{generate_304};
	}
	if(defined($params{info}) && (!defined($info))) {
		$info = $params{info};
	}

	# Unsafe options - must be called before output has been started
	my $pos = $CGI::Buffer::buf->getpos;
	if($pos > 0) {
		if(defined($logger)) {
			my @call_details = caller(0);
			$logger->warn("Too late to call init, $pos characters have been printed, caller line $call_details[2] of $call_details[1]");
		} else {
			# Must do Carp::carp instead of carp for Test::Carp
			Carp::carp "Too late to call init, $pos characters have been printed";
		}
	}
	if(defined($params{cache}) && can_cache()) {
		if(defined($ENV{'HTTP_CACHE_CONTROL'})) {
			my $control = $ENV{'HTTP_CACHE_CONTROL'};
			if(defined($logger)) {
				$logger->debug("cache_control = $control");
			}
			if($control =~ /^max-age\s*=\s*(\d+)$/) {
				# There is an argument not to do this
				# since one client will affect others
				$cache_duration = "$1 seconds";
				if(defined($logger)) {
					$logger->debug("cache_duration = $cache_duration");
				}
			}
		}
		$cache_duration ||= $params{'cache_duration'};

		if($params{'cache_age'}) {
			# Legacy
			$cache_duration ||= $params{'cache_age'};
		}

		if((!defined($params{cache})) && defined($cache)) {
			if(defined($logger)) {
				if($cache_key) {
					$logger->debug("disabling cache $cache_key");
				} else {
					$logger->debug('disabling cache');
				}
			}
			$cache = undef;
		} else {
			$cache = $params{cache};
		}
		if(defined($params{cache_key})) {
			$cache_key = $params{cache_key};
		}
	}
}

sub import {
	# my $class = shift;
	shift;

	return unless @_;

	init(@_);
}

=head2 set_options

Synonym for init, kept for historical reasons.

=cut