view release on metacpan or  search on metacpan

lib/CGI/Compress/Gzip.pm  view on Meta::CPAN

   return $header;
}

# Enable the compression filehandle if:
#  - The mime-type is appropriate (text/* is the default)
#  - The programmer wants compression, indicated by the useCompression()
#    method
#  - Client wants compression, indicated by the Accepted-Encoding HTTP field
#  - The IO::Zlib compression library is available
# Returns: (boolean, reason) -- reason is a string if boolean is false
# Side effects:
#   - may alter $header to add gzip flag if boolean is true
#   - may set $global_can_compress if not yet set

sub _can_compress ## no critic(Subroutines::ProhibitExcessComplexity)
{
   my ($self, $header) = @_;
   # $header is an array ref

   my $settings = $self->{'.CGIgz'};

   # Check programmer preference
   if (defined $settings->{use_compression} ?
       !$settings->{use_compression} : !$global_use_compression)
   {
      return (0, 'programmer request');
   }

   # save it in case we change it
   $settings->{flush} = $OUTPUT_AUTOFLUSH;

   # Check buffering (disable if autoflushing)
   if ($settings->{flush})
   {
      return (0, 'programmer wants unbuffered output');
   }

   # Check that browser supports gzip
   my $acc = $ENV{HTTP_ACCEPT_ENCODING};
   if (!$acc || $acc !~ m/ \bgzip\b /ixms)
   {
      return (0, 'user agent does not want gzip');
   }

   # Parse the header data and look for indicators of compressibility:
   #  * appropriate content type
   #  * already set for compression
   #  * HTTP status not 200

   my @newheader;
   my $content_type;

   # This search reproduces the header parsing done by CGI.pm
   if (@{$header} && $header->[0] =~ m/ \A [a-z] /xms) ## no critic (ProhibitEnumeratedClasses)
   {

      # Using unkeyed version of arguments - convert to the keyed version

      # arg order comes from the header() function in CGI.pm
      my @flags = qw(
         Content_Type Status Cookie Target Expires
         NPH Charset Attachment P3P
      );
      for my $i (0 .. $#{$header})
      {
         if ($i < @flags)
         {
            push @newheader, q{-} . $flags[$i], $header->[$i];
         }
         else
         {
            # Extra args
            push @newheader, $header->[$i];
         }
      }
   }
   else
   {
      @newheader = @{$header};
   }

   # gets set if we find an existing encoding directive
   my $encoding_index;

   for (my $i = 0; $i < @newheader; $i++)
   {
      next if (!defined $newheader[$i]);

      if ($newheader[$i] =~ m/ \A -?(?:Content[-_]Type|Type)(.*) \z /ixms)
      {
         $content_type = $1;
         if ($content_type !~ s/ \A :\s* //xms)
         {
            $content_type = $newheader[++$i];
         }
      }
      elsif ($newheader[$i] =~ m/ \A -?Status(.*) \z /ixms)
      {
         my $content = $1;
         if ($content !~ s/ \A :\s* //xms)
         {
            $content = $newheader[++$i];
         }
         my ($status) = $content =~ m/ \A (\d+) /xms;
         if (!defined $status || $status ne '200')
         {
            return (0, 'HTTP status not 200');
         }
      }
      elsif ($newheader[$i] =~ m/ \A -?Content[-_]Encoding(.*) \z /ixms)
      {
         my $content = $1;
         if ($content !~ s/ \A :\s* //xms)
         {
            $content = $newheader[++$i];
         }
         $encoding_index = $i;
         
         if ($content =~ m/ \bgzip\b /ixms)
         {
            # Already gzip compressed

lib/CGI/Compress/Gzip.pm  view on Meta::CPAN

=head1 CAVEATS

=head2 Apache::Registry

Under Apache::Registry, global variables may not go out of scope in
time.  This may causes timing bugs, since this module makes use of
the DESTROY() method.  To avoid this issue, make sure your CGI
object is stored in a scoped variable.

   # BROKEN CODE
   use CGI::Compress::Gzip;
   $q = CGI::Compress::Gzip->new;
   print $q->header;
   print "Hello, world\n";
   
   # WORKAROUND CODE
   use CGI::Compress::Gzip;
   do {
     my $q = CGI::Compress::Gzip->new;
     print $q->header;
     print "Hello, world\n";
   }

=head2 Filehandles

This module works by changing the default filehandle.  It does not
change STDOUT at all.  As a consequence, your programs should call
C<print> without a filehandle argument.

   # BROKEN CODE
   use CGI::Compress::Gzip;
   my $q = CGI::Compress::Gzip->new;
   print STDOUT $q->header;
   print STDOUT "Hello, world\n";
   
   # WORKAROUND CODE
   use CGI::Compress::Gzip;
   my $q = CGI::Compress::Gzip->new;
   print $q->header;
   print "Hello, world\n";

Future versions may steal away STDOUT and replace it with the
compression filehandle, but that seemed too risky for this version.

=head2 Header Munging

When sending compressed output, the HTTP headers must remain
uncompressed.  So, this module goes to great effort to keep the
headers and body separate.  That has led to CGI::header() emulation
code that is a little brittle.  Most potential problems arise because
STDOUT gets tweaked as soon as header() is called.

If you use the CGI.pm header() API as specified in CGI.pm, then all
should go well.  But if you do anything unusual, this module may
break.  For example:

   # BROKEN CODE
   use CGI::Compress::Gzip;
   my $q = CGI::Compress::Gzip->new;
   print "Set-Cookie: foo=bar\n" . $q->header;
   print "Hello, world\n";

   # WORKAROUND 1 (preferred)
   use CGI::Compress::Gzip;
   my $q = CGI::Compress::Gzip->new;
   print $q->header("-Set_Cookie" => "foo=bar");
   print "Hello, world\n";

   # WORKAROUND 2
   use CGI::Compress::Gzip;
   my $q = CGI::Compress::Gzip->new;
   print "Set-Cookie: foo=bar\n";
   print $q->header;
   print "Hello, world\n";

Future versions could try to parse the header to look for its end rather
than insisting that the printed version match the version returned by
header().  Patches would be very welcome.

=head1 SEE ALSO

CGI::Compress::Gzip depends on CGI and IO::Zlib.  Similar
functionality is available from mod_gzip, Apache::Compress or
Apache::GzipChain, however all of those require changes to the
webserver configuration.

=head1 AUTHOR

Chris Dolan

This module was originally developed by me at Clotho Advanced Media
Inc.  Now I maintain it in my spare time.

=head1 ACKNOWLEDGMENTS

Clotho greatly appreciates the assistance and feedback the community
has extended to help refine this module.

Thanks to Rhesa Rozendaal who noticed the -Type omission in v0.17.

Thanks to Laga Mahesa who did some Windows testing and
experimentation.

Thanks to Slaven Rezic who 1) found several header handling bugs, 2)
discovered the Apache::Registry and Filehandle caveats, 3) provided a
patch incorporated into v0.17, and 4) persisted with smoke tests that
reproduced the envvar problem fixed in v0.23.

Thanks to Jan Willamowius who found a header handling bug.

Thanks to Andreas J. Koenig and brian d foy for module naming advice.

=head1 HELP WANTED

If you like this module, please help by testing on Windows or in a
C<FastCGI> environment, since I have neither available for easy testing.

Personally, I don't use this module much anymore as all of my work is on
Catalyst and mod_perl now.

=cut