1#!/usr/bin/env perl 2package HTML::RewriteAttributes::Resources; 3use strict; 4use warnings; 5use base 'HTML::RewriteAttributes'; 6use URI; 7 8our $VERSION = '0.03'; 9 10my %rewritable_attrs = ( 11 bgsound => { src => 1 }, 12 body => { background => 1 }, 13 img => { src => 1 }, 14 input => { src => 1 }, 15 table => { background => 1 }, 16 td => { background => 1 }, 17 th => { background => 1 }, 18 tr => { background => 1 }, 19); 20 21sub _rewrite { 22 my $self = shift; 23 my $html = shift; 24 my $cb = shift; 25 my %args = @_; 26 27 $self->{rewrite_inline_css_cb} = $args{inline_css}; 28 $self->{rewrite_inline_imports} = $args{inline_imports}; 29 $self->{rewrite_inline_imports_seen} = {}; 30 31 $self->SUPER::_rewrite($html, $cb); 32} 33 34sub _should_rewrite { 35 my ($self, $tag, $attr) = @_; 36 37 return ( $rewritable_attrs{$tag} || {} )->{$attr}; 38} 39 40sub _invoke_callback { 41 my $self = shift; 42 my ($tag, $attr, $value) = @_; 43 44 return $self->{rewrite_callback}->($value, tag => $tag, attr => $attr, rewriter => $self); 45} 46 47sub _start_tag { 48 my $self = shift; 49 my ($tag, $attr, $attrseq, $text) = @_; 50 51 if ($self->{rewrite_inline_css_cb}) { 52 if ($tag eq 'link' and defined $attr->{type} and $attr->{type} eq 'text/css' and defined $attr->{href}) { 53 my $content = $self->_import($attr->{href}); 54 if (defined $content) { 55 $content = $self->_handle_imports($content, $attr->{href}); 56 $self->{rewrite_html} .= "\n<style type=\"text/css\""; 57 $self->{rewrite_html} .= " media=\"$attr->{media}\"" if $attr->{media}; 58 $self->{rewrite_html} .= ">\n<!--\n$content\n-->\n</style>\n"; 59 return; 60 } 61 } 62 if ($tag eq 'style' and defined $attr->{type} and $attr->{type} eq 'text/css') { 63 $self->{rewrite_look_for_style} = 1; 64 } 65 } 66 67 $self->SUPER::_start_tag(@_); 68} 69 70sub _default { 71 my ($self, $tag, $attrs, $text) = @_; 72 if (delete $self->{rewrite_look_for_style}) { 73 $text = $self->_handle_imports($text, '.'); 74 } 75 76 $self->SUPER::_default($tag, $attrs, $text); 77} 78 79sub _handle_imports { 80 my $self = shift; 81 my $content = shift; 82 my $base = shift; 83 84 return $content if !$self->{rewrite_inline_imports}; 85 86 # here we both try to preserve comments *and* ignore any @import 87 # statements that are in comments 88 $content =~ s{ 89 ( /\* .*? \*/ ) 90 | 91 (//[^\n]*) 92 | 93 \@import \s* " ([^"]+) " \s* ; 94 }{ 95 defined($1) ? $1 96 : defined($2) ? $2 97 : $self->_import($self->_absolutify($3, $base)) 98 }xsmeg; 99 100 return $content; 101} 102 103sub _absolutify { 104 my $self = shift; 105 my $path = shift; 106 my $base = shift; 107 108 my $uri = URI->new($path); 109 unless (defined $uri->scheme) { 110 $uri = $uri->abs($base); 111 } 112 113 return $uri->as_string; 114} 115 116sub _import { 117 my $self = shift; 118 my $path = shift; 119 120 return '' if $self->{rewrite_inline_imports_seen}{$path}++; 121 122 my $content = "\n/* $path */\n" 123 . $self->{rewrite_inline_css_cb}->($path); 124 return $self->_handle_imports($content, $path); 125} 126 1271; 128 129__END__ 130 131=head1 NAME 132 133HTML::RewriteAttributes::Resources - concise resource-link rewriting 134 135=head1 SYNOPSIS 136 137 # writing some HTML email I see.. 138 $html = HTML::RewriteAttributes::Resources->rewrite($html, sub { 139 my $uri = shift; 140 my $content = render_template($uri); 141 my $cid = generate_cid_from($content); 142 $mime->attach($cid => content); 143 return "cid:$cid"; 144 }); 145 146 # need to inline CSS too? 147 $html = HTML::RewriteAttributes::Resources->rewrite($html, sub { 148 # see above 149 }, 150 inline_css => sub { 151 my $uri = shift; 152 return render_template($uri); 153 }); 154 155 # need to inline CSS and follow @imports? 156 $html = HTML::RewriteAttributes::Resources->rewrite($html, sub { 157 # see above 158 }, 159 inline_css => sub { 160 # see above 161 }, inline_imports => 1); 162 163=head1 DESCRIPTION 164 165C<HTML::RewriteAttributes::Resources> is a special case of 166L<HTML::RewriteAttributes> for rewriting links to resources. This is to 167facilitate generating, for example, HTML email in an extensible way. 168 169We don't care about how to fetch resources and attach them to the MIME object; 170that's your job. But you don't have to care about how to rewrite the HTML. 171 172=head1 METHODS 173 174=head2 C<new> 175 176You don't need to call C<new> explicitly - it's done in L</rewrite>. It takes 177no arguments. 178 179=head2 C<rewrite> HTML, callback[, args] -> HTML 180 181See the documentation of L<HTML::RewriteAttributes>. 182 183The callback receives as arguments the resource URI (the attribute value), then, in a hash, C<tag> and C<attr>. 184 185=head3 Inlining CSS 186 187C<rewrite> can automatically inline CSS for you. 188 189Passing C<inline_css> will invoke that callback to inline C<style> tags. The 190callback receives as its argument the URI to a CSS file, and expects as a 191return value the contents of that file, so that it may be inlined. Returning 192C<undef> prevents any sort of inlining. 193 194Passing C<inline_imports> (a boolean) will look at any inline CSS and call 195the C<inline_css> callback to inline that import. 196 197This keeps track of what CSS has already been inlined, and won't inline a 198particular CSS file more than once (to prevent import loops). 199 200=head1 SEE ALSO 201 202L<HTML::RewriteAttributes>, L<HTML::Parser>, L<Email::MIME::CreateHTML> 203 204=head1 AUTHOR 205 206Shawn M Moore, C<< <sartak@bestpractical.com> >> 207 208=head1 LICENSE 209 210Copyright 2008-2010 Best Practical Solutions, LLC. 211HTML::RewriteAttributes::Resources is distributed under the same terms as Perl itself. 212 213=cut 214 215