File Coverage

blib/lib/REST/Resource.pm
Criterion Covered Total %
statement 159 208 76.4
branch 55 70 78.5
condition 10 16 62.5
subroutine 19 25 76.0
pod 15 15 100.0
total 258 334 77.2


line stmt bran cond sub pod time code
1             #----------------------------------------------------------------------
2             =pod
3              
4             =head1 NAME
5              
6             REST::Resource -- Provide base class functionality for RESTful servers.
7              
8             =head1 SYNOPSIS
9              
10             package My::Rest::Resource;
11             use base "REST::Resource";
12              
13             sub new
14             {
15             my( $class ) = shift;
16             my( $this ) = $this->SUPER::new( @_ );
17             $this->method( "PUT", \&Create, "This method handles the creation of My::Rest::Resource." );
18             $this->method( "GET", \&Read, "This method handles the reading of My::Rest::Resource." );
19             $this->method( "POST", \&Update, "This method handles the updating of My::Rest::Resource." );
20             $this->method( "DELETE",\&Delete, "This method handles the deletion of My::Rest::Resource." );
21             }
22              
23             sub Create { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
24             sub Read { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
25             sub Update { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
26             sub Delete { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
27              
28             package main;
29             use My::Rest::Resource;
30              
31             my( $restful ) = new My::Rest::Resource();
32             $restful->handle_request(); ## One-shot CGI Context
33              
34             =head1 DESCRIPTION
35              
36             This is a fork of WWW::Resource 0.01. The major changes are:
37              
38             [] Full OO implementation
39             [] Overt abstract base class design
40             [] Support of Perl 5.6
41             [] Support for use with CGI interface.
42             [] Support for HEAD and TRACE.
43             [] Method / handler registration to better support
44             application-semantics over REST-semantics.
45              
46             =head1 METHOD REGISTRATION
47              
48             HTTP method handlers should be members of your derived class and
49             expect $this (or $self) as the first parameter.
50              
51             sub Create { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
52             sub Read { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
53             sub Update { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
54             sub Delete { my( $this ) = shift; my( $request_interface_instance ) = shift; ... }
55              
56             =head1 REQUEST INTERFACE INSTANCE
57              
58             $request_interface_instance is a wrapper for your favorite Common
59             Gateway Interface implementation. Mine is CGI.pm for server-side
60             request interrogation and server-side response.
61              
62             If you don't like this, create a class modeled after REST::Request and
63             register it with:
64              
65             my( $restful ) = new REST::Resource( request_interface => new My::REST::Request() );
66              
67             The REST::Resource constructor will validate that My::REST::Request
68             implements the requisite methods new(), http(), param() and header()
69             and then only use these methods to interace with the Common Gateway
70             Interface variables.
71              
72             =head1 REQUESTED RETURNED CONTENT-TYPE:
73              
74             The requesting client is responsible for specifying the returned
75             Content-Type: header in one of two ways.
76              
77             [] Via the "Accept: application/xml" HTTP header.
78             [] Via the CGI query parameter ?format=xml
79              
80             The Accept: header is preferred as it is semantically cleaner, but the
81             CGI query parameter is also supported in recognition of the fact that
82             sometimes it is easier to affect the request URL than it is to get at
83             and specify the HTTP headers.
84              
85             =head1 DEFAULT SUPPORTED CONTENT TYPES
86              
87             The supported content types provided by the base class are:
88              
89             [] ?format=xml or Accept: application/xml
90             [] ?format=json or Accept: text/javascript
91             [] ?format=html or Accept: text/html
92              
93             HTML will be returned if the requestor appears to be a browser and no
94             format is specified.
95              
96             XML will be returned if the requestor does NOT appear to be a browser
97             and no format is specified.
98              
99             =head1 AUTHOR
100              
101             frotz@acm.org Fork of WWW::Resource into REST::Resource.
102              
103             =head1 CREDITS
104              
105             Ira Woodhead For his WWW::Resource implementation.
106              
107             =head1 BUGS
108              
109             In the spirit of Transparency, please use rt.cpan.org to file bugs.
110             This way everyone can see what bugs have been reported and what their
111             status is and hopefully the fixed-in release.
112              
113             =head1 METHODS
114              
115             =cut
116              
117             package REST::Resource;
118              
119 4     4   101762 use strict; ## Strict coding standards
  4         10  
  4         160  
120 4     4   21 use warnings; ## Very strict coding standards
  4         9  
  4         135  
121              
122 4     4   15032 use CGI qw( :standard );
  4         87387  
  4         32  
123 4     4   19259 use HTTP::Status; ## Mneumonic HTTP Status codes.
  4         16360  
  4         1422  
124 4     4   47776 use Data::Dumper; ## Output format: HTML
  4         19138  
  4         286  
125 4     4   2368 use REST::Request; ## Conditional CGI Request Support
  4         30  
  4         37  
126              
127 4     4   1315 eval "use XML::Dumper; import XML::Dumper; "; ## Conditional Output format: XML
  1         2  
  1         28  
128 4     4   13836 eval "use JSON; import JSON; "; ## Conditional Output format: JavaScript Object Notation
  4         64700  
  4         27  
129              
130             our( $VERSION ) = '0.5.2.4'; ## MODULE-VERSION-NUMBER
131              
132              
133              
134              
135             #----------------------------------------------------------------------
136             =pod
137              
138             =head2 new()
139              
140             USAGE:
141              
142             my( $restful ) = new REST::Resource();
143             $restful->method( "GET", \&get_handler );
144             $restful->handle_request();
145              
146             my( $restful ) = new REST::Resource( request_interface => new REST::Request() );
147              
148             DESCRIPTION:
149              
150             Create an instance of a REST::Resource, or one of its derived classes.
151              
152             If you need a specific implementation of the REST::Request interface,
153             pass it in as shown in the second constructor call.
154              
155             =cut
156              
157             sub new
158             {
159 15     15 1 5606 my( $class ) = shift;
160 15 100       78 $class = ref( $class ) if (ref( $class ));
161 15         49 my( %args ) = @_;
162 15         30 my( $args ) = \%args;
163 15         47 my( $this ) = bless( {}, $class );
164              
165 15 100       54 unless (exists( $args->{request_interface} ))
166             {
167 6         28 $args->{request_interface} = new REST::Request();
168             }
169 15         35 my( $request ) = $args->{request_interface};
170 15 100       76 unless (UNIVERSAL::can( $request, "http" ))
171             {
172 1         47 die( "Interface [$args->{request_interface}] does not implement required method: http()\n" );
173             }
174 14 100       71 unless (UNIVERSAL::can( $request, "param" ))
175             {
176 1         17 die( "Interface [$args->{request_interface}] does not implement required method: param()\n" );
177             }
178 13 100       73 unless (UNIVERSAL::can( $request, "header" ))
179             {
180 1         20 die( "Interface [$args->{request_interface}] does not implement required method: header()\n" );
181             }
182 12         54 $this->{request_interface} = $request;
183              
184 12         30 $this->{methods} = {};
185 12         24 $this->{formats} = {};
186 12         31 $this->{descriptions} = {};
187              
188 12         69 $this->{mimetype_mapping} =
189             {
190             "html" => "text/html",
191             "text/html" => "text/html",
192              
193             "text" => "text/plain",
194             "text/plain" => "text/plain",
195             };
196              
197 12         67 $this->method( "GET", \&REST::Resource::unimplemented, "GET: Unimplemented read accessor." );
198 12         32 $this->method( "PUT", \&REST::Resource::unimplemented, "PUT: Unimplemented create mutator." );
199 12         30 $this->method( "POST", \&REST::Resource::unimplemented, "POST: Unimplemented update mutator." );
200 12         29 $this->method( "DELETE", \&REST::Resource::unimplemented, "DELETE: Unimplemented delete mutator." );
201 12         30 $this->method( "TRACE", \&REST::Resource::api, "TRACE: API identity / discoverability." );
202 12         31 $this->method( "HEAD", \&REST::Resource::api, "HEAD: API identity / discoverability." );
203 12         31 $this->method( "authenticate",
204             \&REST::Resource::authenticate,
205             "authenticate: Default no-authorization-required authentication control implementation." );
206              
207 12         45 $this->format( "text/html", \&REST::Resource::format_html, "Returns HTML UI. Request via 'Accept: text/html' or '?format=html'" );
208 12         32 $this->format( "text/plain", \&REST::Resource::format_text, "Returns Text UI. Request via 'Accept: text/plain' or '?format=text'" );
209 12 50       1056 if (-f $INC{"XML/Dumper.pm"})
210             {
211 0         0 $this->{mimetype_mapping}->{xml} = "application/xml"; ## Support: ?format=xml
212 0         0 $this->format( "application/xml",
213             \&REST::Resource::format_xml,
214             "Returns generic XML. Request via 'Accept: application/xml' or '?format=xml'" );
215             };
216 12 100       721 if (-f $INC{"JSON.pm"})
217             {
218 9         34 $this->{mimetype_mapping}->{json} = "text/javascript"; ## Support: ?format=json
219 9         32 $this->format( "text/javascript",
220             \&REST::Resource::format_json,
221             "Returns Javascript Object Notation (JSON). Request via 'Accept: text/javascript' or '?format=json'" );
222             };
223 12 100       295 if (-f $INC{"REST/RequestFast.pm"})
224             {
225 9         22 $this->{ttl} = 60 * 60;
226             }
227 12         55 return( $this );
228             }
229              
230              
231              
232              
233              
234             #----------------------------------------------------------------------
235             =pod
236              
237             =head2 run() CAUTION
238              
239             USAGE:
240              
241             my( $restful ) = new REST::Resource( request_interface => new REST::RequestFast() );
242             $restful->run();
243              
244             my( $restful ) = new Your::WWW::Resource::Implementation( new REST::RequestFast() );
245             $restful->run();
246              
247             DESCRIPTION:
248              
249             This method will run a REST::RequestFast instance. It delegates
250             request interpolation to the registered request instance via the
251             constructor. The default is a shim derived class of CGI.pm.
252              
253             WWW::RESOURCE COMPATIBILITY:
254              
255             If your derived class provides the WWW::Resource suggested callbacks
256             browserprint() and ttl(), this method will honor those and fold in the
257             new code hook mechanism.
258              
259             WARNING:
260              
261             If your derived class contains the method "browserprint()", the
262             calling semantics for _all_ methods will be \%query.
263              
264             $instance->$method( \%query_hash );
265              
266             If your derived class does NOT contain the method "browserprint()", it
267             is assumed that you are using the new calling semantics where you
268             method handler is passed the request instance.
269              
270             $instance->$method( $request_instance );
271              
272             Thus ref( $arg ) will be "HASH" for the old style and an object
273             reference for the new style.
274              
275             =cut
276              
277             sub run
278             {
279 6     6 1 320 my( $this ) = shift;
280              
281             eval
282 6         11 {
283 4     4   8354 use REST::RequestFast; ## Conditional environment fun and games.
  4         11  
  4         2382  
284             };
285 6 100       153 if (-f $INC{"REST/RequestFast.pm"})
286             {
287 5         28 my( $html ) = $this->can( "browserprint" ); ## WWW::Resource signature method.
288 5         19 my( $ttl ) = $this->can( "ttl" );
289 5 100       15 $this->format( "html", $html, "WWW::Resource style html-format handler." ) if ($html);
290 5 100       13 $this->{ttl} = $this->ttl() if ($ttl);
291 5         11 $this->{starttime} = time();
292              
293 5         6 my( $cgi );
294 5         25 while( ($cgi = new REST::RequestFast()) )
295             {
296 1         4 my( $authenticate ) = $this->method( "authenticate" );
297 1         5 my( $status, $data )= $this->$authenticate( $cgi ); ## We presume that $authenticate always exists.
298 1 50       5 if ($status == RC_OK)
299             {
300 1         9 my( $method ) = $this->method( $cgi->http( "REQUEST_METHOD" ) );
301 1 50       3 if ($html) ## WWW::Resource 0.01 semantics detected.
302             {
303 0         0 my( %query ) = map { split /=/ } split /;/, lc( $ENV{QUERY_STRING} );## Gratuitous case mangling.
  0         0  
304 0         0 $this->_return_result( $cgi, $this->$method->( \%query ) ); ## Old calling convention.
305             }
306             else
307             {
308 1         5 $this->_return_result( $cgi, $this->$method( $cgi ) ); ## New calling convention.
309             }
310             }
311             else
312             {
313 0         0 $this->_return_result( $cgi, $status, $data );
314             }
315 1 50       1640 if ( (time() - $this->{starttime}) > $this->{ttl} )
316             {
317 0         0 return;
318             }
319             }
320             }
321             else
322             {
323 1         13 die "REST::RequestFast did not load. Presumably CGI::Fast and FCGI are unavailable.";
324             }
325             }
326              
327              
328              
329              
330             #----------------------------------------------------------------------
331             =pod
332              
333             =head2 handle_request()
334              
335             USAGE:
336              
337             my( $restful ) = new REST::Resource( request_instance => new REST::Request() );
338             $restful->handle_request(); ## Implicit
339             $restful->handle_request( new REST::Request() ); ## Explicit
340             $restful->handle_request( new CGI() ); ## Explicit
341              
342             DESCRIPTION:
343              
344             This method runs a single action handler. Optionally pass in the CGI
345             request to be handled.
346              
347             =cut
348              
349             sub handle_request
350             {
351 0     0 1 0 my( $this ) = shift;
352 0         0 my( $req ) = shift;
353 0 0       0 $req = $this->get_request() unless( $req );
354 0         0 my( $method ) = $this->method( $req->http( "REQUEST_METHOD" ) );
355 0         0 my( $authenticate ) = $this->method( "authenticate" );
356 0         0 my( $status, $data )= $this->$authenticate( $req ); ## We presume that $authenticate always exists.
357 0 0 0     0 if ($status == RC_OK && defined( $method ))
358             {
359 0         0 $this->_return_result( $req, $this->$method( $req ) );
360             }
361             else
362             {
363 0         0 $this->_return_result( $req, $status, $data ); ## Either 401/403
364             }
365             }
366              
367              
368              
369              
370             #----------------------------------------------------------------------
371             =pod
372              
373             =head2 method()
374              
375             USAGE:
376              
377             my( $coderef ) = $restful->method( "GET" ); ## OR
378             my( $method ) = $restful->method( "GET", \&get_handler, $description );
379              
380             $restful->$method( $request_interface_instance );
381              
382             DESCRIPTION:
383              
384             This accessor/mutator allows the caller to register or change the
385             implementation behavior for a given HTTP method handler. The standard
386             event handlers that are pre-registered are:
387              
388             GET
389             PUT
390             POST
391             DELETE
392             TRACE
393             HEAD
394              
395             Additionally, the following pseudo-methods provide over-ride control
396             to derived class implementors.
397              
398             authenticate
399              
400             Unless otherwise overridden, the default implementation for each of
401             these methods is REST::Resource->unimplemented().
402              
403             =cut
404              
405             sub method
406             {
407 102     102 1 3073 my( $this ) = shift;
408 102         121 my( $method ) = shift;
409 102         113 my( $implementation ) = shift;
410 102         112 my( $description ) = shift;
411 102 100       194 $description = "$method: No API semantics provided during method registration." unless( $description );
412 102   100     369 my( $old ) = $this->{methods}->{$method} || undef;
413 102 100       198 if (defined( $implementation ))
414             {
415 93         166 $this->{methods}->{$method} = $implementation;
416 93         154 $this->{descriptions}->{$method} = $description;
417             }
418 102         185 return( $old );
419             }
420              
421              
422              
423              
424              
425             #----------------------------------------------------------------------
426             =pod
427              
428             =head2 format()
429              
430             USAGE:
431              
432             my( $format ) = $restful->format( "xml" ); ## OR
433             $description = $restful->format( "xml", \&format_xml, $description );
434              
435             $restful->$format( $request_interface_instance, $status, $data );
436              
437             DESCRIPTION:
438              
439             This accessor/mutator allows the caller to register or change the
440             implementation behavior for a given output format.
441              
442             =cut
443              
444             sub format
445             {
446 42     42 1 512 my( $this ) = shift;
447 42         48 my( $format ) = shift;
448 42 100       144 $format = $this->{mimetype_mapping}->{$format} if (exists( $this->{mimetype_mapping}->{$format} ));
449 42         54 my( $implementation ) = shift;
450 42         50 my( $description ) = shift;
451 42 100       91 $description = "$format: No format semantics provided during format registration." unless( $description );
452 42         49 my( $old ) = undef;
453 42 100       104 $old = $this->{formats}->{$format} if (exists( $this->{formats}->{$format} ));
454 42 100       88 if (defined( $implementation ))
455             {
456 37         65 $this->{formats}->{$format} = $implementation;
457 37         85 $this->{descriptions}->{$format} = $description;
458 37         65 $this->{mimetype_mapping}->{$format} = $format;
459             }
460 42         93 return( $old );
461             }
462              
463              
464              
465              
466              
467             #----------------------------------------------------------------------
468             =pod
469              
470             =head2 description()
471              
472             USAGE:
473              
474             my( $restful ) = new REST::Resource();
475             my( $description ) = $restful->description( $name );
476              
477             DESCRIPTION:
478              
479             This accessor/mutator allows the caller to register or change the
480             description for a given HTTP method handler or output format.
481              
482             This is used by REST::Resource->api() to provide a description of the
483             API.
484              
485             PARAMETERS:
486              
487             $type -- "methods" or "formats"
488             $name -- See the names appropriate for the given $type.
489             $description-- The description to be set (or returned).
490              
491             =cut
492              
493             sub description
494             {
495 30     30 1 46 my( $this ) = shift;
496 30         106 my( $name ) = shift;
497 30         61 my( $description ) = "No description is available for [$name].";
498 30 100       88 if (defined( $this->{descriptions}->{$name} ))
499             {
500 29         51 $description = $this->{descriptions}->{$name};
501             }
502 30         102 return( $description );
503             }
504              
505              
506              
507              
508              
509             #----------------------------------------------------------------------
510             =pod
511              
512             =head2 api()
513              
514             USAGE:
515              
516             my( $status, $data ) = $this->api( $request_interface_instance );
517              
518             DESCRIPTION:
519              
520             This method generates a resultset that can be returned through
521             $this->_return_result( $status, $data );
522              
523             =cut
524              
525             sub api
526             {
527 3     3 1 9 my( $this ) = shift;
528 3         6 my( $req ) = shift; ## Interface: REST::Request
529 3         8 my( $status ) = RC_OK;
530 3         57 my( $data ) =
531             {
532             version => $this->VERSION,
533             implementation => ref( $this ),
534             };
535 3 100       27 my( $server_url ) = ($req->http( "SERVER_PORT" ) == 443
536             ? "https://" . $req->http( "SERVER_NAME" )
537             : "http://" . $req->http( "SERVER_NAME" )
538             );
539 3 100       14 my( $uri ) = (defined( $req->http( "SCRIPT_NAME" ) )
540             ? $req->http( "SCRIPT_NAME" )
541             : "/dummy/testing/uri");
542 3         10 foreach my $method (keys( %{ $this->{methods} } ))
  3         18  
543             {
544 21         33 my( $api ) = {};
545 21         97 $api->{url} = $server_url . $uri;
546 21         48 $api->{description} = $this->description( $method );
547 21         49 $data->{$method} = $api;
548             }
549 3         15 return( $status, $data );
550             }
551              
552              
553              
554              
555              
556             #----------------------------------------------------------------------
557             =pod
558              
559             =head2 authenticate()
560              
561             USAGE:
562              
563             my( $status, $data ) = $this->authenticate( $request_interface_instance );
564              
565             DESCRIPTION:
566              
567             This method may be overridden by a derived class that requires
568             HTTP request authentication.
569              
570             STATUS VALUES:
571              
572             RC_OK (200) -- Accept provided credentials, if any.
573             RC_UNAUTHORIZED (401) -- Prompt user for credentials via dialog box.
574             RC_FORBIDDEN (403) -- Reject provided credentials.
575              
576             DERIVED IMPLEMENTATIONS:
577              
578             This method may be overridden in the derived class in order to
579             require a specific set of credentials.
580              
581             =cut
582              
583             sub authenticate
584             {
585 2     2 1 5 my( $this ) = shift;
586 2         6 my( $req ) = shift;
587 2         5 my( $status ) = RC_OK;
588 2         3 my( $data ) = undef;
589              
590 2         7 return( $status, $data );
591             }
592              
593              
594              
595              
596              
597             #----------------------------------------------------------------------
598             =pod
599              
600             =head2 format_xml()
601              
602             USAGE:
603              
604             print $this->format_xml( $request_interface_instance, $status, $data );
605              
606             DESCRIPTION:
607              
608             This method will format $data as XML via XML::Dumper with an included
609             in-document DTD. This method will only be registered if the module
610             XML::Deumper is found in the execution environment.
611              
612             =cut
613              
614             sub format_xml
615             {
616 0     0 1 0 my( $this ) = shift;
617 0         0 my( $req ) = shift;
618 0         0 my( $status ) = shift;
619 0         0 my( $data ) = shift;
620 0         0 my( $xml ) = new XML::Dumper();
621 0         0 $xml->dtd; ## Include an in-document DTD
622 0         0 return( join( "",
623             $req->header( -status => $status,
624             -expires => "+15s",
625             -content_type => "application/xml" ),
626             $xml->pl2xml( $data ),
627             )
628             );
629             }
630              
631              
632              
633              
634              
635             #----------------------------------------------------------------------
636             =pod
637              
638             =head2 format_text()
639              
640             USAGE:
641              
642             print $this->format_text( $request_interface_instance, $status, $data );
643              
644             DESCRIPTION:
645              
646             Use Data::Dumper to emit $data in text/plain format.
647              
648             =cut
649              
650             sub format_text
651             {
652 0     0 1 0 my( $this ) = shift;
653 0         0 my( $req ) = shift;
654 0         0 my( $status ) = shift;
655 0         0 my( $data ) = shift;
656 0         0 return( join( "",
657             $req->header( -status => $status,
658             -expires => "+15s",
659             -content_type => "text/plain" ),
660             Dumper( $data ),
661             )
662             );
663             }
664              
665              
666              
667              
668              
669             #----------------------------------------------------------------------
670             =pod
671              
672             =head2 format_html()
673              
674             USAGE:
675              
676             print $this->format_html( $request_interface_instance, $status, $data );
677              
678             DESCRIPTION:
679              
680             Use Data::Dumper to emit $data, then translate it via simple
 
681             tags with limited CSS to control the font-size.
682              
683             =cut
684              
685             sub format_html
686             {
687 0     0 1 0 my( $this ) = shift;
688 0         0 my( $req ) = shift;
689 0         0 my( $status ) = shift;
690 0         0 my( $data ) = shift;
691 0         0 my( $dumped ) = substr( Dumper( $data ), 7 );
692 0         0 return( join( "",
693             $req->header( -status => $status,
694             -expires => "+15s",
695             -content_type => "text/html" ),
696             "",
697             "",
698             "Structured Data",
699             "",
700             "",
701             "

Structured Data

",
702             "
",	## 80% of normal size 
703             $dumped,
704             "",
705             "",
706             "",
707             )
708             );
709             }
710              
711              
712              
713              
714              
715             #----------------------------------------------------------------------
716             =pod
717              
718             =head2 format_json()
719              
720             USAGE:
721              
722             print $this->format_json( $request_interface_instance, $status, $data );
723              
724             DESCRIPTION:
725              
726             This method will format $data in JSON (JavaScript Object Notation).
727             This method will only be registered if JSON is found in the execution
728             environment.
729              
730             =cut
731              
732             sub format_json
733             {
734 0     0 1 0 my( $this ) = shift;
735 0         0 my( $req ) = shift;
736 0         0 my( $status ) = shift;
737 0         0 my( $data ) = shift;
738              
739 0         0 return( join( "",
740             $req->header( -status => $status,
741             -expires => "+15s",
742             -content_type => "text/javascript" ),
743             &objToJson( $data,
744             {
745             pretty => 1,
746             indent => 4,
747             }
748             )
749             )
750             );
751             }
752              
753              
754              
755              
756              
757             #----------------------------------------------------------------------
758             =pod
759              
760             =head2 unimplemented()
761              
762             USAGE:
763              
764             N/A
765              
766             DESCRIPTION:
767              
768             This method is invoked if an unregistered HTTP REQUEST_METHOD is
769             invoked.
770              
771             =cut
772              
773             sub unimplemented
774             {
775 1     1 1 5 my( $this ) = shift;
776 1         2 my( $req ) = shift; ## Interface: REST::Request
777 1         3 my( $status ) = RC_OK; ## Don't let the browser whine. We get to do that...
778 1         6 my( $data ) =
779             {
780             ERROR => "No RESTful implementation defined for " . $req->http( "REQUEST_METHOD" ),
781             RESOURCE => $req->http( "SCRIPT_NAME" ),
782             PARAMETERS => $req->http( "PATH_INFO" ),
783             };
784 1         4 return( $status, $data );
785             }
786              
787              
788              
789              
790              
791             #----------------------------------------------------------------------
792             =pod
793              
794             =head2 default_format()
795              
796             USAGE:
797              
798             my( $format ) = $this->default_format( $request_interface_instance );
799             print $this->$format( $status, $data );
800              
801             DESCRIPTION:
802              
803             This method will return the requested format. We look in two
804             places. The first is in the query parameter list for the
805             parameter "format". If that is defined, we return that value.
806              
807             Otherwise, we scan through the list of q=1.0 Accept: headers and
808             return the first matching MIME-type.
809              
810             SAMPLE OPERA Accept: / User-Agent: HEADERS:
811              
812             Accept: text/html, application/xml;q=0.9, application/xhtml+xml,
813             image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1
814             User-Agent: Opera/9.10 (X11; Linux i686; U; en)
815              
816             SAMPLE FIREFOX Accept: / User-Agent: HEADERS:
817              
818             Accept: text/xml, application/xml, application/xhtml+xml, text/html;
819             q=0.9, text/plain;
820             q=0.8, image/png, */*;
821             q=0.5
822             User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.3)
823             Gecko/20070309 Firefox/2.0.0.3
824              
825             SAMPLE MSIE Accept: / User-Agent: HEADERS:
826              
827             Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg,
828             application/x-shockwave-flash, application/vnd.ms-powerpoint,
829             application/vnd.ms-excel, application/msword, */*
830             User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1;
831             .NET CLR 1.1.4322; .NET CLR 2.0.50727)
832              
833             SUGGESTIONS FOR JSON DEVELOPERS:
834              
835             Use "Accept: text/javascript" or "?format=json" to get JSON
836             output. The default algorithm will presume that the client is a
837             human behind a browser and try to encourage html.
838              
839             SUGGESTIONS FOR AJAX DEVELOPERS:
840              
841             Use "Accept: application/xml" or "?format=xml" to get XML output.
842             The default algorithm will presume that the client is a human
843             behind a browser and try to encourage html.
844              
845             =cut
846              
847             sub default_format
848             {
849 12     12 1 34 my( $this ) = shift;
850 12         19 my( $req ) = shift;
851 12         39 my( $format ) = $req->param( "format" );
852 12         253 my( $useragent ) = $req->http( "HTTP_USER_AGENT" );
853 12   50     39 my( $accept ) = $req->http( "HTTP_ACCEPT" ) || ";";
854 12         46 my( $explicit ) = (split( ";", $accept ))[0]; ## Only q=1.0 entries
855              
856 12 100       45 if (defined( $format ))
    50          
857             {
858 2         10 return( $format );
859             }
860             elsif (defined( $explicit ))
861             {
862 10         67 my( @mimetypes ) = split( /\,\s*/, $explicit );
863 10         23 my( $mimetypes ) = {};
864 10         14 foreach $format (@mimetypes)
865             {
866 40         98 $mimetypes->{$format} = 1;
867             }
868 10 100 100     170 if (defined( $useragent ) &&
869             $useragent =~ /Gecko/i)
870             {
871 6 100 100     50 return( "html" ) if ($mimetypes->{"text/html"} && ## Firefox default is xml, but
872             $mimetypes->{"application/xml"}); ## should be html.
873             }
874 9         14 foreach $format (@mimetypes)
875             {
876 19 100       99 return( $format ) if (exists( $this->{formats}->{$format} )); ## Return specified MIME-type.
877             }
878 1 50 33     11 if (defined( $useragent ) &&
879             $useragent =~ /MSIE/)
880             {
881 1         11 return( "html" ); ## MSIE doesn't auto-match, so push HTML
882             }
883             }
884 0         0 my( $default_type ) = "html";
885 0 0       0 if (defined( %XML::Dumper:: ))
886             {
887 0         0 $default_type = "xml";
888             }
889 0         0 return( $default_type );
890             }
891              
892              
893              
894              
895              
896             #----------------------------------------------------------------------
897             =pod
898              
899             =head2 get_request()
900              
901             USAGE:
902              
903             my( $request ) = $restful->get_request();
904              
905             DESCRIPTION:
906              
907             Return a new request_interface instance. This instance must
908             support the methods: new(), http(), param() and header().
909              
910             SEE ALSO:
911              
912             REST::Request
913             REST::RequestFast
914              
915             =cut
916              
917             sub get_request
918             {
919 0     0 1 0 my( $this ) = shift;
920 0         0 my( $interface ) = $this->{request_interface};
921 0         0 return( $interface->new() );
922             }
923              
924              
925              
926              
927              
928             #----------------------------------------------------------------------
929             =pod
930              
931             =head2 _return_result() PRIVATE
932              
933             USAGE:
934              
935             $this->_return_result( $request_interface_instance, $http_status, $data );
936              
937             DESCRIPTION:
938              
939             This method is handed output of a given REQUEST_METHOD handler and is
940             responsible for appropriate status code emission and $data formatting.
941              
942             =cut
943              
944             sub _return_result
945             {
946 1     1   13 my( $this ) = shift;
947 1         2 my( $req ) = shift;
948 1         2 my( $status ) = shift;
949 1         2 my( $data ) = shift;
950              
951 1         2 my( $status_msg ) = $status;
952 1 50       8 $status_msg .= &status_message( $status ) if (defined( $status ));
953 1 50       9 chomp( $status_msg ) if (defined( $status_msg ));
954 1 50       5 if ( &is_error( $status ))
955             {
956 1         10 print $req->header( -status => $status_msg );
957             }
958             else
959             {
960 0           my( $format ) = $this->default_format( $req );
961 0           my( $formatter ) = $this->format( $format );
962 0           print join( "",
963             $this->$formatter( $req, $status, $data ),
964             );
965             }
966             }
967              
968              
969              
970              
971             #----------------------------------------------------------------------
972             =pod
973              
974             =head2 SEE ALSO
975              
976             WWW::Resource
977             http://www.peej.co.uk/articles/restfully-delicious.html
978             http://www.xfront.com/REST-Web-Services.html
979             http://www.ics.uci.edu/~fielding/pubs/dissertation/rest_arch_style.htm
980              
981             =cut
982              
983             1;