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

use strict;
use warnings;
package Exception::Reporter::Dumpable::File 0.015;
# ABSTRACT: a dumpable object for a file on disk

#pod =head1 SYNOPSIS
#pod
#pod   $reporter->report_exception(
#pod     [
#pod       ...,
#pod       [ import_file => Exception::Reporter::Dumpable::File->new(
#pod                          $path_to_file,
#pod                          { mimetype => 'text/csv', charset => 'us-ascii' },
#pod                        ) ],
#pod     ]
#pod   );
#pod
#pod This class exists to provide a simple way to tell Exception::Reporter to
#pod include a file from disk.  To make this useful, you should also include
#pod L in your summarizers.
#pod
#pod Right now, file content is read as soon as the file is constructed.  This may
#pod change in the future.
#pod
#pod =cut

sub _err_msg {
  my ($class, $path, $msg) = @_;
  return "(file at <$path> was requested for dumping, but $msg)";
}

#pod =method new
#pod
#pod   my $file_dumpable = Exception::Reporter::Dumpable::File->new(
#pod     $path,
#pod     \%arg,
#pod   );
#pod
#pod Useful arguments are:
#pod
#pod   mimetype - defaults to a guess by extension or application/octet-stream
#pod   charset  - defaults to utf-8 for text, undef otherwise
#pod   max_size - the maximum size to include; if the file is larger, a placeholder
#pod              will be included instead
#pod
#pod If the file object can't be constructed, B.  This to
#pod avoid requiring exception handling in your exception handling.  Instead, C
#pod I which will then be summarized as any other string.
#pod
#pod Maybe this will change in the future, and the file summarizer will know how to
#pod expect File::Error objects, or something like that.
#pod
#pod =cut

sub new {
  my ($class, $path, $arg) = @_;
  $arg ||= {};

  return $class->_err_msg($path, 'does not exist') unless -e $path;

  my $realpath = -l $path ? readlink $path : $path;

  return $class->_err_msg($path, 'is not a normal file') unless -f $realpath;

  return $class->_err_msg($path, "can't be read") unless -r $realpath;

  if ($arg->{max_size}) {
    my $size = -s $realpath;
    if ($size > $arg->{max_size}) {
      return $class->_err_msg(
        $path,
        "its size $size " . "exceeds maximum allowed size $arg->{max_size}"
      );
    }
  }

  my $guts = { path => $path };

  $guts->{mimetype} = $arg->{mimetype}
                   || $class->_mimetype_from_filename($path)
                   || 'application/octet-stream';

  $guts->{charset} = $arg->{charset}
                  || $guts->{mimetype} =~ m{\Atext/} ? 'utf-8' : undef;

  open my $fh, '<', $path
    or return $class->_err_msg("there was an error reading it: $!");

  my $contents = do { local $/; <$fh> };

  $guts->{contents_ref} = \$contents;

  bless $guts => $class;
}

sub path     { $_[0]->{path} }
sub mimetype { $_[0]->{mimetype} }
sub charset  { $_[0]->{charset} }
sub contents_ref { $_[0]->{contents_ref} }

# replace with MIME::Type or something -- rjbs, 2012-07-03
my %LOOKUP = (
  txt  => 'text/plain',
  html => 'text/html',
);

sub _mimetype_from_filename {
  my ($class, $filename) = @_;

  my ($extension) = $filename =~ m{\.(.+?)\z};
  return unless $extension;

  return $LOOKUP{ $extension };
}

1;

__END__