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