File Coverage

blib/lib/Exception/Reporter/Dumpable/File.pm
Criterion Covered Total %
statement 28 35 80.0
branch 8 18 44.4
condition 4 7 57.1
subroutine 8 9 88.8
pod 1 5 20.0
total 49 74 66.2


line stmt bran cond sub pod time code
1 1     1   370 use strict;
  1         1  
  1         22  
2 1     1   3 use warnings;
  1         2  
  1         975  
3             package Exception::Reporter::Dumpable::File;
4             # ABSTRACT: a dumpable object for a file on disk
5             $Exception::Reporter::Dumpable::File::VERSION = '0.013';
6             #pod =head1 SYNOPSIS
7             #pod
8             #pod $reporter->report_exception(
9             #pod [
10             #pod ...,
11             #pod [ import_file => Exception::Reporter::Dumpable::File->new(
12             #pod $path_to_file,
13             #pod { mimetype => 'text/csv', charset => 'us-ascii' },
14             #pod ) ],
15             #pod ]
16             #pod );
17             #pod
18             #pod This class exists to provide a simple way to tell Exception::Reporter to
19             #pod include a file from disk. To make this useful, you should also include
20             #pod L in your summarizers.
21             #pod
22             #pod Right now, file content is read as soon as the file is constructed. This may
23             #pod change in the future.
24             #pod
25             #pod =cut
26              
27             sub _err_msg {
28 1     1   2 my ($class, $path, $msg) = @_;
29 1         4 return "(file at <$path> was requested for dumping, but $msg)";
30             }
31              
32             #pod =method new
33             #pod
34             #pod my $file_dumpable = Exception::Reporter::Dumpable::File->new(
35             #pod $path,
36             #pod \%arg,
37             #pod );
38             #pod
39             #pod Useful arguments are:
40             #pod
41             #pod mimetype - defaults to a guess by extension or application/octet-stream
42             #pod charset - defaults to utf-8 for text, undef otherwise
43             #pod max_size - the maximum size to include; if the file is larger, a placeholder
44             #pod will be included instead
45             #pod
46             #pod If the file object can't be constructed, B. This to
47             #pod avoid requiring exception handling in your exception handling. Instead, C
48             #pod I which will then be summarized as any other string.
49             #pod
50             #pod Maybe this will change in the future, and the file summarizer will know how to
51             #pod expect File::Error objects, or something like that.
52             #pod
53             #pod =cut
54              
55             sub new {
56 2     2 1 3921 my ($class, $path, $arg) = @_;
57 2   100     7 $arg ||= {};
58              
59 2 100       34 return $class->_err_msg($path, 'does not exist') unless -e $path;
60              
61 1 50       8 my $realpath = -l $path ? readlink $path : $path;
62              
63 1 50       6 return $class->_err_msg($path, 'is not a normal file') unless -f $realpath;
64              
65 1 50       7 return $class->_err_msg($path, "can't be read") unless -r $realpath;
66              
67 1 50       3 if ($arg->{max_size}) {
68 0         0 my $size = -s $realpath;
69 0 0       0 if ($size > $arg->{max_size}) {
70 0         0 return $class->_err_msg(
71             $path,
72             "its size $size " . "exceeds maximum allowed size $arg->{max_size}"
73             );
74             }
75             }
76              
77 1         3 my $guts = { path => $path };
78              
79             $guts->{mimetype} = $arg->{mimetype}
80 1   50     3 || $class->_mimetype_from_filename($path)
81             || 'application/octet-stream';
82              
83             $guts->{charset} = $arg->{charset}
84 1 50 33     4 || $guts->{mimetype} =~ m{\Atext/} ? 'utf-8' : undef;
85              
86 1 50       23 open my $fh, '<', $path
87             or return $class->_err_msg("there was an error reading it: $!");
88              
89 1         1 my $contents = do { local $/; <$fh> };
  1         3  
  1         17  
90              
91 1         2 $guts->{contents_ref} = \$contents;
92              
93 1         11 bless $guts => $class;
94             }
95              
96 2     2 0 73 sub path { $_[0]->{path} }
97 2     2 0 6 sub mimetype { $_[0]->{mimetype} }
98 4     4 0 16 sub charset { $_[0]->{charset} }
99 2     2 0 5 sub contents_ref { $_[0]->{contents_ref} }
100              
101             # replace with MIME::Type or something -- rjbs, 2012-07-03
102             my %LOOKUP = (
103             txt => 'text/plain',
104             html => 'text/html',
105             );
106              
107             sub _mimetype_from_filename {
108 0     0     my ($class, $filename) = @_;
109              
110 0           my ($extension) = $filename =~ m{\.(.+?)\z};
111 0 0         return unless $extension;
112              
113 0           return $LOOKUP{ $extension };
114             }
115              
116             1;
117              
118             __END__