File Coverage

blib/lib/Servlet/Http/HttpServlet.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# -*- Mode: Perl; indent-tabs-mode: nil; -*-

package Servlet::Http::HttpServlet;

use base qw(Servlet::GenericServlet);
use strict;
use warnings;

use Servlet::ServletException ();
use Servlet::Http::HttpServletResponse ();

use constant METHOD_DELETE => 'DELETE';
use constant METHOD_HEAD => 'HEAD';
use constant METHOD_GET => 'GET';
use constant METHOD_OPTIONS => 'OPTIONS';
use constant METHOD_POST => 'POST';
use constant METHOD_PUT => 'PUT';
use constant METHOD_TRACE => 'TRACE';

use constant HEADER_IFMODSINCE => 'If-Modified-Since';
use constant HEADER_LASTMOD => 'Last-Modified';

sub new {
    my $self = shift;

    $self = fields::new($self) unless ref $self;
    $self->SUPER::new(@_);

    return $self;
}

sub doDelete {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my $msg = 'HTTP method DELETE is not supported';
    my $protocol = $request->getProtocol();
    my $code;
    if ($protocol =~ /1\.1$/) {
        $code = Servlet::Http::HttpServletResponse::SC_METHOD_NOT_ALLOWED;
    } else {
        $code = Servlet::Http::HttpServletResponse::SC_BAD_REQUEST;
    }

    $response->sendError($code, $msg);

    return 1;
}

sub doGet {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my $method = $request->getMethod();
    my $msg = "HTTP method $method is not supported";
    my $protocol = $request->getProtocol();
    my $code;
    if ($protocol =~ /1\.1$/) {
        $code = Servlet::Http::HttpServletResponse::SC_METHOD_NOT_ALLOWED;
    } else {
        $code = Servlet::Http::HttpServletResponse::SC_BAD_REQUEST;
    }

    $response->sendError($code, $msg);

    return 1;
}

sub doHead {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    # use a response wrapper that eats the output handle but sets the
    # content length appropriately

    my $noBodyResponse =
        Servlet::Http::HttpServlet::NoBodyResponse->new($response);

    $self->doGet($request, $noBodyResponse);
    $noBodyResponse->setContentLength();

    return 1;
}

sub doPost {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my $msg = 'HTTP method POST is not supported';
    my $protocol = $request->getProtocol();
    my $code;
    if ($protocol =~ /1\.1$/) {
        $code = Servlet::Http::HttpServletResponse::SC_METHOD_NOT_ALLOWED;
    } else {
        $code = Servlet::Http::HttpServletResponse::SC_BAD_REQUEST;
    }

    $response->sendError($code, $msg);

    return 1;
}

sub doOptions {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my @meth;

    # XXX: shouldn't be using can(), since it traverses the
    # inheritance tree, and we just want to examine the classes
    # that are descendents of HttpServlet

    if ($self->can('doDelete')) {
        push @meth, qw(DELETE);
    }
    if ($self->can('doGet')) {
        push @meth, qw(GET HEAD);
    }
    if ($self->can('doOptions')) {
        push @meth, qw(OPTIONS);
    }
    if ($self->can('doPost')) {
        push @meth, qw(POST);
    }
    if ($self->can('doPut')) {
        push @meth, qw(PUT);
    }
    if ($self->can('doTrace')) {
        push @meth, qw(TRACE);
    }

    $response->setHeader('Allow', join(', ', @meth));

    return 1;
}

sub doPut {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my $msg = 'HTTP method PUT is not supported';
    my $protocol = $request->getProtocol();
    my $code;
    if ($protocol =~ /1\.1$/) {
        $code = Servlet::Http::HttpServletResponse::SC_METHOD_NOT_ALLOWED;
    } else {
        $code = Servlet::Http::HttpServletResponse::SC_BAD_REQUEST;
    }

    $response->sendError($code, $msg);

    return 1;
}

sub doTrace {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    my $str = sprintf("TRACE %s %s\r\n",
                      $request->getRequestURI(),
                      $request->getProtocol());

    for my $name ($request->getHeaderNames()) {
        $str .= sprintf ("%s: %s\r\n", $name, $request->getHeader($name));
    }

    $response->setContentType('message/http');
    $response->setContentLength(length($str));
    my $out = $response->getOutputHandle();
    $out->print($str);
    $out->close();

    return 1;
}

sub getLastModified {
    my $self = shift;
    my $request = shift;

    return -1;
}

sub service {
    my $self = shift;
    my $request = shift;
    my $response = shift;

    unless ($request->isa('Servlet::Http::HttpServletRequest') &&
            $response->isa('Servlet::Http::HttpServletResponse')) {
        my $msg = 'non-HTTP request or response';
        Servlet::ServletException->throw($msg);
    }

    my $method = $request->getMethod();

    if ($method eq METHOD_DELETE) {
        $self->doDelete($request, $response);
    } elsif ($method eq METHOD_GET) {
        my $lastmod = $self->getLastModified($request);
        if ($lastmod == -1) {
            $self->doGet($request, $response);
        } else {
            my $ifmodsince = $request->getDateHeader(HEADER_IFMODSINCE);
            if ($ifmodsince < ($lastmod / 1000 * 1000)) {
                $self->maybeSetLastModified($response, $lastmod);
                $self->doGet($request, $response);
            } else {
                my $code = Servlet::Http::HttpServletResponse::SC_NOT_MODIFIED;
                $response->setStatus($code);
            }
        }
    } elsif ($method eq METHOD_HEAD) {
        my $lastmod = $self->getLastModified($request);
        $self->maybeSetLastModified($response, $lastmod);
        $self->doHead($request, $response);
    } elsif ($method eq METHOD_OPTIONS) {
        $self->doOptions($request, $response);
    } elsif ($method eq METHOD_POST) {
        $self->doPost($request, $response);
    } elsif ($method eq METHOD_PUT) {
        $self->doPut($request, $response);
    } elsif ($method eq METHOD_TRACE) {
        $self->doTrace($request, $response);
    } else {
        my $msg = "HTTP method $method is not supported";
        my $code = Servlet::Http::HttpServletResponse::SC_NOT_IMPLEMENTED;
        $response->sendError($code, $msg);
    }

    return 1;
}

sub maybeSetLastModified {
    my $self = shift;
    my $response = shift;
    my $lastmod = shift;

    # don't set the header if it's already been set
    return 1 if $response->containsHeader(HEADER_LASTMOD);

    $response->setDateHeader(HEADER_LASTMOD, $lastmod) if $lastmod >= 0;

    return 1;
}

1;

package Servlet::Http::HttpServlet::NoBodyResponse;

use base qw(Servlet::Http::HttpServletResponseWrapper);
use fields qw(output writer didSetContentLength);
use strict;
use warnings;

# simple response wrapper class that gets content length from output
# handle class

sub new {
    my $self = shift;

    $self = fields::new($self) unless ref $self;
    $self->SUPER::new(@_);

    $self->{output} = Servlet::Http::HttpServlet::NoBodyOutputHandle->new();
    $self->{writer} = undef;
    $self->{didSetContentLength} = undef;

    return $self;
}

sub setContentLength {
    my $self = shift;
    my $len = shift;

    if ($len) {
        $self->{response}->setContentLength($len);
        $self->{didSetContentLength} = 1;
    } else {
        unless ($self->{didSetContentLength}) {
            my $len = $self->{output}->getContentLength();
            $self->{response}->setContentLength($len);
        }
    }

    return 1;
}

sub getOutputHandle {
    my $self = shift;

    return $self->{output};
}

sub getWriter {
    my $self = shift;

    unless ($self->{writer}) {
        # XXX
        return $self->{output};
    }

    return $self->{writer};
}

1;

package Servlet::Http::HttpServlet::NoBodyOutputHandle;

use base qw(IO::Handle);
use fields qw(contentLength);
use strict;
use warnings;

# simple output handle class that eats the output data but calculates
# content length correctly

sub new {
    my $self = shift;

    $self = $self->SUPER::new(@_);
    ${*self}{servlet_http_httpservlet_nobodyoutputhandle_contentlength} = 0;

    return $self;
}

sub getContentLength {
    my $self = shift;

    return ${*self}{servlet_http_httpservlet_nobodyoutputhandle_contentlength};
}

sub print {
    my $self = shift;

    return $self->write(@_);
}

sub write {
    my $self = shift;
    my $str = shift;
    my $len = shift || length $str;

    ${*self}{servlet_http_httpservlet_nobodyoutputhandle_contentlength} +=
        $len;

    return 1;
}

1;
__END__