File Coverage

lib/Email/MIME/CreateHTML/Resolver.pm
Criterion Covered Total %
statement 44 44 100.0
branch 27 30 90.0
condition 12 17 70.5
subroutine 8 9 88.8
pod 2 4 50.0
total 93 104 89.4


line stmt bran cond sub pod time code
1             ###############################################################################
2             # Purpose : Pick the most appropriate resolver
3             # Author : John Alden
4             # Created : Aug 2006
5             ###############################################################################
6              
7             package Email::MIME::CreateHTML::Resolver;
8              
9 3     3   803 use strict;
  3         6  
  3         80  
10 3     3   12 use Carp;
  3         13  
  3         146  
11 3     3   17 use Scalar::Util ();
  3         6  
  3         114  
12              
13             our $VERSION = '1.042';
14              
15 3     3   16 use vars qw($HaveCache $HaveLWP $HaveFilesystem);
  3         5  
  3         2045  
16              
17             $HaveCache = 0;
18             eval {
19             require Email::MIME::CreateHTML::Resolver::Cached;
20             $HaveCache = 1;
21             };
22              
23             $HaveLWP = 0;
24             eval {
25             require Email::MIME::CreateHTML::Resolver::LWP;
26             $HaveLWP = 1;
27             };
28              
29             $HaveFilesystem = 0;
30             eval {
31             require Email::MIME::CreateHTML::Resolver::Filesystem;
32             $HaveFilesystem = 1;
33             };
34              
35              
36             #
37             # API
38             #
39              
40             sub new {
41 30     30 1 713 my ($class, $args) = @_;
42 30   100     83 $args ||= {};
43              
44             #Do some sanity checking of inputs
45 30         48 my $resolver = $args->{resolver};
46 30 100       59 if(defined $resolver) {
47 3 100       149 confess "resolver must be an object" unless Scalar::Util::blessed($resolver);
48 2 100       114 confess "resolver does not seem to use the expected interface (get_resource)" unless ($resolver->can('get_resource'));
49             }
50              
51 28         39 my $object_cache = $args->{'object_cache'};
52 28 100       50 if(defined $object_cache ) {
53 8 100       252 confess "object_cache must be an object" unless Scalar::Util::blessed($object_cache);
54 7 100 66     139 confess "object_cache does not seem to use the expected cache interface (get and set methods)"
55             unless ($object_cache->can('get') && $object_cache->can('set'));
56 6 50       13 warn("Caching support is not available - object_cache will not be used") unless($HaveCache);
57             }
58              
59             #Construct object
60 26         87 my $self = bless ({
61             %$args
62             }, $class);
63 26         81 return $self;
64             }
65              
66             sub get_resource {
67 11     11 1 22 my ($self, $uri) = @_;
68 11 100 66     218 croak("get_resource without a URI") unless(defined $uri && length($uri));
69 10         20 my $resolver = $self->_select_resolver($uri);
70 10         30 return $resolver->get_resource($uri);
71             }
72              
73             #
74             # Private methods
75             #
76              
77             sub _select_resolver {
78 19     19   62 my ($self, $uri) = @_;
79              
80             #Look at the start of the URI
81 19 100 66     66 my $start = (defined $self->{base} && length($self->{base}))? $self->{base} : $uri;
82            
83             #Pick an appropriate resolver...
84 19         25 my $resolver;
85 19 100       33 if($self->{resolver}) {
86             #If we've been told to use a specific resolver we'll respect that
87 1         3 $resolver = $self->{resolver};
88             } else {
89             #Decide on the best resolver to use - does URL start with protocol://
90 18         52 TRACE("Start is $start");
91 18 100 66     90 if($HaveFilesystem && $start =~ /^file:\/\//){
    100          
92             #Push file URLs through filesystem resolver if available (so File::Policy gets applied)
93 1         4 $resolver = new Email::MIME::CreateHTML::Resolver::Filesystem($self);
94             } elsif($start =~ /^\w+:\/\//) {
95 3 50       9 die("External URLs in emails cannot be resolved without the LWP resolver (which is currently not installed)\n") unless($HaveLWP);
96 3         15 $resolver = new Email::MIME::CreateHTML::Resolver::LWP($self);
97             } else {
98 14 50       28 die("Local URLs in emails cannot be resolved without the Filesystem resolver (which is currently not installed)\n") unless($HaveFilesystem);
99 14         63 $resolver = new Email::MIME::CreateHTML::Resolver::Filesystem($self);
100             }
101             }
102              
103             #Optionally wrap it with caching
104 19 100 66     82 if($HaveCache && defined $self->{'object_cache'} ) {
105 4         23 $resolver = new Email::MIME::CreateHTML::Resolver::Cached({resolver => $resolver, object_cache => $self->{'object_cache'}});
106             }
107            
108 19         88 return $resolver;
109             }
110              
111       18 0   sub TRACE {}
112       0 0   sub DUMP {}
113              
114             1;
115              
116              
117             =head1 NAME
118              
119             Email::MIME::CreateHTML::Resolver - provides the appropriate resource resolver
120              
121             =head1 SYNOPSIS
122              
123             my $o = new Email::MIME::CreateHTML::Resolver(\%args)
124             my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
125              
126             =head1 DESCRIPTION
127              
128             This is used by Email::MIME::CreateHTML to load resources.
129              
130             =head1 METHODS
131              
132             =over 4
133              
134             =item $o = new Email::MIME::CreateHTML::Resolver(\%args)
135              
136             =item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
137              
138             =back
139              
140             =head1 AUTHOR
141              
142             Tony Hennessy, Simon Flack and John Alden with additional contributions by
143             Ricardo Signes and Henry Van Styn
144              
145             =head1 COPYRIGHT
146              
147             (c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
148              
149             See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
150              
151             =cut