view release on metacpan or  search on metacpan

t/cgi.t  view on Meta::CPAN

  local $ENV{QUERY_STRING} = 'foo=bar';
  local $ENV{REMOTE_ADDR} = '127.0.0.1';
  local $ENV{REMOTE_HOST} = 'localhost';
  local $ENV{REMOTE_IDENT} = 'somebody';
  local $ENV{REMOTE_USER} = 'user';
  local $ENV{REQUEST_METHOD} = 'POST';
  local $ENV{SCRIPT_NAME} = '/test.cgi';
  local $ENV{SERVER_NAME} = 'localhost';
  local $ENV{SERVER_PORT} = '80';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  local $ENV{SERVER_SOFTWARE} = "CGI::Tiny/$CGI::Tiny::VERSION";
  my $auth_str = encode_base64 'user:password', '';
  local $ENV{HTTP_AUTHORIZATION} = "Basic $auth_str";
  local $ENV{HTTP_CONTENT_LENGTH} = length $text;
  local $ENV{HTTP_CONTENT_TYPE} = 'text/plain;charset=UTF-8';
  open my $in_fh, '<', \$text or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  my ($headers, $auth_header, $content_length_header, %vars);
  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    foreach my $key ((map { lc } @env_keys), qw(method path query)) { $vars{$key} = $_->$key }
    $headers = $_->headers;
    $auth_header = $_->header('Authorization');
    $content_length_header = $_->header('Content-Length');
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok defined($response->{headers}{date}), 'Date set';
  like $response->{status}, qr/^200\b/, '200 response status';
  is $vars{auth_type}, 'Basic', 'right AUTH_TYPE';
  is $vars{content_length}, length($text), 'right CONTENT_LENGTH';
  is $vars{content_type}, 'text/plain;charset=UTF-8', 'right CONTENT_TYPE';
  is $vars{gateway_interface}, 'CGI/1.1', 'right GATEWAY_INTERFACE';
  is $vars{path_info}, '/foo', 'right PATH_INFO';
  is $vars{path_translated}, '/path/to/foo', 'right PATH_TRANSLATED';
  is $vars{query_string}, 'foo=bar', 'right QUERY_STRING';
  is $vars{remote_addr}, '127.0.0.1', 'right REMOTE_ADDR';
  is $vars{remote_host}, 'localhost', 'right REMOTE_HOST';
  is $vars{remote_ident}, 'somebody', 'right REMOTE_IDENT';
  is $vars{remote_user}, 'user', 'right REMOTE_USER';
  is $vars{request_method}, 'POST', 'right REQUEST_METHOD';
  is $vars{script_name}, '/test.cgi', 'right SCRIPT_NAME';
  is $vars{server_name}, 'localhost', 'right SERVER_NAME';
  is $vars{server_port}, '80', 'right SERVER_PORT';
  is $vars{server_protocol}, 'HTTP/1.0', 'right SERVER_PROTOCOL';
  is $vars{server_software}, "CGI::Tiny/$CGI::Tiny::VERSION", 'right SERVER_SOFTWARE';
  is $vars{method}, 'POST', 'right method';
  is $vars{path}, '/foo', 'right path';
  is $vars{query}, 'foo=bar', 'right query';
  is $headers->{authorization}, "Basic $auth_str", 'right Authorization header';
  is $headers->{'content-length'}, length($text), 'right Content-Length header';
  is $headers->{'content-type'}, 'text/plain;charset=UTF-8', 'right Content-Type header';
  is $auth_header, "Basic $auth_str", 'right Authorization header';
  is $content_length_header, length($text), 'right Content-Length header';
};

subtest 'Cookies' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  local $ENV{HTTP_COOKIE} = 'a=b; c=42; x=; a=c';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  my ($cookies, $cookie_names, $a_cookie, $a_cookies, $b_cookie);
  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    $cookies = $_->cookies;
    $cookie_names = $_->cookie_names;
    $a_cookie = $_->cookie('a');
    $a_cookies = $_->cookie_array('a');
    $b_cookie = $_->cookie('b');
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok defined($response->{headers}{date}), 'Date set';
  like $response->{status}, qr/^200\b/, '200 response status';
  is_deeply $cookies, [['a', 'b'], ['c', 42], ['x', ''], ['a', 'c']], 'right cookies';
  is_deeply $cookie_names, ['a', 'c', 'x'], 'right cookie names';
  is $a_cookie, 'c', 'right cookie value';
  is_deeply $a_cookies, ['b', 'c'], 'right cookie values';
  ok !defined $b_cookie, 'no cookie value';
};

subtest 'Not found' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    $_->set_response_status(404);
    $_->render(text => '');
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
  is $response->{headers}{'content-length'}, 0, 'right Content-Length';
  like $response->{status}, qr/^404\b/, '404 response status';
  ok !length($response->{body}), 'empty response body';
};

subtest 'Data response (fixed length)' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';

t/cgi.t  view on Meta::CPAN

  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  my $url = '/foo';
  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    $_->set_response_status(100)->render(redirect => $url);
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
  is $response->{headers}{'content-length'}, 0, 'right Content-Length';
  is $response->{headers}{location}, $url, 'Location set';
  like $response->{status}, qr/^302\b/, '302 response status';
  ok defined($response->{headers}{date}), 'Date set';
  ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
  ok !length($response->{body}), 'empty response body';
};

subtest 'Response headers' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  my @headers = (
    ['X-Test', 'some value'],
    ['X-test', 'another value'],
  );
  my @cookies = (
    ['foo', 'bar', Domain => 'example.com', HttpOnly => 1, 'Max-Age' => 3600, Path => '/test', SameSite => 'Strict', Secure => 1],
    ['x', '', Expires => 'Sun, 06 Nov 1994 08:49:37 GMT', HttpOnly => 0, SameSite => 'Lax', Secure => 0],
  );
  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    foreach my $header (@headers) { $_->add_response_header(@$header) }
    foreach my $cookie (@cookies) { $_->add_response_cookie(@$cookie) }
    $_->set_response_type('image/gif');
    $_->set_response_disposition(attachment => 'foo.gif');
    $_->set_response_status(202);
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok defined($response->{headers}{'content-type'}), 'Content-Type set';
  is $response->{headers}{'content-type'}, 'image/gif', 'right content type';
  is $response->{headers}{'content-disposition'}, 'attachment; filename="foo.gif"; filename*=UTF-8\'\'foo.gif', 'right Content-Disposition';
  like $response->{status}, qr/^202\b/, '202 response status';
  is_deeply $response->{headers}{'x-test'}, ['some value', 'another value'], 'right custom headers';
  is_deeply $response->{headers}{'set-cookie'},
    ['foo=bar; Domain=example.com; HttpOnly; Max-Age=3600; Path=/test; SameSite=Strict; Secure',
     'x=; Expires=Sun, 06 Nov 1994 08:49:37 GMT; SameSite=Lax'], 'right Set-Cookie headers';
};

subtest 'Reset response headers' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  my @headers = (
    ['X-Test', 'some value'],
    ['X-test', 'another value'],
  );
  my @cookies = (
    ['foo', 'bar'],
  );
  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    foreach my $header (@headers) { $_->add_response_header(@$header) }
    foreach my $cookie (@cookies) { $_->add_response_cookie(@$cookie) }
    $_->set_response_type('image/gif');
    $_->set_response_status(400);
    $_->set_response_disposition(attachment => 'foo.gif');
    $_->reset_response_headers;
    $_->set_response_type(undef);
    $_->set_response_status(200);
    $_->set_response_disposition('inline');
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data);
  ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
  ok !defined $response->{headers}{'content-disposition'}, 'Content-Disposition not set';
  like $response->{status}, qr/^200\b/, '200 response status';
  ok !defined $response->{headers}{'x-test'}, 'custom headers reset';
  ok !defined $response->{headers}{'set-cookie'}, 'Set-Cookie headers reset';
};

subtest 'NPH response' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  local $ENV{SERVER_SOFTWARE} = "CGI::Tiny/$CGI::Tiny::VERSION";
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    $_->set_nph;
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data, 1);
  like $response->{start_line}, qr/^HTTP\/1.0\b/, 'right start line';
  ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
  is $response->{headers}{server}, "CGI::Tiny/$CGI::Tiny::VERSION", 'right Server header';
  like $response->{status}, qr/^200\b/, '200 response status';
  ok defined($response->{headers}{date}), 'Date set';
  ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
  ok !length($response->{body}), 'empty response body';
};

subtest 'NPH error response' => sub {
  local @ENV{@env_keys} = ('')x@env_keys;
  local $ENV{PATH_INFO} = '/';
  local $ENV{REQUEST_METHOD} = 'GET';
  local $ENV{SCRIPT_NAME} = '/';
  local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
  open my $in_fh, '<', \(my $in_data = '') or die "failed to open handle for input: $!";
  open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";

  cgi {
    $_->set_input_handle($in_fh);
    $_->set_output_handle($out_fh);
    $_->set_nph(1);
    $_->set_response_status(404);
    $_->set_response_type('text/plain');
    $_->render;
  };

  ok length($out_data), 'response rendered';
  my $response = _parse_response($out_data, 1);
  like $response->{start_line}, qr/^HTTP\/1.0\b/, 'right start line';
  ok defined($response->{headers}{'content-type'}), 'Content-Type set';
  is $response->{headers}{'content-type'}, 'text/plain', 'right content type';
  like $response->{status}, qr/^404\b/, '404 response status';
  ok !length($response->{body}), 'empty response body';
};

done_testing;