| 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 |