Commit | Line | Data |
e601adda |
1 | # |
2 | # Catlyst::Action::SerializeBase.pm |
3 | # Created by: Adam Jacob, Marchex, <adam@marchex.com> |
4 | # |
5 | # $Id$ |
6 | |
7 | package Catalyst::Action::SerializeBase; |
8 | |
9 | use strict; |
10 | use warnings; |
11 | |
12 | use base 'Catalyst::Action'; |
13 | use Module::Pluggable::Object; |
14 | use Data::Dump qw(dump); |
15 | use HTTP::Headers::Util qw(split_header_words); |
16 | |
17 | __PACKAGE__->mk_accessors(qw(_serialize_plugins _loaded_plugins)); |
18 | |
19 | sub _load_content_plugins { |
20 | my $self = shift; |
21 | my ( $search_path, $controller, $c ) = @_; |
22 | |
23 | unless ( defined( $self->_loaded_plugins ) ) { |
24 | $self->_loaded_plugins( {} ); |
25 | } |
26 | |
27 | # Load the Serialize Classes |
28 | unless ( defined( $self->_serialize_plugins ) ) { |
29 | my @plugins; |
30 | my $mpo = |
31 | Module::Pluggable::Object->new( 'search_path' => [$search_path], ); |
32 | @plugins = $mpo->plugins; |
33 | $self->_serialize_plugins( \@plugins ); |
34 | } |
35 | |
36 | # First, we use the content type in the HTTP Request. It wins all. |
37 | my $content_type = $c->request->content_type || ''; |
38 | |
39 | # Second, we allow GET requests to tunnel the content-type as |
40 | # a query param. |
41 | if (!$content_type && $c->req->method eq "GET" && $c->req->param('content-type')) { |
42 | |
43 | $content_type = $c->req->param('content-type'); |
44 | } |
45 | |
46 | # Third, we parse the Accept header, and see if the client |
47 | # takes a format we understand. |
48 | # |
49 | # This is taken from chansen's Apache2::UploadProgress. |
50 | my $used_accept = 0; |
51 | if ( !$content_type && $c->request->header('Accept') ) { |
52 | my $accept_header = $c->request->header('Accept'); |
53 | my %accept = (); |
54 | my $counter = 0; |
55 | |
56 | foreach my $pair ( split_header_words($accept_header) ) { |
57 | |
58 | my ( $type, $qvalue ) = @{$pair}[ 0, 3 ]; |
59 | |
60 | unless ( defined $qvalue ) { |
61 | $qvalue = 1 - ( ++$counter / 1000 ); |
62 | } |
63 | |
64 | $accept{$type} = sprintf( '%.3f', $qvalue ); |
65 | } |
66 | |
67 | foreach my $type ( sort { $accept{$b} <=> $accept{$a} } keys %accept ) |
68 | { |
69 | |
70 | if ( exists $controller->config->{'serialize'}->{'map'}->{$type} ) |
71 | { |
72 | $content_type = $type; |
73 | last; |
74 | } |
75 | } |
76 | $used_accept = 1; |
77 | } |
78 | |
79 | # Finally, we load the class. If you have a default serializer, |
80 | # and we still don't have a content-type that exists in the map, |
81 | # we'll use it. |
82 | my $sclass = $search_path . "::"; |
83 | my $sarg; |
84 | my $map = $controller->config->{'serialize'}->{'map'}; |
85 | if ( exists( $map->{$content_type} ) ) { |
86 | my $mc; |
87 | if ( ref( $map->{$content_type} ) eq "ARRAY" ) { |
88 | $mc = $map->{$content_type}->[0]; |
89 | $sarg = $map->{$content_type}->[1]; |
90 | } else { |
91 | $mc = $map->{$content_type}; |
92 | } |
93 | # TODO: Handle custom serializers more elegantly.. this is a start, |
94 | # but how do we determine which is Serialize and Deserialize? |
95 | #if ($mc =~ /^+/) { |
96 | # $sclass = $mc; |
97 | # $sclass =~ s/^+//g; |
98 | #} else { |
99 | $sclass .= $mc; |
100 | #} |
101 | if ( !grep( /^$sclass$/, @{ $self->_serialize_plugins } ) ) { |
102 | return $self->_unsupported_media_type($c, $content_type); |
103 | } |
104 | } else { |
105 | if ( exists( $controller->config->{'serialize'}->{'default'} ) ) { |
106 | $sclass .= $controller->config->{'serialize'}->{'default'}; |
107 | } else { |
108 | return $self->_unsupported_media_type($c, $content_type); |
109 | } |
110 | } |
111 | unless ( exists( $self->_loaded_plugins->{$sclass} ) ) { |
112 | my $load_class = $sclass; |
113 | $load_class =~ s/::/\//g; |
114 | $load_class =~ s/$/.pm/g; |
115 | eval { require $load_class; }; |
116 | if ($@) { |
117 | $c->log->error( |
118 | "Error loading $sclass for " . $content_type . ": $!" ) |
119 | if $c->log->is_debug; |
120 | return $self->_unsupported_media_type($c, $content_type); |
121 | } else { |
122 | $self->_loaded_plugins->{$sclass} = 1; |
123 | } |
124 | } |
125 | |
126 | if ($search_path eq "Catalyst::Action::Serialize") { |
127 | if ($content_type) { |
128 | $c->response->header( 'Vary' => 'Content-Type' ); |
129 | } elsif ($used_accept) { |
130 | $c->response->header( 'Vary' => 'Accept' ); |
131 | } |
132 | $c->response->content_type($content_type); |
133 | } |
134 | |
135 | return $sclass, $sarg, $content_type; |
136 | } |
137 | |
138 | sub _unsupported_media_type { |
139 | my ( $self, $c, $content_type ) = @_; |
140 | $c->res->content_type('text/plain'); |
141 | $c->res->status(415); |
2224bad1 |
142 | if (defined($content_type) && $content_type ne "") { |
e601adda |
143 | $c->res->body( |
144 | "Content-Type " . $content_type . " is not supported.\r\n" ); |
145 | } else { |
146 | $c->res->body( |
147 | "Cannot find a Content-Type supported by your client.\r\n" ); |
148 | } |
149 | return undef; |
150 | } |
151 | |
152 | sub _serialize_bad_request { |
153 | my ( $self, $c, $content_type, $error ) = @_; |
154 | $c->res->content_type('text/plain'); |
155 | $c->res->status(400); |
156 | $c->res->body( |
157 | "Content-Type " . $content_type . " had a problem with your request.\r\n***ERROR***\r\n$error" ); |
158 | return undef; |
159 | } |
160 | |
161 | 1; |
162 | |
163 | =head1 NAME |
164 | |
165 | B<Catalyst::Action::SerializeBase> |
166 | |
167 | Base class for Catalyst::Action::Serialize and Catlayst::Action::Deserialize. |
168 | |
169 | =head1 DESCRIPTION |
170 | |
171 | This module implements the plugin loading and content-type negotiating |
172 | code for L<Catalyst::Action::Serialize> and L<Catalyst::Action::Deserialize>. |
173 | |
174 | =head1 SEE ALSO |
175 | |
176 | L<Catalyst::Action::Serialize>, L<Catalyst::Action::Deserialize>, |
177 | L<Catalyst::Controller::REST>, |
178 | |
179 | =head1 AUTHOR |
180 | |
181 | Adam Jacob <adam@stalecoffee.org>, with lots of help from mst and jrockway. |
182 | |
183 | Marchex, Inc. paid me while I developed this module. (http://www.marchex.com) |
184 | |
185 | =head1 LICENSE |
186 | |
187 | You may distribute this code under the same terms as Perl itself. |
188 | |
189 | =cut |
190 | |