File Coverage

blib/lib/SockJS/Transport/HtmlFile.pm
Criterion Covered Total %
statement 47 54 87.0
branch 9 12 75.0
condition 3 5 60.0
subroutine 7 7 100.0
pod 0 2 0.0
total 66 80 82.5


line stmt bran cond sub pod time code
1             package SockJS::Transport::HtmlFile;
2              
3 1     1   454 use strict;
  1         2  
  1         29  
4 1     1   4 use warnings;
  1         2  
  1         27  
5              
6 1     1   5 use base 'SockJS::Transport::Base';
  1         2  
  1         443  
7              
8             sub new {
9 5     5 0 12288 my $self = shift->SUPER::new(@_);
10 5         9 my (%params) = @_;
11              
12 5   50     18 $self->{response_limit} = $params{response_limit} || 128 * 1024;
13              
14 5         34 push @{$self->{allowed_methods}}, 'GET';
  5         15  
15              
16 5         12 return $self;
17             }
18              
19             sub dispatch_GET {
20 5     5 0 33 my $self = shift;
21 5         12 my ($env, $conn) = @_;
22              
23 5         30 my ($callback) = $env->{QUERY_STRING} =~ m/(?:^|&|;)c=([^&;]+)/;
24 5 100       15 if (!$callback) {
25 1         5 return [500, [], ['"callback" parameter required']];
26             }
27              
28 4         17 $callback =~ s/%(..)/chr(hex($1))/eg;
  0         0  
29 4 100       15 if ($callback !~ m/^[a-zA-Z0-9-_\.]+$/) {
30 1         5 return [500, [], ['invalid "callback" parameter']];
31             }
32              
33 3         6 my $limit = $self->{response_limit};
34              
35             return sub {
36 3     3   414 my $respond = shift;
37              
38 3         23 my $writer = $respond->(
39             [
40             200,
41             [
42             'Content-Type' => 'text/html; charset=UTF-8',
43             'Connection' => 'close',
44             ]
45             ]
46             );
47              
48 3 100 66     18 if ($conn->is_connected && !$conn->is_reconnecting) {
49 1         5 my $message = $self->_wrap_message(
50             'c[2010,"Another connection still open"]' . "\n");
51 1         12 $writer->write($message);
52 1         54 $writer->close;
53 1         39 return;
54             }
55              
56             $conn->write_cb(
57             sub {
58 2         3 my $conn = shift;
59 2         5 my ($message) = @_;
60              
61 2         5 $limit -= length($message) - 1;
62              
63 2         5 $writer->write($self->_wrap_message($message));
64              
65 2 50       89 if ($limit <= 0) {
66 0         0 $writer->close;
67              
68 0         0 $conn->reconnecting;
69             }
70             }
71 2         15 );
72              
73 2         9 $conn->close_cb(sub { $writer->close });
  0         0  
74              
75 2         35 $writer->write(<<"EOF" . (' ' x 1024));
76            
77            
78            
79            
80            

Don't panic!

81            
88             EOF
89              
90 2         165 $conn->write('o');
91              
92 2 50       5 if ($conn->is_closed) {
    50          
93 0         0 $conn->connected;
94 0         0 $conn->close;
95             }
96             elsif ($conn->is_connected) {
97 0         0 $conn->reconnected;
98             }
99             else {
100 2         5 $conn->connected;
101             }
102 3         32 };
103             }
104              
105             sub _wrap_message {
106 3     3   4 my $self = shift;
107 3         6 my ($message) = @_;
108              
109 3         19 $message =~ s/(['""\\\/\n\r\t]{1})/\\$1/smg;
110 3         30 return qq{\r\n};
111             }
112              
113             1;