File Coverage

blib/lib/Plack/Middleware/HTMLLint.pm
Criterion Covered Total %
statement 25 27 92.5
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 34 36 94.4


line stmt bran cond sub pod time code
1             package Plack::Middleware::HTMLLint;
2 2     2   17223 use 5.008_001;
  2         5  
  2         63  
3 2     2   8 use strict;
  2         2  
  2         121  
4 2     2   10 use warnings;
  2         5  
  2         103  
5              
6             our $VERSION = '0.03';
7              
8 2     2   472 use parent qw/ Plack::Middleware /;
  2         259  
  2         12  
9              
10             use constant +{
11 2         197 PSGI_STATUS => 0,
12             PSGI_HEADER => 1,
13             PSGI_BODY => 2,
14 2     2   13749 };
  2         4  
15              
16             use constant +{
17 2         124 SYNTAX_HTML5 => 'html5',
18             SYNTAX_HTML4 => 'html4',
19             SYNTAX_XHTML => 'xhtml',
20 2     2   12 };
  2         2  
21              
22 2     2   10 use Plack::Util;
  2         2  
  2         46  
23 2     2   9 use Plack::Util::Accessor qw/error2html/;
  2         3  
  2         11  
24 2     2   638 use HTML::Lint;
  0            
  0            
25             use HTML::Escape qw/escape_html/;
26              
27             sub prepare_app {
28             my $self = shift;
29             unless ($self->error2html) {
30             $self->error2html(sub {
31             my @errors = @_;
32              
33             my @error_html;
34             push @error_html => '
';
35             push @error_html => '

HTML Error

';
36             push @error_html => '
';
37             foreach my $error (@errors) {
38             push @error_html => '
', escape_html($error->errcode), '
';
39             push @error_html => '
', escape_html($error->as_string), '
';
40             }
41             push @error_html => '';
42              
43             push @error_html => '';
44              
45             return join '', @error_html;
46             });
47             }
48             }
49              
50             sub call {
51             my($self, $env) = @_;
52              
53             return $self->response_cb($self->app->($env), sub {
54             my $res = shift;
55             my $content_type = Plack::Util::header_get($res->[PSGI_HEADER], 'Content-Type') || '';
56              
57             if ($content_type =~ m{^(?:text/x?html|application/xhtml\+xml)\b}io) {# HTML/XHTML
58             my $do_lint = sub {
59             my $content = shift;
60              
61             my $syntax = ($content =~ /^$/imo) ? SYNTAX_HTML5:
62             ($content_type =~ m{^(?:text/xhtml|application/xhtml\+xml)\b}io) ? SYNTAX_XHTML:
63             SYNTAX_HTML4;
64              
65             if (my @errors = $self->html_lint($syntax => $content)) {
66             return $self->error2html->(@errors);
67             }
68             else {
69             return '';
70             }
71             };
72              
73             if ($res->[PSGI_BODY]) {
74             my $content = '';
75             Plack::Util::foreach($res->[PSGI_BODY] => sub { $content .= $_[0] });
76             if (my $error_html = $do_lint->($content)) {
77             unless ($content =~ s{]*)>}{$error_html}i) {
78             ## fallback
79             $content .= $error_html;
80             }
81             $res->[PSGI_BODY] = [$content];
82             }
83             }
84             else {
85             # XXX: It has become increasingly complex not to block the stream as possible.
86             my $buffer = '';
87             my $html_last_buffer = '';
88             my $end_of_html_body = 0;
89             my $do_lint_finished = 0;
90             return sub {
91             my $body_chunk = shift;
92             if (defined $body_chunk) {
93             $buffer .= $body_chunk;
94             if ($end_of_html_body || $body_chunk =~ m{}io) {
95             $end_of_html_body = 1;
96             $html_last_buffer .= $body_chunk;
97             return '';
98             }
99             else {
100             return $body_chunk;
101             }
102             }
103             else {
104             if ($do_lint_finished) {
105             return;
106             }
107             else {
108             my $error_html = $do_lint->($buffer);
109             if ($error_html) {
110             unless ($html_last_buffer =~ s{}{$error_html}i) {
111             ## fallback
112             $html_last_buffer = $error_html . $html_last_buffer;
113             }
114             }
115              
116             $do_lint_finished = 1;
117             return $html_last_buffer;
118             }
119             }
120             };
121             }
122             }
123              
124             return;
125             });
126             }
127              
128             sub html_lint {
129             my($self, $syntax, $content) = @_;
130              
131             my $lint = HTML::Lint->new;
132             $lint->parse($content);
133             $lint->eof;
134              
135             return $lint->errors;
136             }
137              
138             1;
139             __END__