view release on metacpan or  search on metacpan

lib/REST/Application.pm  view on Meta::CPAN

            $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__
=pod

=head1 NAME

L<REST::Application> - A framework for building RESTful web-applications.

=head1 SYNOPSIS

    # MyRESTApp L<REST::Application> instance / mod_perl handler
    package MyRESTApp;
    use Apache;
    use Apache::Constants qw(:common);

    sub handler {
        __PACKAGE__->new(request => $r)->run();
        return OK;
    }
    
    sub getMatchText { return Apache->uri }

    sub setup {
        my $self = shift;
        $self->resourceHooks(
            qr{/rest/parts/(\d+)} => 'get_part',
            # ... other handlers here ...
        );
    }