view release on metacpan or  search on metacpan

t/headers/cgi-mode.t  view on Meta::CPAN

# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
use strict;
use warnings;
use Test::More tests => 160;
use HTTP::Headers;
use HTTP::Status qw(:constants);
use IO::Capture::Stderr;
use JSON;
use XML::XPath;
use English qw(-no_match_vars);
use Carp;

use lib qw(t/headers/lib t/lib);
use t::request;
use t::model::response;
use t::view::response;

#########
# database setup
#
no warnings qw(redefine once);
local $ENV{dev} = 'live';
unlink 't/headers/data/headers.sql3';
local *ClearPress::util::data_path = sub { return 't/headers/data'; };
my $dbh = ClearPress::util->new->dbh;
$dbh->do(q[create table response (code int primary key, name char(32))]) or croak qq[could not create table];
$dbh->commit();

my $runner = sub {
  my ($headers_ref, $content_ref, $config) = @_;

  my $response = t::request->new($config);

  my ($header_str, $content) = $response =~ m{^(.*?\n)\n(.*)$}smix;
  my $headers = HTTP::Headers->new();

  for my $line (split /\n/smx, $header_str) {
    my ($k, $v) = split m{\s*:\s*}smx, $line, 2;
    $headers->header($k, $v);
  }

  ${$headers_ref} = $headers;
  ${$content_ref} = $content;

  return 1;
};

{
  my $sets = [
	      [ '',     'text/html',        sub { my $arg=shift; return $arg;                                       } ], # plain # <p class="error">
	      [ '.js',  'application/json', sub { my $arg=shift; return JSON->new->decode($arg)->{error};           } ], # json
	      [ '.csv', 'text/csv',         sub { my $arg=shift; return [split /[\r\n]+/smix, $arg]->[0];           } ], # csv
	      [ '.xml', 'text/xml',         sub { my $arg=shift; return XML::XPath->new(xml=>$arg)->find('/error'); } ], # xml
	     ];

  my $tests = [
	       ['/t', '/no_config',    'GET', '', HTTP_NOT_FOUND,             'No such view (no_config)', 'no config'],
	       ['/t', '/no_model',     'GET', '', HTTP_INTERNAL_SERVER_ERROR, 'Failed to instantiate no_model model', 'no model'],
	       ['/t', '/response/200', 'GET', '', HTTP_OK,                    '', '200 response'], # extractors look for error blocks, so can't check "code=200" here
	       ['/t', '/response/301', 'GET', '', HTTP_MOVED_PERMANENTLY,     '', '301 redirect'],
	       ['/t', '/response/302', 'GET', '', HTTP_FOUND,                 '', '302 moved'],
	       ['/t', '/response/403', 'GET', '', HTTP_FORBIDDEN,             '', '403 forbidden'],
	       ['/t', '/response/404', 'GET', '', HTTP_NOT_FOUND,             '', '404 not found'],
	       ['/t', '/response/500', 'GET', '', HTTP_INTERNAL_SERVER_ERROR, '', '500 error'],
	       ['/t', '/response/999', 'GET', '', HTTP_INTERNAL_SERVER_ERROR, 'Application Error', '999 failure'],

	       ['/t', '/no_config',    'POST', '', HTTP_NOT_FOUND,             '', 'no config'],
	       ['/t', '/no_model',     'POST', '', HTTP_INTERNAL_SERVER_ERROR, '', 'no model'],
	       ['/t', '/response/200', 'POST', '', HTTP_OK,                    '', '200 response'], # extractors look for error blocks, so can't check "code=200" here
	       ['/t', '/response/301', 'POST', '', HTTP_MOVED_PERMANENTLY,     '', '301 redirect'],
	       ['/t', '/response/302', 'POST', '', HTTP_FOUND,                 '', '302 moved'],
	       ['/t', '/response/403', 'POST', '', HTTP_FORBIDDEN,             '', '403 forbidden'],
	       ['/t', '/response/404', 'POST', '', HTTP_NOT_FOUND,             '', '404 not found'],
	       ['/t', '/response/500', 'POST', '', HTTP_INTERNAL_SERVER_ERROR, '', '500 error'],
	       ['/t', '/response/999', 'POST', '', HTTP_INTERNAL_SERVER_ERROR, 'Application Error', '999 failure'], # update non-existent entity
	      ];

  my $skips = [
               ['GET',  '/no_config.csv'    ],
               ['GET',  '/no_model.csv'     ],
               ['GET',  '/response/999.csv' ],
               ['POST', '/response/999.csv' ],
              ];
  for my $set (@{$sets}) {
    my ($extension, $content_type, $extraction) = @{$set};

    for my $t (@{$tests}) {

      my ($script_name, $path_info, $method, $username, $status, $errstr, $msg) = @{$t};
      $path_info .= $extension;

      my $cap = IO::Capture::Stderr->new;
      $cap->start;
      my ($headers, $content);
      $runner->(\$headers, \$content,
		{
		 SCRIPT_NAME    => $script_name,
		 PATH_INFO      => $path_info,