File Coverage

blib/lib/Perlbal/XS/HTTPHeaders.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Perlbal::XS::HTTPHeaders;

use 5.008;
use strict;
use warnings;
use Carp;

require Exporter;
use AutoLoader;

use Perlbal;
use Perlbal::HTTPHeaders;

# inherit things from Perlbal::HTTPHeaders when we can
our @ISA = qw(Exporter Perlbal::HTTPHeaders);

# flag we set when we are enabled or disabled
our $Enabled = 0;

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use HTTPHeaders ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	H_REQUEST
	H_RESPONSE
	M_DELETE
	M_GET
	M_OPTIONS
	M_POST
	M_PUT
    M_HEAD
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	H_REQUEST
	H_RESPONSE
	M_DELETE
	M_GET
	M_OPTIONS
	M_POST
	M_PUT
    M_HEAD
);

our $VERSION = '0.20';

sub AUTOLOAD {
    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.

    my $constname;
    our $AUTOLOAD;
    ($constname = $AUTOLOAD) =~ s/.*:://;
    croak "&Perlbal::XS::HTTPHeaders::constant not defined" if $constname eq 'constant';
    my ($error, $val) = constant($constname);
    if ($error) { croak $error; }
    {
	no strict 'refs';
	# Fixed between 5.005_53 and 5.005_61
#XXX	if ($] >= 5.00561) {
#XXX	    *$AUTOLOAD = sub () { $val };
#XXX	}
#XXX	else {
	    *$AUTOLOAD = sub { $val };
#XXX	}
    }
    goto &$AUTOLOAD;
}

require XSLoader;
XSLoader::load('Perlbal::XS::HTTPHeaders', $VERSION);

# create a very bare response to send to a user (mostly used internally)
sub new_response {
    my $code = $_[1];

    my $msg = $Perlbal::HTTPHeaders::HTTPCode->{$code} || "";
    my $hdr = Perlbal::XS::HTTPHeaders->new(\"HTTP/1.0 $code $msg\r\n\r\n");
    return $hdr;
}

# do some magic to determine content length
sub content_length {
    my Perlbal::XS::HTTPHeaders $self = $_[0];

    if ($self->isRequest()) {
        return 0 if $self->getMethod() == M_HEAD();
    } else {
        my $code = $self->getStatusCode();
        if ($code == 304 || $code == 204 || ($code >= 100 && $code <= 199)) {
            return 0;
        }
    }

    if (defined (my $clen = $self->getHeader('Content-length'))) {
        return $clen+0;
    }

    return undef;
}

sub set_version {
    my Perlbal::XS::HTTPHeaders $self = $_[0];
    my $ver = $_[1];

    die "Bogus version" unless $ver =~ /^(\d+)\.(\d+)$/;

    my ($ver_ma, $ver_mi) = ($1, $2);
    $self->setVersionNumber($ver_ma * 1000 + $ver_mi);

    return $self;
}

sub clone {
    return Perlbal::XS::HTTPHeaders->new( $_[0]->to_string_ref );
}

### Perlbal::XS interface implementation
my @subs = qw{
    new new_response DESTROY getReconstructed getHeader setHeader
    getMethod getStatusCode getVersionNumber setVersionNumber isRequest
    isResponse setStatusCode getURI setURI header to_string to_string_ref
    code request_method request_uri headers_list set_request_uri response_code
    res_keep_alive req_keep_alive set_version content_length clone
    http_code_english
};

sub enable {
    return 1 if $Enabled;
    $Enabled = 1;
    *Perlbal::HTTPHeaders::new = *Perlbal::XS::HTTPHeaders::new;
    *Perlbal::HTTPHeaders::new_response = *Perlbal::XS::HTTPHeaders::new_response;
    return 1;
}

sub disable {
    return unless $Enabled;
    *Perlbal::HTTPHeaders::new_response = *Perlbal::HTTPHeaders::new_response_PERL;
    *Perlbal::HTTPHeaders::new = *Perlbal::HTTPHeaders::new_PERL;
    $Enabled = 0;
    return 1;
}

sub code {
    my Perlbal::XS::HTTPHeaders $self = shift;

    my ($code, $msg) = @_;
    $msg ||= $self->http_code_english($code);
    $self->setCodeText($code, $msg);
}

# save pointer to the old way of creating new objects
$Perlbal::XSModules{headers} = 'Perlbal::XS::HTTPHeaders';
#enable();

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__