1package CGI::Compress::Gzip::FileHandle; 2 3use 5.006; 4use warnings; 5use strict; 6use English qw(-no_match_vars); 7use Compress::Zlib; 8 9use base qw(IO::Zlib); 10our $VERSION = '1.03'; 11 12#=encoding utf8 13 14=for stopwords zlib 15 16=head1 NAME 17 18CGI::Compress::Gzip::FileHandle - CGI::Compress::Gzip helper package 19 20=head1 LICENSE 21 22Copyright 2006-2007 Clotho Advanced Media, Inc., <cpan@clotho.com> 23 24Copyright 2007-2008 Chris Dolan <cdolan@cpan.org> 25 26This library is free software; you can redistribute it and/or modify it 27under the same terms as Perl itself. 28 29=head1 SYNOPSIS 30 31 use CGI::Compress::Gzip; 32 33 my $cgi = new CGI::Compress::Gzip; 34 print $cgi->header(); 35 print "<html> ..."; 36 37=head1 DESCRIPTION 38 39This is intended for internal use only! Use CGI::Compress::Gzip 40instead. 41 42This CGI::Compress::Gzip helper class subclasses IO::Zlib. It is 43is needed to make sure that output is not compressed until the CGI 44header is emitted. This filehandle delays the ignition of the zlib 45filter until it sees the exact same header generated by 46CGI::Compress::Gzip::header() pass through it's WRITE() method. If 47you change the header before printing it, this class will throw an 48exception. 49 50This class holds one global variable representing the previous default 51filehandle used before the gzip filter is put in place. This 52filehandle, usually STDOUT, is replaced after the gzip stream finishes 53(which is usually when the CGI object goes out of scope and is 54destroyed). 55 56=head1 FUNCTIONS 57 58=over 59 60=item OPEN 61 62Overrides IO::Zlib::OPEN. This method doesn't actually do anything -- 63it just stores it's arguments for a later call to SUPER::OPEN in 64WRITE(). The reason is that we may not have seen the header yet, so 65we don't yet know whether to compress output. 66 67=cut 68 69sub OPEN 70{ 71 my ($self, $fh, @args) = @_; 72 73 # Delay opening until after the header is printed. 74 $self->{out_fh} = $fh; 75 $self->{openargs} = \@args; 76 $self->{outtype} = undef; 77 $self->{buffer} = q{}; 78 $self->{pending_header} = q{}; 79 return $self; 80} 81 82=item WRITE buffer, length, offset 83 84Emit the uncompressed header followed by the compressed body. 85 86=cut 87 88sub WRITE 89{ 90 my ($self, $buf, $length, $offset) = @_; 91 92 # Appropriated from IO::Zlib: 93 if ($length > length $buf) 94 { 95 die 'bad LENGTH'; 96 } 97 if (defined $offset && $offset != 0) 98 { 99 die 'OFFSET not supported'; 100 } 101 102 my $bytes = 0; 103 if ($self->{pending_header}) 104 { 105 # Side effects: $buf and $self->{pending_header} are trimmed 106 $bytes = $self->_print_header(\$buf, $length); 107 $length -= $bytes; 108 } 109 return $bytes if (!$length); # if length is zero, there's no body content to print 110 111 if (!defined $self->{outtype}) 112 { 113 # Determine whether we can stream data to the output filehandle 114 115 # default case: no, cannot stream 116 $self->{outtype} = 'block'; 117 118 # Mod perl already does funky filehandle stuff, so don't stream 119 my $is_mod_perl = ($ENV{MOD_PERL} || 120 ($ENV{GATEWAY_INTERFACE} && 121 $ENV{GATEWAY_INTERFACE} =~ m/ \A CGI-Perl\/ /xms)); 122 123 my $type = ref $self->{out_fh}; 124 125 if (!$is_mod_perl && $type) 126 { 127 my $is_glob = $type eq 'GLOB' && defined $self->{out_fh}->fileno(); 128 my $is_filehandle = ($type !~ m/ \A GLOB|SCALAR|HASH|ARRAY|CODE \z /xms && 129 $self->{out_fh}->can('fileno') && 130 defined $self->{out_fh}->fileno()); 131 132 if ($is_glob || $is_filehandle) 133 { 134 # Complete delayed open 135 if (!$self->SUPER::OPEN($self->{out_fh}, @{$self->{openargs}})) 136 { 137 die 'Failed to open the compressed output stream'; 138 } 139 140 $self->{outtype} = 'stream'; 141 } 142 } 143 } 144 145 if ($self->{outtype} eq 'stream') 146 { 147 $bytes += $self->SUPER::WRITE($buf, $length, $offset); 148 } 149 else 150 { 151 $self->{buffer} .= $buf; 152 $bytes += length $buf; 153 } 154 155 return $bytes; 156} 157 158sub _print_header 159{ 160 my ($self, $buf, $length) = @_; 161 162 my $header = $self->{pending_header}; 163 if ($length < length $header) 164 { 165 $self->{pending_header} = substr $header, $length; 166 $header = substr $header, 0, $length; 167 } 168 else 169 { 170 $self->{pending_header} = q{}; 171 } 172 173 if (${$buf} !~ s/ \A \Q$header\E //xms) 174 { 175 die 'Expected to print the CGI header'; 176 } 177 178 my $out_fh = $self->{out_fh}; 179 if (!print {$out_fh} $header) 180 { 181 die 'Failed to print the uncompressed CGI header'; 182 } 183 184 return length $header; 185} 186 187=item CLOSE 188 189Flush the compressed output. 190 191=cut 192 193sub CLOSE 194{ 195 my ($self) = @_; 196 197 my $out_fh = $self->{out_fh}; 198 $self->{out_fh} = undef; # clear it, so we can't write to it after this method ends 199 200 my $result; 201 if ($self->{outtype} && $self->{outtype} eq 'stream') 202 { 203 $result = $self->SUPER::CLOSE(); 204 if (!$result) 205 { 206 die "Failed to close gzip $OS_ERROR"; 207 } 208 } 209 else 210 { 211 print {$out_fh} Compress::Zlib::memGzip($self->{buffer}); 212 $result = 1; 213 } 214 215 return $result; 216} 217 2181; 219__END__ 220 221=back 222 223=head1 AUTHOR 224 225Clotho Advanced Media, I<cpan@clotho.com> 226 227Primary developer: Chris Dolan 228 229=cut 230