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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
package CGI::Compress::Gzip::FileHandle;
use 5.006;
use warnings;
use strict;
use English qw(-no_match_vars);
use Compress::Zlib;
use base qw(IO::Zlib);
our $VERSION = '1.03';
#=encoding utf8
=for stopwords zlib
=head1 NAME
CGI::Compress::Gzip::FileHandle - CGI::Compress::Gzip helper package
=head1 LICENSE
Copyright 2006-2007 Clotho Advanced Media, Inc., <cpan@clotho.com>
Copyright 2007-2008 Chris Dolan <cdolan@cpan.org>
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 SYNOPSIS
use CGI::Compress::Gzip;
my $cgi = new CGI::Compress::Gzip;
print $cgi->header();
print "<html> ...";
=head1 DESCRIPTION
This is intended for internal use only! Use CGI::Compress::Gzip
instead.
This CGI::Compress::Gzip helper class subclasses IO::Zlib. It is
is needed to make sure that output is not compressed until the CGI
header is emitted. This filehandle delays the ignition of the zlib
filter until it sees the exact same header generated by
CGI::Compress::Gzip::header() pass through it's WRITE() method. If
you change the header before printing it, this class will throw an
exception.
This class holds one global variable representing the previous default
filehandle used before the gzip filter is put in place. This
filehandle, usually STDOUT, is replaced after the gzip stream finishes
(which is usually when the CGI object goes out of scope and is
destroyed).
=head1 FUNCTIONS
=over
=item OPEN
Overrides IO::Zlib::OPEN. This method doesn't actually do anything --
it just stores it's arguments for a later call to SUPER::OPEN in
WRITE(). The reason is that we may not have seen the header yet, so
we don't yet know whether to compress output.
=cut
sub OPEN
{
my ($self, $fh, @args) = @_;
# Delay opening until after the header is printed.
$self->{out_fh} = $fh;
$self->{openargs} = \@args;
$self->{outtype} = undef;
$self->{buffer} = q{};
$self->{pending_header} = q{};
return $self;
}
=item WRITE buffer, length, offset
Emit the uncompressed header followed by the compressed body.
=cut
sub WRITE
{
my ($self, $buf, $length, $offset) = @_;
# Appropriated from IO::Zlib:
if ($length > length $buf)
{
die 'bad LENGTH';
}
if (defined $offset && $offset != 0)
{
die 'OFFSET not supported';
}
my $bytes = 0;
if ($self->{pending_header})
{
# Side effects: $buf and $self->{pending_header} are trimmed
$bytes = $self->_print_header(\$buf, $length);
$length -= $bytes;
}
return $bytes if (!$length); # if length is zero, there's no body content to print
if (!defined $self->{outtype})
{
# Determine whether we can stream data to the output filehandle
# default case: no, cannot stream
$self->{outtype} = 'block';
# Mod perl already does funky filehandle stuff, so don't stream
my $is_mod_perl = ($ENV{MOD_PERL} ||
($ENV{GATEWAY_INTERFACE} &&
$ENV{GATEWAY_INTERFACE} =~ m/ \A CGI-Perl\/ /xms));
my $type = ref $self->{out_fh};
if (!$is_mod_perl && $type)
{
my $is_glob = $type eq 'GLOB' && defined $self->{out_fh}->fileno();
my $is_filehandle = ($type !~ m/ \A GLOB|SCALAR|HASH|ARRAY|CODE \z /xms &&
$self->{out_fh}->can('fileno') &&
defined $self->{out_fh}->fileno());
if ($is_glob || $is_filehandle)
{
# Complete delayed open
if (!$self->SUPER::OPEN($self->{out_fh}, @{$self->{openargs}}))
{
die 'Failed to open the compressed output stream';
}
$self->{outtype} = 'stream';
}
}
}
if ($self->{outtype} eq 'stream')
{
$bytes += $self->SUPER::WRITE($buf, $length, $offset);
}
else
{
$self->{buffer} .= $buf;
$bytes += length $buf;
}
return $bytes;
}
sub _print_header
{
my ($self, $buf, $length) = @_;
my $header = $self->{pending_header};
if ($length < length $header)
{
$self->{pending_header} = substr $header, $length;
$header = substr $header, 0, $length;
}
else
{
$self->{pending_header} = q{};
}
if (${$buf} !~ s/ \A \Q$header\E //xms)
{
die 'Expected to print the CGI header';
}
my $out_fh = $self->{out_fh};
if (!print {$out_fh} $header)
{
die 'Failed to print the uncompressed CGI header';
}
return length $header;
}
=item CLOSE
Flush the compressed output.
=cut
sub CLOSE
{
my ($self) = @_;
my $out_fh = $self->{out_fh};
$self->{out_fh} = undef; # clear it, so we can't write to it after this method ends
my $result;
if ($self->{outtype} && $self->{outtype} eq 'stream')
{
$result = $self->SUPER::CLOSE();
if (!$result)
{
die "Failed to close gzip $OS_ERROR";
}
}
else
{
print {$out_fh} Compress::Zlib::memGzip($self->{buffer});
$result = 1;
}
return $result;
}
1;
__END__
=back
=head1 AUTHOR
Clotho Advanced Media, I<cpan@clotho.com>
Primary developer: Chris Dolan
=cut
|
