Revision 139ae60d
Von Sven Schöling vor mehr als 4 Jahren hinzugefügt
| SL/Response.pm | ||
|---|---|---|
|
package SL::Response;
|
||
|
|
||
|
use strict;
|
||
|
use parent qw(Rose::Object);
|
||
|
use Carp;
|
||
|
use SL::MoreCommon qw(listify);
|
||
|
|
||
|
use Rose::Object::MakeMethods::Generic (
|
||
|
scalar => [ qw(status location content_type) ],
|
||
|
'scalar --get_set_init' => [ qw(cookie) ],
|
||
|
);
|
||
|
|
||
|
my %status_codes = (
|
||
|
200 => 'OK',
|
||
|
201 => 'Created',
|
||
|
202 => 'Accepted',
|
||
|
302 => 'Found',
|
||
|
303 => 'See Other',
|
||
|
307 => 'Temporary Redirect',
|
||
|
401 => 'Unauthorized',
|
||
|
403 => 'Forbidden',
|
||
|
404 => 'Not Found',
|
||
|
418 => "I'm a teapot",
|
||
|
);
|
||
|
|
||
|
my %supported_generic_header_fields = (
|
||
|
charset => 'Charset',
|
||
|
content_length => 'Content-Length',
|
||
|
transfer_encoding => 'Transfer-Encoding',
|
||
|
connection => 'Connection',
|
||
|
);
|
||
|
|
||
|
my %cookie_args = (
|
||
|
domain => 1,
|
||
|
path => 1,
|
||
|
expires => 1,
|
||
|
"max-age" => 1,
|
||
|
secure => 0,
|
||
|
HttpOnly => 0,
|
||
|
);
|
||
|
|
||
|
my $crlf = "\015\012";
|
||
|
|
||
|
sub header {
|
||
|
my ($self, %header) = @_;
|
||
|
|
||
|
my @header;
|
||
|
|
||
|
# these three must come first
|
||
|
my $content_type = delete $header{content_type} // $self->content_type;
|
||
|
push @header, "Content-Type: $content_type" if defined $content_type;
|
||
|
|
||
|
my $status = delete $header{status} // $self->status;
|
||
|
croak "Unsupported HTTP Status: $status" if defined $status && !$status_codes{$status};
|
||
|
push @header, "Status: $status $status_codes{$status}" if defined $status;
|
||
|
|
||
|
my $location = delete $header{location} // $self->location;
|
||
|
push @header, "Location: $location" if defined $location;
|
||
|
|
||
|
# handle more than one cookie
|
||
|
my @cookies = (listify(delete $header{cookie}), listify($self->cookie));
|
||
|
push @header, "Set-Cookie: $_" for @cookies;
|
||
|
|
||
|
# content-disposition has some weird syntax from RFC1806
|
||
|
my $attachment = delete $header{attachment};
|
||
|
push @header, qq|Content-Disposition: attachment; filename="$attachment"| if defined $attachment;
|
||
|
|
||
|
# process the rest
|
||
|
for my $field (keys %header) {
|
||
|
my $keyword = $supported_generic_header_fields{$field} or croak "unknown header '$field'";
|
||
|
push @header, "$keyword: $header{$field}";
|
||
|
}
|
||
|
|
||
|
return join $crlf, @header, '', '';
|
||
|
}
|
||
|
|
||
|
sub redirect {
|
||
|
my ($self, $url, %params) = @_;
|
||
|
$self->header(%params, status => 302, location => $url);
|
||
|
}
|
||
|
|
||
|
sub add_cookie {
|
||
|
my ($self, $name, $value, %args) = @_;
|
||
|
|
||
|
# we don't care that cookies can have more than one value. if you need it, implement it.
|
||
|
# we also don't care that technically you have to url encode cookies. simply don't put unicode in cookies.
|
||
|
|
||
|
my @cookie = "$name=$value";
|
||
|
|
||
|
for (keys %args) {
|
||
|
my $need_argument = $cookie_args{$_};
|
||
|
croak "unknown cookie argument '$_'" unless defined $need_argument;
|
||
|
push @cookie, $need_argument ? "$_=$args{$_}" : (($_) x !!$args{$_});
|
||
|
}
|
||
|
|
||
|
push @{ $self->{cookie} //= [] }, join '; ', @cookie;
|
||
|
}
|
||
|
|
||
|
sub init_cookie { [] }
|
||
|
|
||
|
1;
|
||
|
|
||
|
__END__
|
||
|
|
||
|
=encoding utf-8
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
SL::Response - reponse helper and aggregator
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use SL::Response;
|
||
|
my $r = SL::Respone->new
|
||
|
|
||
|
$r->add_cookie("name", "value", secure => 1, path => $path);
|
||
|
$r->redirect($url);
|
||
|
$r->header(
|
||
|
content_type => 'text/html',
|
||
|
charset => 'UTF-8',
|
||
|
...
|
||
|
);
|
||
|
|
||
|
$r->content_type('text/json');
|
||
|
$r->status(502);
|
||
|
$r->header;
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
Introduced mainly to get rid of L<CGI.pm>. Also meant to abstract response
|
||
|
header generation, and one day maybe be able to handle all STDOUT printing.
|
||
|
After that we can add more bindings to PSGI or a standalone server.
|
||
|
|
||
|
=head1 ATTRIBUTES
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item * C<status>
|
||
|
|
||
|
=item * C<location>
|
||
|
|
||
|
=item * C<content_type>
|
||
|
|
||
|
These three are used for the upcoming response and can be set beforehand.
|
||
|
|
||
|
=item * C<cookie>
|
||
|
|
||
|
Aggregator for cookies. Returns an arrayref. Should be filled with
|
||
|
L</add_cookie>. Aggregated cookies will be added to all generated headers,
|
||
|
including redirects.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 METHODS
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item * C<header PARAMS>
|
||
|
|
||
|
Generates a header and returns it as octet stream.
|
||
|
|
||
|
Known arguments:
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item * C<content_type>
|
||
|
|
||
|
Corresponds to C<Content-Type>
|
||
|
|
||
|
=item * C<status>
|
||
|
|
||
|
Corresponds to C<Status>
|
||
|
|
||
|
=item * C<location>
|
||
|
|
||
|
Corresponds to C<Location>
|
||
|
|
||
|
=item * C<cookie>
|
||
|
|
||
|
Corresponds to C<Set-Cookie>. Can be arrayref or single value but must contain
|
||
|
valid arguments for the HTTP C<Set-Cookie> header. If cookies have been added
|
||
|
to the response object before, both will be added.
|
||
|
|
||
|
=item * C<attachment>
|
||
|
|
||
|
Corresponds to C<Content-Disposition: attachemnt>. The argument will be added as the filename.
|
||
|
|
||
|
=item * C<charset>
|
||
|
|
||
|
Corresponds to C<Charset>
|
||
|
|
||
|
=item * C<content_length>
|
||
|
|
||
|
Corresponds to C<Content-Length>
|
||
|
|
||
|
=item * C<transfer_encoding>
|
||
|
|
||
|
Corresponds to C<Transfer-Encoding>
|
||
|
|
||
|
=item * C<connection>
|
||
|
|
||
|
Corresponds to C<Connection>
|
||
|
|
||
|
=back
|
||
|
|
||
|
=item * C<redirect URL PARAMS>
|
||
|
|
||
|
Calls header with status code 302 and the location specified by the C<url>
|
||
|
parameter.
|
||
|
|
||
|
=item * C<add_cookie PARAMS>
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 BUGS
|
||
|
|
||
|
None yet :)
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Sven Schöling E<lt>s.schoeling@googlemail.comE<gt>
|
||
|
|
||
|
=cut
|
||
Auch abrufbar als: Unified diff
SL::Response - neues response objekt