/usr/share/perl5/Email/MIME/CreateHTML/Resolver/LWP.pm is in libemail-mime-createhtml-perl 1.030-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | ###############################################################################
# Purpose : Load resources using LWP
# Author : John Alden
# Created : Aug 2006
# CVS : $Header: /home/cvs/software/cvsroot/email/lib/Email/MIME/CreateHTML/Resolver/LWP.pm,v 1.7 2006/08/24 21:41:38 johna Exp $
###############################################################################
package Email::MIME::CreateHTML::Resolver::LWP;
use strict;
use Carp;
use MIME::Types;
use LWP::UserAgent;
use vars qw($VERSION);
$VERSION = sprintf "%d.%03d", q$Revision: 1.7 $ =~ /: (\d+)\.(\d+)/;
sub new {
my ($class, $options) = @_;
$options ||= {};
my $ua = LWP::UserAgent->new(agent => __PACKAGE__);
$ua->env_proxy;
# Stop us getting cached resources when they have been updated on the server
$ua->default_header( 'Cache-Control' => 'no-cache' );
$ua->default_header( 'Pragma' => 'no-cache' );
my $self = {
%$options,
'UA' => $ua,
};
return bless($self, $class);
}
#Resource loader using LWP
sub get_resource {
my ($self, $src) = @_;
my $base = $self->{base};
#Resolve URIs relative to optional base URI
my $uri;
if(defined $base) {
require URI::WithBase;
$uri = URI::WithBase->new_abs( $src, $base );
} else {
$uri = new URI($src);
}
#Fetch resource from URI using LWP
my $response = $self->{UA}->get($uri->as_string);
croak( "Could not fetch ".$uri->as_string." : ".$response->status_line ) unless ($response->is_success);
my $content = $response->content;
DUMP("HTTP response", $response);
#Filename
my $path = $uri->path;
my ($volume,$directories,$filename) = File::Spec->splitpath( $path );
#Deduce MIME type and transfer encoding
my ($mimetype, $encoding);
if(defined $filename && length($filename)) {
TRACE("Using file extension to deduce MIME type and transfer encoding");
($mimetype, $encoding) = MIME::Types::by_suffix($filename);
} else {
$filename = 'index';
}
#If we have a content-type header we can make a more informed guess at MIME type
if ($response->header('content-type')) {
$mimetype = $response->header('content-type');
TRACE("Content Type header: $mimetype");
$mimetype = $1 if($mimetype =~ /(\S+);\s*charset=(.*)$/); #strip down to just a MIME type
}
#If all else fails then some conservative and general-purpose defaults are:
$mimetype ||= 'application/octet-stream';
$encoding ||= 'base64';
#Return values expected from a resource callback
return ($content, $filename, $mimetype, $encoding);
}
sub TRACE {}
sub DUMP {}
1;
=head1 NAME
Email::MIME::CreateHTML::Resolver::LWP - uses LWP as a resource resolver
=head1 SYNOPSIS
my $o = new Email::MIME::CreateHTML::Resolver::LWP(\%args)
my ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=head1 DESCRIPTION
This is used by Email::MIME::CreateHTML to load resources.
=head1 METHODS
=over 4
=item $o = new Email::MIME::CreateHTML::Resolver::LWP(\%args)
%args can contain:
=over 4
=item base
Base URI to resolve URIs passed to get_resource.
=back
=item ($content,$filename,$mimetype,$xfer_encoding) = $o->get_resource($uri)
=back
=head1 VERSION
$Revision: 1.7 $ on $Date: 2006/08/24 21:41:38 $ by $Author: johna $
=head1 AUTHOR
Tony Hennessy, Simon Flack and John Alden
=head1 COPYRIGHT
(c) BBC 2005,2006. This program is free software; you can redistribute it and/or modify it under the GNU GPL.
See the file COPYING in this distribution, or http://www.gnu.org/licenses/gpl.txt
=cut
|