File Coverage

blib/lib/Nile/HTTP/Response.pm
Criterion Covered Total %
statement 15 157 9.5
branch 0 66 0.0
condition 0 24 0.0
subroutine 5 43 11.6
pod 2 36 5.5
total 22 326 6.7


line stmt bran cond sub pod time code
1             # Copyright Infomation
2             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3             # Author : Dr. Ahmed Amin Elsheshtawy, Ph.D.
4             # Website: https://github.com/mewsoft/Nile, http://www.mewsoft.com
5             # Email : mewsoft@cpan.org, support@mewsoft.com
6             # Copyrights (c) 2014-2015 Mewsoft Corp. All rights reserved.
7             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8             package Nile::HTTP::Response;
9              
10             our $VERSION = '0.55';
11             our $AUTHORITY = 'cpan:MEWSOFT';
12              
13             =pod
14              
15             =encoding utf8
16              
17             =head1 NAME
18              
19             Nile::HTTP::Response - The HTTP response manager.
20              
21             =head1 SYNOPSIS
22              
23             # get response instance
24             $res = $app->response;
25              
26             $res->code(200);
27             #$res->status(200);
28            
29             $res->header('Content-Type' => 'text/plain');
30             #$res->content_type('text/html');
31             $res->header(Content_Base => 'http://www.mewsoft.com/');
32             $res->header(Accept => "text/html, text/plain, image/*");
33             $res->header(MIME_Version => '1.0', User_Agent => 'Nile Web Client/0.27');
34             $res->cookies->{username} = {
35             value => 'mewsoft',
36             path => "/",
37             domain => '.mewsoft.com',
38             expires => time + 24 * 60 * 60,
39             };
40             #$res->body("Hello world content");
41             $res->content("Hello world content");
42              
43             # PSGI response
44             $response = $res->finalize;
45             # [$code, $headers, $body]
46             ($code, $headers, $body) = @$response;
47            
48             # headers as string
49             $headers_str = $res->headers_as_string($eol)
50            
51             # message as string
52             print $res->as_string($eol);
53              
54             # HTTP/1.1 200 OK
55             # Accept: text/html, text/plain, image/*
56             # User-Agent: Nile Web Client/0.27
57             # Content-Type: text/plain
58             # Content-Base: http://www.mewsoft.com/
59             # MIME-Version: 1.0
60             # Set-Cookie: username=mewsoft; domain=.mewsoft.com; path=/; expires=Fri, 25-Jul-2014 19:10:45 GMT
61             #
62             # Hello world content
63              
64             =head1 DESCRIPTION
65              
66             Nile::HTTP::Response - The HTTP response manager allows you to create PSGI response array ref.
67              
68             =cut
69              
70 1     1   4 use Nile::Base;
  1         1  
  1         9  
71 1     1   5723 use Scalar::Util ();
  1         3  
  1         13  
72 1     1   1480 use HTTP::Headers;
  1         3052  
  1         12  
73 1     1   26 use URI::Escape ();
  1         1  
  1         2178  
74             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
75             sub main { # sub new{}
76 0     0 0   my ($self, $code, $headers, $content) = @_;
77 0 0         $self->status($code) if defined $code;
78 0 0         $self->headers($headers) if defined $headers;
79 0 0         $self->body($content) if defined $content;
80             }
81             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
82             =head2 headers
83              
84             $headers = $res->headers;
85             $res->headers([ 'Content-Type' => 'text/html' ]);
86             $res->headers({ 'Content-Type' => 'text/html' });
87             $res->headers( HTTP::Headers->new );
88              
89             Sets and gets HTTP headers of the response. Setter can take either an
90             array ref, a hash ref or L<HTTP::Headers> object containing a list of
91             headers.
92              
93             This is L<HTTP::Headers> object and all its methods available:
94            
95             say $res->headers->header_field_names();
96             say $res->headers->remove_content_headers();
97             $res->headers->clear();
98              
99             =cut
100              
101             sub headers {
102              
103 0     0 0   my $self = shift;
104              
105 0 0         if (@_) {
106 0           my $headers = shift;
107 0 0         if (ref $headers eq 'ARRAY') {
    0          
108 0 0         Carp::carp("Odd number of headers") if @$headers % 2 != 0;
109 0           $headers = HTTP::Headers->new(@$headers);
110             }
111             elsif (ref $headers eq 'HASH') {
112 0           $headers = HTTP::Headers->new(%$headers);
113             }
114 0           return $self->{headers} = $headers;
115             }
116             else {
117 0   0       return $self->{headers} ||= HTTP::Headers->new();
118             }
119             }
120             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
121             =head2 header
122              
123             $res->header('X-Foo' => 'bar');
124             my $val = $res->header('X-Foo');
125              
126             Sets and gets HTTP header of the response.
127              
128             =cut
129              
130 0     0 0   sub header { shift->headers->header(@_) }
131             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132              
133             =head2 remove_header
134            
135             # delete
136             $res->remove_header('Content-Type');
137              
138             Removes the header fields with the specified names.
139              
140             =cut
141              
142 0     0 1   sub remove_header { shift->headers->remove_header(@_) }
143             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144             =head2 status
145              
146             $res->status(200);
147             $status = $res->status;
148              
149             Sets and gets HTTP status code. C<code> is an alias.
150              
151             =cut
152              
153             has status => (is => 'rw');
154 0     0 0   sub code { shift->status(@_) }
155             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156             =head2 body
157              
158             $res->body($body_str);
159             $res->body([ "Hello", "World" ]);
160             $res->body($io);
161              
162             Gets and sets HTTP response body. Setter can take either a string, an
163             array ref, or an IO::Handle-like object. C<content> is an alias.
164              
165             Note that this method doesn't automatically set I<Content-Length> for
166             the response. You have to set it manually if you want, with the
167             C<content_length> method.
168              
169             =cut
170              
171             has body => (is => 'rw');
172 0     0 0   sub content { shift->body(@_) }
173             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
174             =head2 cookies
175              
176             $res->cookies->{name} = 123;
177             $res->cookies->{name} = {value => '123'};
178              
179             Returns a hash reference containing cookies to be set in the
180             response. The keys of the hash are the cookies' names, and their
181             corresponding values are a plain string (for C<value> with everything
182             else defaults) or a hash reference that can contain keys such as
183             C<value>, C<domain>, C<expires>, C<path>, C<httponly>, C<secure>,
184             C<max-age>.
185              
186             C<expires> can take a string or an integer (as an epoch time) and
187             B<does not> convert string formats such as C<+3M>.
188              
189             $res->cookies->{name} = {
190             value => 'test',
191             path => "/",
192             domain => '.example.com',
193             expires => time + 24 * 60 * 60,
194             };
195              
196             =cut
197              
198             has cookies => (is => 'rw', isa => 'HashRef', default => sub {+{}});
199             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
200             =head2 content_length
201              
202             $res->content_length(123);
203              
204             A decimal number indicating the size in bytes of the message content.
205             Shortcut for the equivalent get/set method in C<< $res->headers >>.
206              
207             =cut
208              
209 0     0 0   sub content_length {shift->headers->content_length(@_)}
210             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211             =head2 content_type
212              
213             $res->content_type('text/plain');
214              
215             The Content-Type header field indicates the media type of the message content.
216             Shortcut for the equivalent get/set method in C<< $res->headers >>.
217              
218             =cut
219              
220 0     0 0   sub content_type {shift->headers->content_type(@_)}
221             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
222             =head2 content_encoding
223              
224             $res->content_encoding('gzip');
225              
226             Shortcut for the equivalent get/set method in C<< $res->headers >>.
227              
228             =cut
229              
230 0     0 0   sub content_encoding {shift->headers->content_encoding(@_)}
231             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232             =head2 location
233              
234             Gets and sets C<Location> header.
235              
236             Note that this method doesn't normalize the given URI string in the
237             setter.
238              
239             =cut
240              
241 0     0 0   sub location {shift->headers->header('Location' => @_)}
242             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
243             =head2 redirect
244              
245             $res->redirect($url);
246             $res->redirect($url, 301);
247              
248             Sets redirect URL with an optional status code, which defaults to 302.
249              
250             Note that this method doesn't normalize the given URI string. Users of
251             this module have to be responsible about properly encoding URI paths
252             and parameters.
253              
254             =cut
255              
256             sub redirect {
257              
258 0     0 0   my $self = shift;
259              
260 0 0         if (@_) {
261 0           my $url = shift;
262 0   0       my $status = shift || 302;
263 0           $self->location($url);
264 0           $self->status($status);
265             }
266              
267 0           return $self->location;
268             }
269             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
270             =head2 finalize
271              
272             $res = $res->finalize;
273             # [$code, \@headers, $body]
274             ($code, $headers, $body) = @$res;
275              
276             Returns the status code, headers, and body of this response as a PSGI response array reference.
277              
278             =cut
279              
280             sub finalize {
281              
282 0     0 0   my $self = shift;
283            
284 0 0         $self->status || $self->status(200);
285              
286 0           my $headers = $self->headers;
287              
288 0           my @headers;
289              
290             $headers->scan(sub{
291 0     0     my ($k, $v) = @_;
292 0           $v =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP
  0            
293 0           $v =~ s/\015|\012//g; # remove CR and LF since the char is invalid here
294 0           push @headers, $k, $v;
295 0           });
296              
297 0           $self->build_cookies(\@headers);
298              
299 0           return [$self->status, \@headers, $self->build_body];
300             }
301             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302             =head2 to_app
303              
304             $res_app = $res->to_app;
305              
306             A helper shortcut for C<< sub { $res->finalize } >>.
307              
308             =cut
309              
310 0     0 0   sub to_app {sub {shift->finalize}}
  0     0      
311             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
312             =head2 headers_as_string
313              
314             $headers = $res->headers_as_string($eol)
315              
316             Return the header fields as a formatted MIME header.
317              
318             The optional $eol parameter specifies the line ending sequence to
319             use. The default is "\n". Embedded "\n" characters in header field
320             values will be substituted with this line ending sequence.
321              
322             =cut
323              
324             sub headers_as_string {
325            
326 0     0 0   my ($self, $eol) = @_;
327              
328 0 0         $eol = "\n" unless defined $eol;
329            
330 0           my $res = $self->finalize;
331 0           my ($code, $headers, $body) = @$res;
332              
333             #$self->headers->as_string;
334              
335 0           my @result = ();
336            
337 0           for (my $i = 0; $i < @$headers; $i = $i+2) {
338 0           my $k = $headers->[$i];
339 0           my $v = $headers->[$i+1];
340 0 0         if (index($v, "\n") >= 0) {
341 0           $v = $self->process_newline($v, $eol);
342             }
343 0           push @result, $k . ': ' . $v;
344             }
345              
346 0           return join($eol, @result, '');
347             }
348             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349             sub process_newline {
350 0     0 0   local $_ = shift;
351 0           my $eol = shift;
352             # must handle header values with embedded newlines with care
353 0           s/\s+$//; # trailing newlines and space must go
354 0           s/\n(\x0d?\n)+/\n/g; # no empty lines
355 0           s/\n([^\040\t])/\n $1/g; # intial space for continuation
356 0           s/\n/$eol/g; # substitute with requested line ending
357 0           $_;
358             }
359             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
360             =head2 as_string
361              
362             $message = $res->as_string($eol);
363              
364             Returns the message formatted as a single string.
365              
366             The optional $eol parameter specifies the line ending sequence to use.
367             The default is "\n". If no $eol is given then as_string will ensure
368             that the returned string is newline terminated (even when the message
369             content is not). No extra newline is appended if an explicit $eol is
370             passed.
371              
372             =cut
373              
374              
375             sub as_string {
376              
377 0     0 0   my($self, $eol) = @_;
378              
379 0 0         $eol = "\n" unless defined $eol;
380              
381             # The calculation of content might update the headers
382             # so we need to do that first.
383 0           my $content = $self->content;
384            
385             #push @header, "Server: " . server_software() if $nph;
386             #push @header, "Status: $status" if $status;
387             #push @header, "Window-Target: $target" if $target;
388             #sub server_software { $ENV{'SERVER_SOFTWARE'} || 'cmdline' }
389            
390 0   0       my $protocol = ($ENV{SERVER_PROTOCOL} || 'HTTP/1.1') . " " .$self->code . " " . $self->http_codes->{$self->code} . $eol;
391              
392 0 0 0       return join("",
393             #$protocol,
394             $self->headers_as_string($eol),
395             $eol,
396             $content,
397             (@_ == 1 && length($content) && $content !~ /\n\z/) ? "\n" : "",
398             );
399             }
400             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
401             =head2 render
402              
403             $res->render;
404              
405             Prints the message formatted as a single string to the standard output.
406              
407             =cut
408              
409             sub render {
410 0     0 0   my ($self) = @_;
411 0           print $self->as_string();
412             }
413             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414             sub send_file {
415            
416 0     0 0   my ($self, $file, $options) = @_;
417            
418 0           load Nile::HTTP::SendFile;
419            
420 0           my $sender = Nile::HTTP::SendFile->new;
421              
422 0           $sender->send_file($self, $file, $options);
423              
424              
425             }
426             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
427             has encoded => (is => 'rw', isa => 'Bool', default => 0);
428             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
429             sub build_body {
430              
431 0     0 0   my $self = shift;
432              
433 0           my $body = $self->body;
434              
435 0 0         $body = [] unless defined $body;
436            
437 0 0         if (!$self->encoded) {
438 0           $self->encoded(1);
439 0           $body = Encode::encode($self->app->charset, $body);
440             }
441              
442 0 0 0       if (!ref $body or Scalar::Util::blessed($body) && overload::Method($body, q("")) && !$body->can('getline')) {
      0        
      0        
443 0           return [$body];
444             } else {
445 0           return $body;
446             }
447             }
448             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
449             sub build_cookies {
450 0     0 0   my($self, $headers) = @_;
451 0           while (my($name, $val) = each %{$self->cookies}) {
  0            
452 0           my $cookie = $self->build_cookie($name, $val);
453 0           push @$headers, 'Set-Cookie' => $cookie;
454             }
455             }
456             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
457             sub build_cookie {
458              
459 0     0 0   my($self, $name, $val) = @_;
460              
461 0 0         return '' unless defined $val;
462              
463 0 0         $val = {value => $val} unless ref $val eq 'HASH';
464              
465 0           my @cookie = (URI::Escape::uri_escape($name) . "=" . URI::Escape::uri_escape($val->{value}));
466              
467 0 0         push @cookie, "domain=" . $val->{domain} if $val->{domain};
468 0 0         push @cookie, "path=" . $val->{path} if $val->{path};
469 0 0         push @cookie, "expires=" . $self->cookie_date($val->{expires}) if $val->{expires};
470 0 0         push @cookie, "max-age=" . $val->{"max-age"} if $val->{"max-age"};
471 0 0         push @cookie, "secure" if $val->{secure};
472 0 0         push @cookie, "HttpOnly" if $val->{httponly};
473              
474 0           return join "; ", @cookie;
475             }
476             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
477             sub file_response {
478              
479 0     0 0   my ($self, $file, $mime, $status) = @_;
480            
481 0 0 0       $mime ||= $self->app->mime->for_file($file) || "application/x-download",
      0        
482              
483             $self->status($status) if ($status);
484            
485 0           my ($size, $last_modified) = (stat $file)[7,9];
486              
487 0           $last_modified = $self->http_date($last_modified);
488              
489             #my $ifmod = $ENV{HTTP_IF_MODIFIED_SINCE};
490              
491 0           open (my $fh, '<', $file);
492 0           binmode $fh;
493              
494 0           $self->content($fh);
495              
496 0           $self->header('Last-Modified' => $last_modified);
497 0           $self->header('Content-Type' => $mime);
498 0           $self->header('Content-Length' => $size);
499              
500             }
501             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
502             my @MON = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
503             my @WDAY = qw(Sun Mon Tue Wed Thu Fri Sat);
504              
505             =head2 cookie_date
506              
507             say $res->cookie_date( time + 24 * 60 * 60);
508             #Fri, 25-Jul-2014 20:46:53 GMT
509              
510             Returns cookie formated date.
511              
512             =cut
513              
514             sub cookie_date {
515 0     0 1   my ($self, $expires) = @_;
516 0 0         if ($expires =~ /^\d+$/) {
517 0           return $self->make_date($expires, "cookie");
518             }
519 0           return $expires;
520             }
521             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522             =head2 http_date
523              
524             say $res->http_date(time);
525             #Thu, 24 Jul 2014 20:46:53 GMT
526              
527             Returns http formated date.
528              
529             =cut
530              
531             sub http_date {
532 0     0 0   my ($self, $time) = @_;
533 0           return $self->make_date($time, "http");
534             }
535             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
536             sub make_date {
537              
538 0     0 0   my ($self, $time, $format) = @_;
539            
540             # format: cookie = "-", http = " "
541 0 0         my $sp = $format eq "cookie" ? "-" : " ";
542              
543 0           my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
544 0           $year += 1900;
545              
546 0           return sprintf("%s, %02d$sp%s$sp%s %02d:%02d:%02d GMT",
547             $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
548             }
549             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
550             has 'http_codes' => (
551             is => 'rw',
552             isa => 'HashRef',
553             default => sub { +{
554             # informational
555             # 100 => 'Continue', # only on HTTP 1.1
556             # 101 => 'Switching Protocols', # only on HTTP 1.1
557              
558             # processed codes
559             200 => 'OK',
560             201 => 'Created',
561             202 => 'Accepted',
562              
563             # 203 => 'Non-Authoritative Information', # only on HTTP 1.1
564             204 => 'No Content',
565             205 => 'Reset Content',
566             206 => 'Partial Content',
567              
568             # redirections
569             301 => 'Moved Permanently',
570             302 => 'Found',
571              
572             # 303 => '303 See Other', # only on HTTP 1.1
573             304 => 'Not Modified',
574              
575             # 305 => '305 Use Proxy', # only on HTTP 1.1
576             306 => 'Switch Proxy',
577              
578             # 307 => '307 Temporary Redirect', # on HTTP 1.1
579              
580             # problems with request
581             400 => 'Bad Request',
582             401 => 'Unauthorized',
583             402 => 'Payment Required',
584             403 => 'Forbidden',
585             404 => 'Not Found',
586             405 => 'Method Not Allowed',
587             406 => 'Not Acceptable',
588             407 => 'Proxy Authentication Required',
589             408 => 'Request Timeout',
590             409 => 'Conflict',
591             410 => 'Gone',
592             411 => 'Length Required',
593             412 => 'Precondition Failed',
594             413 => 'Request Entity Too Large',
595             414 => 'Request-URI Too Long',
596             415 => 'Unsupported Media Type',
597             416 => 'Requested Range Not Satisfiable',
598             417 => 'Expectation Failed',
599              
600             # problems with server
601             500 => 'Internal Server Error',
602             501 => 'Not Implemented',
603             502 => 'Bad Gateway',
604             503 => 'Service Unavailable',
605             504 => 'Gateway Timeout',
606             505 => 'HTTP Version Not Supported',
607             }});
608             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
609             =head2 status_message($code)
610              
611             The status_message() function will translate status codes to human
612             readable strings. If the $code is unknown, then C<undef> is returned.
613              
614             =cut
615              
616 0     0 0   sub status_message {my $self = shift; $self->http_codes->{$_[0]};}
  0            
617             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
618             =head2 is_info( $code )
619              
620             Return TRUE if C<$code> is an I<Informational> status code (1xx). This
621             class of status code indicates a provisional response which can't have
622             any content.
623              
624             =cut
625              
626 0 0   0 0   sub is_info {shift; $_[0] >= 100 && $_[0] < 200; }
  0            
627             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628             =item is_success( $code )
629              
630             Return TRUE if C<$code> is a I<Successful> status code (2xx).
631              
632             =cut
633              
634 0 0   0 0   sub is_success {shift; $_[0] >= 200 && $_[0] < 300; }
  0            
635             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
636             =item is_redirect( $code )
637              
638             Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
639             status code indicates that further action needs to be taken by the
640             user agent in order to fulfill the request.
641              
642             =cut
643              
644 0 0   0 0   sub is_redirect {shift; $_[0] >= 300 && $_[0] < 400; }
  0            
645             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
646             =item is_error( $code )
647              
648             Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
649             returns TRUE for both client and server error status codes.
650              
651             =cut
652              
653 0 0   0 0   sub is_error {shift; $_[0] >= 400 && $_[0] < 600; }
  0            
654             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
655             =item is_client_error( $code )
656              
657             Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
658             of status code is intended for cases in which the client seems to have
659             erred.
660              
661             =cut
662              
663 0 0   0 0   sub is_client_error {shift; $_[0] >= 400 && $_[0] < 500; }
  0            
664             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
665             =item is_server_error( $code )
666              
667             Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
668             of status codes is intended for cases in which the server is aware
669             that it has erred or is incapable of performing the request.
670              
671             =cut
672              
673 0 0   0 0   sub is_server_error {shift; $_[0] >= 500 && $_[0] < 600; }
  0            
674             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
675             sub http_code_response {
676            
677 0     0 0   my ($self, $code) = @_;
678              
679 0           $self->code($code);
680            
681 0           $self->header('Content-Type' => 'text/plain');
682            
683 0           my $body = $self->status_message($code);
684              
685 0           $self->content($body);
686            
687 1     1   7 use bytes; # turn off character semantics
  1         1  
  1         6  
688 0           $self->header('Content-Length' => length($body));
689              
690 0           return $self->finalize;
691             }
692             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
693             sub response_403 {
694             # 403 => 'Forbidden',
695 0     0 0   return shift->http_code_response(403);
696             }
697             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
698             sub response_400 {
699             # 400 => 'Bad Request',
700 0     0 0   return shift->http_code_response(400);
701             }
702             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
703             sub response_404 {
704             # 404 => 'Not Found',
705 0     0 0   return shift->http_code_response(404);
706             }
707             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
708              
709             =pod
710              
711             =head1 Bugs
712              
713             This project is available on github at L<https://github.com/mewsoft/Nile>.
714              
715             =head1 HOMEPAGE
716              
717             Please visit the project's homepage at L<https://metacpan.org/release/Nile>.
718              
719             =head1 SOURCE
720              
721             Source repository is at L<https://github.com/mewsoft/Nile>.
722              
723             =head1 ACKNOWLEDGMENT
724              
725             This module is based on L<Plack::Response> L<HTTP::Message>
726              
727             =head1 SEE ALSO
728              
729             See L<Nile> for details about the complete framework.
730              
731             =head1 AUTHOR
732              
733             Ahmed Amin Elsheshtawy, احمد امين الششتاوى <mewsoft@cpan.org>
734             Website: http://www.mewsoft.com
735              
736             =head1 COPYRIGHT AND LICENSE
737              
738             Copyright (C) 2014-2015 by Dr. Ahmed Amin Elsheshtawy احمد امين الششتاوى mewsoft@cpan.org, support@mewsoft.com,
739             L<https://github.com/mewsoft/Nile>, L<http://www.mewsoft.com>
740              
741             This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
742              
743             =cut
744              
745             1;