File Coverage

blib/lib/REST/Application.pm

Criterion	Covered	Total	%
statement	236	245	96.3
branch	79	96	82.2
condition	26	34	76.4
subroutine	49	51	96.0
pod	19	35	54.2
total	409	461	88.7

# vi:ai:sm:et:sw=4:ts=4:tw=0
#
# REST::Application - A framework for building RESTful web-applications.
#
# Copyright 2005 Matthew O'Connor
package REST::Application;
use strict;
use warnings;
use Carp;
use Tie::IxHash;
use UNIVERSAL;
use CGI;

our $VERSION = '0.992';

####################
# Class Methods
####################

sub new {
    my ($proto, %args) = @_;
    my $class = ref($proto) ? ref($proto) : $proto;
    my $self = bless({ __defaultQuery => CGI->new() }, $class);
    $self->setup(%args);
    return $self;
}

##################################
# Instance Methods - Object State
##################################

sub query {
    my $self = shift;

    # Set default value if this method hasn't been called yet.
    if (not exists $self->{__query}) {
        $self->{__query} = $self->defaultQueryObject();
    }

    # Set the field if we got any arguments.
    $self->{__query} = shift if @_;

    return $self->{__query};
}

sub defaultQueryObject {
    my $self = shift;

    # Set the field if we got any arguments.
    if (@_) {
        $self->{__defaultQuery} = shift;
    }

    return $self->{__defaultQuery};
}

sub resourceHooks {
    my $self = shift;

    # Set default value if this method hasn't been called yet.
    if (not exists $self->{__resourceHooks}) {
        my %hooks;
        tie(%hooks, "Tie::IxHash");  # For keeping hash key order preserved.
        $self->{__resourceHooks} = \%hooks;
    }

    # If we got arguments then they should be an even sized list, otherwise a
    # hash reference.
    if (@_ and @_%2 == 0) {
        %{ $self->{__resourceHooks} } = @_;
    } elsif (@_ == 1) {
        my $value = shift;
        if (ref($value) ne 'HASH') {
            croak "Expected hash reference or even-sized list.";
        }
        %{ $self->{__resourceHooks} } = %$value;
    }

    return $self->{__resourceHooks};
}

sub extraHandlerArgs {
    my $self = shift;

    # Set default value for method if it hasn't been called yet.
    if (not exists $self->{__extraHandlerArgs}) {
        $self->{__extraHandlerArgs} = [];
    }

    # If got arguments then process them.  We expect either a single array
    # reference or a list
    if (@_) {
        if (@_ == 1 and ref($_[0]) eq 'ARRAY') {
            $self->{__extraHandlerArgs} = shift;
        } else {
            $self->{__extraHandlerArgs} = [ @_ ];
        }
    }

    return @{ $self->{__extraHandlerArgs} };
}

##################################
# Instance Methods - Proxies
##################################

sub getPathInfo {
    my $self = shift;
    return $self->query->path_info();
}

sub getRealRequestMethod {
    my $self = shift;
    return uc( $self->query->request_method() || "" );
}

sub getRequestMethod {
    my $self          = shift;
    my $real_method   = $self->getRealRequestMethod();
    my $tunnel_method = uc(
               $self->query->http('X-HTTP-Method')
            || $self->query->url_param('http_method')
            || $self->query->param('http_method')
            || $real_method
    );

    # POST can tunnel any method.
    return $tunnel_method if $real_method eq 'POST';

    # GET can only tunnel GET/HEAD
    if ( $real_method eq 'GET' and $tunnel_method =~ /^(GET|HEAD)$/ ) {
        return $tunnel_method;
    }

    return $real_method;
}

#############################
# Instance Methods - Public
#############################

sub loadResource {
    my ($self, $path, @extraArgs) = @_;
    $path ||= $self->getMatchText();
    my $handler = sub { $self->defaultResourceHandler(@_) };
    my $matches = [];

    # Loop through the keys of the hash returned by resourceHooks().  Each of
    # the keys is a regular expression, see if the current path info matches
    # that regular expression.  Save the parent matches for passing into the
    # handler.
    for my $pathRegex (keys %{ $self->resourceHooks() }) {
        if ($self->checkMatch($path, $pathRegex)) {
            $handler = $self->_getHandlerFromHook($pathRegex);
            last;
        }
    }

    return $self->callHandler($handler, @extraArgs);
}

sub getHandlerArgs {
    my ($self, @extraArgs) = @_;
    my @args = ($self,
                $self->_getLastRegexMatches(),
                $self->extraHandlerArgs(),
                @extraArgs);

    # Don't make $self the first argument if the handler is a method on $self,
    # because in that case it'd be redundant.  Also see _getHandlerFromHook().
    shift @args if $self->{__handlerIsOurMethod};

    return @args;
}

sub callHandler {
    my ($self, $handler, @extraArgs) = @_;
    my @args = $self->getHandlerArgs(@extraArgs);

    # Call the handler, carp if something goes wrong.
    my $result;
    eval {
        $self->preHandler(\@args);  # no-op by default.
        $result = $handler->(@args);
        $self->postHandler(\$result, \@args); # no-op by default.
    };
    carp "Handler failed: $@\n" if $@;

    # Convert the result to a scalar result if it isn't already.
    my $ref = (ref($result) eq 'scalar') ? $result : \$result;

    return $ref;
}

sub getMatchText {
    my $self = shift;
    return $self->getPathInfo();
}

sub checkMatch {
    my ($self, $a, $b) = @_;
    my $match = 0;

    if ($a =~ /$b/) {
        $self->_setLastRegexMatches();
        $self->{__last_match_path} = $a;
        $self->{__last_match_pattern} = $b;
        $match = 1;
    }

    return $match;
}

sub getLastMatchPath {
    my $self = shift;
    return $self->{__last_match_path};
}

sub getLastMatchPattern {
    my $self = shift;
    return $self->{__last_match_pattern};
}

sub run {
    my $self = shift;

    # Get resource.
    $self->preRun(); # A no-op by default.
    my $repr = $self->loadResource(@_);
    $self->postRun($repr); # A no-op by default.

    # Get the headers and then add the representation to to the output stream.
    my $output = $self->getHeaders();
    $self->addRepresentation($repr, \$output);

    # Send the output unless we're told not to by the environment.
    print $output if not $ENV{REST_APP_RETURN_ONLY};

    return $output;
}

sub getHeaders {
    my $self = shift;
    my $type = $self->headerType() || "";
    my $header = "";

    if ($type eq 'header') {
        $header = $self->query->header($self->header());
    } elsif ($type eq 'redirect') {
        $header = $self->query->redirect($self->header());
    } elsif ($type ne 'none') {
        croak "Unexpected header type: \"$type\".";
    }

    return $header;
}

sub addRepresentation {
    my ($self, $repr, $outputRef) = @_;

    # Make sure $outputRef is a scalar ref and the scalar it references is
    # defined.
    return if ref($outputRef) ne 'SCALAR';
    return if not defined $$outputRef;

    # If we're given a scalar reference then dereference it first, otherwise
    # just treat what we got as though it's a string.
    if (ref($repr) eq 'SCALAR') {
        $$outputRef .= $$repr if defined $$repr;
    } else {
        $$outputRef .= $repr if defined $repr;
    }
}

sub headerType {
    my $self = shift;

    # Set the default value if this method has not been called yet.
    if (not exists $self->{__headerType}) {
        $self->{__headerType} = "header";
    }

    # If an argument was passed in then use them to set the header type.
    if (@_) {
        my $type = lc(shift || "");
        if ($type =~ /^(redirect|header|none)$/) {
            $self->{__headerType} = $type;
        } else {
            croak "Invalid header type specified: \"$type\"";
        }
    }

    return $self->{__headerType};
}

sub header {
    my $self = shift;

    # Set the default value if this method has not been called yet.
    if (not exists $self->{__header}) {
        $self->{__header} = {};
    }

    # If arguments were passed in then use them to set the header type.
    # Arguments can be passed in as a hash-ref or as an even sized list.
    if (@_) {
        if (@_%2 == 0) { # even-sized list, must be hash
            %{ $self->{__header} } = @_;
        } elsif (ref($_[0]) eq 'HASH') {  # First item must be a hash reference
            $self->{__header} = shift;
        } else {
            croak "Expected even-sized list or hash reference.";
        }
    }

    return %{$self->{__header}};
}

sub resetHeader {
    my $self = shift;
    my %old = $self->header();
    $self->headerType('header');
    $self->{__header} = {};
    return %old;
}

sub setRedirect {
    my ($self, $url) = @_;
    $self->headerType('redirect');
    $self->header(-url => $url || "");
}

##############################################
# Instance Methods - Intended for Overloading
##############################################

sub setup { return }
sub preRun { return }
sub postRun{ return }
sub preHandler { return }
sub postHandler { return }
sub defaultResourceHandler { return }

#############################
# Instance Methods - Private
#############################

# CodeRef _getHandlerFromHook(String $pathRegex)
#
# This method retrieves a code reference which will yield the resource of the
# given $pathRegex, where $pathRegex is a key into the resource hooks hash (it
# isn't used as a regex in this method, just a hash key).
sub _getHandlerFromHook {
    my ($self, $pathRegex) = @_;
    my $ref = $self->resourceHooks()->{$pathRegex};
    my $refType = ref($ref);
    my $handler = sub { $self->defaultResourceHandler(@_) };
    my $method = $self->getRequestMethod() || "getResource";

    # If we get a hash, then use the request method to narrow down the choice.
    # We do this first because we allow the same range of handler types for a
    # particular HTTP method that we do for a more generic handler.
    if ($refType eq 'HASH') {
        %$ref = map { uc($_) => $ref->{$_} } keys %$ref;  # Uppercase the keys
        my $http_method = $self->getRequestMethod();
        if (exists $ref->{$http_method}) {
            $ref = $ref->{$http_method}
        } elsif (exists $ref->{'*'}) {
            $ref = $ref->{'*'};
        } else {
            return $handler;  # Just bail now with the default handler.
        }
        $refType = ref($ref);
    }

    # If we still have a hash then assume we're doing Content Negotation
    if ($refType eq 'HASH') {
        my $type = $self->bestContentType(keys %$ref);
        $ref = $ref->{$type};
        $refType = ref($ref);
    }

    # Based on the the reference's type construct the handler.
    if ($refType eq "CODE") {
        # A code reference
        $handler = $ref;
    } elsif ($refType eq "ARRAY") {
        # Array reference which holds a $object and "method name" pair.
        my ($thing, $smethod) = @$ref;
        $smethod ||= $method;
        if (ref $thing) {
            $handler = $self->makeHandlerFromRef($thing, $smethod);
        } else {
            $handler = $self->makeHandlerFromClass($thing, $smethod);
        }
    } elsif ($refType) {
        # Object with GET, PUT, etc, or getResource method.
        $handler = $self->makeHandlerFromRef($ref, $method);
    } elsif ($ref) {
        # A bare string signifying a method name
        $handler = sub { $self->$ref(@_) };
        $self->{__handlerIsOurMethod} = 1;  # See callHandler().
    }

    return $handler;
}

sub makeHandlerFromRef {
    my ($self, $ref, $method) = @_;
    return sub { $ref->$method(@_) };
}

sub makeHandlerFromClass {
    my ($self, $class, $method) = @_;
    return sub { $class->$method(@_) };
}

sub bestContentType {
    my ($self, @types) = @_;
    return ($self->simpleContentNegotiation(@types))[0] || '*/*';
}

# We don't support the full range of content negtiation because a) it's
# overkill and b) it makes it hard to specify the hooks cleanly, also see (a).
sub simpleContentNegotiation {
    my ($self, @types) = @_;
    my @accept_types = $self->getContentPrefs();
    my $score = sub { $self->scoreType(shift, @accept_types) };
    return sort {$score->($b) <=> $score->($a)} @types;
}

# The pattern matching stuff was stolen from CGI.pm
sub scoreType {
    my ($self, $type, @accept_types) = @_;
    my $score = scalar(@accept_types);
    for my $accept_type (@accept_types) {
        return $score if $type eq $accept_type;
        my $pat;
        ($pat = $accept_type) =~ s/([^\w*])/\\$1/g; # escape meta characters
        $pat =~ s/\*/.*/g; # turn it into a pattern
        return $score if $type =~ /$pat/;
        $score--;
    }
    return 0;
}

# Basic idea stolen from CGI.pm.  Its semantics made it hard to pull out the
# information I wanted without a lot of trickery, so I improved upon the
# original.  Same with libwww's HTTP::Negotiate algorithim, it's also hard to
# make go with what we want.
sub getContentPrefs {
    my $self = shift;
    my $default_weight = 1;
    my @prefs;

    # Parse the Accept header, and save type name, score, and position.
    my @accept_types = split /,/, $self->getAcceptHeader();
    my $order = 0;
    for my $accept_type (@accept_types) {
        my ($weight) = ($accept_type =~ /q=(\d\.\d+|\d+)/);
        my ($name) = ($accept_type =~ m#(\S+/[^;]+)#);
        next unless $name;
        push @prefs, { name => $name, order => $order++};
        if (defined $weight) {
            $prefs[-1]->{score} = $weight;
        } else {
            $prefs[-1]->{score} = $default_weight;
            $default_weight -= 0.001;
        }
    }

    # Sort the types by score, subscore by order, and pull out just the name
    @prefs = map {$_->{name}} sort {$b->{score} <=> $a->{score} ||
                                    $a->{order} <=> $b->{order}} @prefs;
    return @prefs, '*/*';  # Allows allow for */*
}

sub getAcceptHeader {
    my $self = shift;
    return $self->query->http('accept') || "";
}

# List _getLastRegexMatches(void)
#
# Returns a list of all the paren matches in the last regular expression who's
# matches were saved with _saveLastRegexMatches().
sub _getLastRegexMatches {
    my $self = shift;
    my $matches = $self->{__lastRegexMatches} || [];
    return @$matches;
}

# ArrayRef _setLastRegexMatches(void)
#
# Grabs the values of $1, $2, etc. as set by the last regular expression to run
# in the current dyanamic scope.  This of course exploits that $1, $2, etc. and
# @+ are dynamically scoped.  A reference to an array is returned where the
# array values are $1, $2, $3, etc.  _getLastRegexMatches() can also be used to
# retrieve the values saved by this method.
sub _setLastRegexMatches {
    my $self = shift;
    no strict 'refs'; # For the $$_ symbolic reference below.
    my @matches = map $$_, (1 ..  scalar(@+)-1);  # See "perlvar" for @+.
    $self->{__lastRegexMatches} = \@matches;
}

1;
__END__