File Coverage

blib/lib/MVC/Neaf/Exception.pm
Criterion Covered Total %
statement 55 55 100.0
branch 17 18 94.4
condition 24 29 82.7
subroutine 14 14 100.0
pod 8 8 100.0
total 118 124 95.1


line stmt bran cond sub pod time code
1             package MVC::Neaf::Exception;
2              
3 95     95   70792 use strict;
  95         251  
  95         2838  
4 95     95   496 use warnings;
  95         182  
  95         4305  
5             our $VERSION = '0.2800_01';
6              
7             =head1 NAME
8              
9             MVC::Neaf::Exception - Exception class for Not Even A Framework.
10              
11             =head1 DESCRIPTION
12              
13             Currently internal signalling or L is based on the exception
14             mechanism. To avoid collisions with user's exceptions or Perl errors,
15             these internal exceptions are blessed into this class.
16              
17             Please see the neaf_err() function in L.
18              
19             By convention, C and Cnew( nnn )>
20             will be treated exactly the same by Neaf.
21              
22             B This file is mostly used internally by Neaf
23             and may change with little to no warning.
24             Please file a bug/feature request demanding a more stable interface
25             if you plan to rely on it.
26              
27             B.
28              
29             =cut
30              
31 95     95   608 use Scalar::Util qw(blessed);
  95         215  
  95         4794  
32 95     95   632 use Carp;
  95         322  
  95         5640  
33 95     95   2017 use overload '""' => "as_string";
  95         1328  
  95         678  
34              
35 95     95   8334 use MVC::Neaf::Util qw(bare_html_escape);
  95         238  
  95         72817  
36              
37             =head1 METHODS
38              
39             =head2 new( $@ || 500, %options )
40              
41             =head2 new( %options )
42              
43             Returns a new exception object.
44              
45             %options may include any keys as well as some Neaf-like control keys:
46              
47             =over
48              
49             =item * -status - alias for first argument.
50             If starts with 3 digits, will result in a "http error page" exception,
51             otherwise is reset to 500 and reason is updated.
52              
53             =item * -reason - details about what happened
54              
55             =item * -headers - array or hash of headers, just like that of a normal reply.
56              
57             =item * -location - indicates a redirection
58              
59             =item * -sudden - this was not an expected error (die 404 or redirect)
60             This will automatically turn on if -status cannot be parsed.
61              
62             =item * -file - where error happened
63              
64             =item * -line - where error happened
65              
66             =item * -nocaller - don't try to determine error origin via caller
67              
68             =back
69              
70             =cut
71              
72             sub new {
73 56     56 1 1514 my $class = shift;
74 56 100       253 if (@_ % 2) {
75 6         14 my $err = shift;
76 6         20 push @_, -status => $err;
77             };
78 56         240 my %opt = @_;
79              
80             # TODO 0.30 bad rex will catch garbage if under 'C:\Program files'
81 56 50 100     1088 ($opt{-status} || '')
82             =~ qr{^(?:(\d\d\d)\s*)?(.*?)(?:\s+at (\S+) line (\d+)\.?)?$}s
83             or die "NEAF: Bug: Regex failed unexpectedly for q{$opt{-status}}";
84              
85 56   100     370 $opt{-status} = $1 || 500;
86 56   100     610 $opt{-reason} ||= $2 || $1 || 'unknown error';
      66        
87 56   100     355 $opt{-sudden} ||= !$1;
88 56 100       306 my @caller = $opt{-nocaller} ? () : (caller(0));
89 56   100     672 $opt{-file} ||= $3 || $caller[1];
      66        
90 56   100     535 $opt{-line} ||= $4 || $caller[2];
      66        
91              
92 56         322 return bless \%opt, $class;
93             };
94              
95             =head2 status()
96              
97             Return error code.
98              
99             =cut
100              
101             sub status {
102 66     66 1 210 my $self = shift;
103 66         507 return $self->{-status};
104             };
105              
106             =head2 is_sudden()
107              
108             Tells whether error was unexpected.
109              
110             B. Name and meaning subject to change.
111              
112             =cut
113              
114             sub is_sudden {
115 92     92 1 1654 my $self = shift;
116 92 100       1387 return $self->{-sudden} ? 1 : 0;
117             };
118              
119             =head2 as_string()
120              
121             Stringify.
122              
123             Result will start with C if error was generated via
124             C or a redirect.
125              
126             Otherwise it would look similar to the original -status.
127              
128             =cut
129              
130             sub as_string {
131 9     9 1 3398 my $self = shift;
132              
133             return ($self->{-sudden} ? '' : "MVC::Neaf: ")
134 9 100       57 .($self->{-location} ? "See $self->{-location}: " : '')
    100          
135             . $self->reason;
136             };
137              
138             =head2 make_reply( $request )
139              
140             Returns a refault error HTML page.
141              
142             The default page is guaranteen to contain
143             the status as its one and only C<< >> element,
144             the unique request-id as one and only C<< >> element,
145             and the location (if any) as its one and only C<< >> element.
146              
147             This page used to be a JSON but it turned out hard to debug
148             when dealing with javascript.
149              
150             =cut
151              
152             sub make_reply {
153 43     43 1 156 my ($self, $req) = @_;
154              
155 43         223 my $code = $self->{-status};
156 43         99 my $redirect = '';
157 43         263 my $request_id = $req->id;
158 43 100       563 my @headers = @{ $self->{-headers} || [] };
  43         305  
159 43 100       251 if (my $where = $self->{-location}) {
160 3         9 unshift @headers, Location => $where;
161 3         10 $where = bare_html_escape( $where );
162 3         12 $redirect = qq{

See $where

};
163             };
164              
165             # An in-place template to avoid rendering
166             # don't worry, be stupid!
167 43         264 my $content = qq{
168            
169             Error $code
170            
171            
172            

Error $code

173            

Request-id:$request_id

174             $redirect
175            
176             Powered by Not even a framework.
177            
178            
179             };
180              
181             return {
182             -status => $self->{-status},
183 43         532 -content => $content,
184             -type => 'text/html; charset=utf8',
185             -headers => \@headers,
186             };
187             };
188              
189             =head2 reason()
190              
191             Returns error message that was expected to cause the error.
192              
193             =cut
194              
195             sub reason {
196 21     21 1 124 my $self = shift;
197              
198 21   50     124 return ($self->{-reason} || "Unknown error") . $self->file_and_line;
199             };
200              
201             =head2 file_and_line
202              
203             Return " at /foo/bar line 42" suffix, if both file and line are available.
204             Empty string otherwise.
205              
206             =cut
207              
208             sub file_and_line {
209 23     23 1 107 my $self = shift;
210             return ($self->{-file} && $self->{-line})
211 23 100 66     320 ? " at $self->{-file} line $self->{-line}"
212             : ''
213             };
214              
215             =head2 TO_JSON()
216              
217             Converts exception to JSON, so that it doesn't frighten View::JS.
218              
219             =cut
220              
221             sub TO_JSON {
222 1     1 1 3 my $self = shift;
223 1         14 return { %$self };
224             };
225              
226             =head1 LICENSE AND COPYRIGHT
227              
228             This module is part of L suite.
229              
230             Copyright 2016-2023 Konstantin S. Uvarin C.
231              
232             This program is free software; you can redistribute it and/or modify it
233             under the terms of either: the GNU General Public License as published
234             by the Free Software Foundation; or the Artistic License.
235              
236             See L for more information.
237              
238             =cut
239              
240             1;