File Coverage

blib/lib/HTML/RewriteAttributes/Resources.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	18	22	81.8
condition	11	17	64.7
subroutine	12	12	100.0
pod			n/a
total	103	113	91.1

#!/usr/bin/env perl
package HTML::RewriteAttributes::Resources;
use strict;
use warnings;
use base 'HTML::RewriteAttributes';
use URI;

our $VERSION = '0.03';

my %rewritable_attrs = (
    bgsound => { src        => 1 },
    body    => { background => 1 },
    img     => { src        => 1 },
    input   => { src        => 1 },
    table   => { background => 1 },
    td      => { background => 1 },
    th      => { background => 1 },
    tr      => { background => 1 },
);

sub _rewrite {
    my $self = shift;
    my $html = shift;
    my $cb   = shift;
    my %args = @_;

    $self->{rewrite_inline_css_cb} = $args{inline_css};
    $self->{rewrite_inline_imports} = $args{inline_imports};
    $self->{rewrite_inline_imports_seen} = {};

    $self->SUPER::_rewrite($html, $cb);
}

sub _should_rewrite {
    my ($self, $tag, $attr) = @_;

    return ( $rewritable_attrs{$tag} || {} )->{$attr};
}

sub _invoke_callback {
    my $self = shift;
    my ($tag, $attr, $value) = @_;

    return $self->{rewrite_callback}->($value, tag => $tag, attr => $attr, rewriter => $self);
}

sub _start_tag {
    my $self = shift;
    my ($tag, $attr, $attrseq, $text) = @_;

    if ($self->{rewrite_inline_css_cb}) {
        if ($tag eq 'link' and defined $attr->{type} and $attr->{type} eq 'text/css' and defined $attr->{href}) {
            my $content = $self->_import($attr->{href});
            if (defined $content) {
                $content = $self->_handle_imports($content, $attr->{href});
                $self->{rewrite_html} .= "\n
</tr>

<tr>
<td  class="h" >
<a name="57">57</a>
</td>

<td  class="c3" >

7

</td>

<td  class="c3" >
 <a href="blib-lib-HTML-RewriteAttributes-Resources-pm--branch.html#57-1"> 
100
 </a> 
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

36

</td>

<td class="s">                 $self->{rewrite_html} .= " media=\"$attr->{media}\"" if $attr->{media}; </td>
</tr>

<tr>
<td  class="h" >
<a name="58">58</a>
</td>

<td  class="c3" >

7

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

23

</td>

<td class="s">                 $self->{rewrite_html} .= ">\n<!--\n$content\n-->\n\n";
                return;
            }
        }
        if ($tag eq 'style' and defined $attr->{type} and $attr->{type} eq 'text/css') {
            $self->{rewrite_look_for_style} = 1;
        }
    }

    $self->SUPER::_start_tag(@_);
}

sub _default {
    my ($self, $tag, $attrs, $text) = @_;
    if (delete $self->{rewrite_look_for_style}) {
        $text = $self->_handle_imports($text, '.');
    }

    $self->SUPER::_default($tag, $attrs, $text);
}

sub _handle_imports {
    my $self    = shift;
    my $content = shift;
    my $base    = shift;

    return $content if !$self->{rewrite_inline_imports};

    # here we both try to preserve comments *and* ignore any @import
    # statements that are in comments
    $content =~ s{
        ( /\* .*? \*/ )
        |
        (//[^\n]*)
        |
        \@import \s* " ([^"]+) " \s* ;
    }{
          defined($1) ? $1
        : defined($2) ? $2
        : $self->_import($self->_absolutify($3, $base))
    }xsmeg;

    return $content;
}

sub _absolutify {
    my $self = shift;
    my $path = shift;
    my $base = shift;

    my $uri = URI->new($path);
    unless (defined $uri->scheme) {
        $uri = $uri->abs($base);
    }

    return $uri->as_string;
}

sub _import {
    my $self = shift;
    my $path = shift;

    return '' if $self->{rewrite_inline_imports_seen}{$path}++;

    my $content = "\n/* $path */\n"
                . $self->{rewrite_inline_css_cb}->($path);
    return $self->_handle_imports($content, $path);
}

1;

__END__