view release on metacpan or  search on metacpan

t/gzip.t  view on Meta::CPAN

   my $reason = 'x-non-gzip-reason: incompatible content-type foo/bar' . $eol;
   my $header = CGI->new(q{})->header(-Type => 'foo/bar');

   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip type "$compare"`;
   msgs_match($out, $reason . $header.$compare, 'Un-Gzipped with -Type flag');
}

# CGI redirection and compression
{
   my $reason = 'x-non-gzip-reason: HTTP status not 200' . $eol;
   my $expected_header = CGI->new(q{})->redirect($redir);

   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip redirect "$redir"`;
   msgs_match($out, $reason . $expected_header, 'CGI redirect');
}

# unbuffered CGI
{
   my $reason = 'x-non-gzip-reason: user agent does not want gzip' . $eol;
   my $out = `$basecmd simple "$compare"`;
   msgs_match($out, $reason . $compareheader.$compare, 'unbuffered CGI');
}

# Simulated mod_perl
{
   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip mod_perl "$compare"`;
   msgs_match($out, $gzip . $compareheader . $zcompare, 'mod_perl simulation');
}

# Double print header
{
   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip doublehead "$compare"`;
   msgs_match($out, $gzip . $compareheader . $zcompare, 'double header');
}

# redirected filehandle
{
   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip fh1 "$compare"`;
   msgs_match($out, $gzip . $compareheader . $zcompare, 'filehandle, fh=STDOUT plus select');
}

# redirected filehandle
{
   local $TODO = 'Explicit use of filehandles not yet supported';

   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip fh2 "$compare"`;
   msgs_match($out, $gzip . $compareheader . $zcompare, 'filehandle, explict STDOUT');
}

# redirected filehandle
{
   local $TODO = 'Explicit use of filehandles not yet supported';

   my $out = `$basecmd -DHTTP_ACCEPT_ENCODING=gzip fh3 "$compare"`;
   msgs_match($out, $gzip . $compareheader . $zcompare, 'filehandle, explicit fh');
}

sub msgs_match {
   my ($got, $expected, $message) = @_;
   ## no critic (RegularExpressions::RequireLineBoundaryMatching)
   my ($got_head, $got_body) = split m/\015\012\015\012/xs, $got, 2;
   my ($exp_head, $exp_body) = split m/\015\012\015\012/xs, $expected, 2;
   my %exp = map {lc($_) => 1} split m/\015\012/xs, $exp_head;
   for my $got_head_line (split m/\015\012/xs, $got_head) {
      if (!delete $exp{lc $got_head_line}) {
         return is($got, $expected, $message . ' -- extra header: ' . $got_head_line); # fail
      }
   }
   if (scalar keys %exp) {
      return is($got, $expected, $message . ' -- missing header: ' . [keys %exp]->[0]); # fail
   }
   if ($got_body ne $exp_body) {
      return is($got, $expected, $message . ' -- bodies do not match'); # fail
   }
   return pass($message);
}