Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 127 lines (114 sloc) 3.157 kb
b80ead56 »
2010-09-29 Treat tied vars in the response properly
1 #!perl
2 use warnings;
3 use strict;
4 use Test::More tests => 25;
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
5 use Test::Fatal;
b80ead56 »
2010-09-29 Treat tied vars in the response properly
6 use utf8;
7 use lib 't'; use Utils;
8
9 BEGIN { use_ok('Feersum') };
10
11 my ($socket,$port) = get_listen_socket();
12 ok $socket, "made listen socket";
13 ok $socket->fileno, "has a fileno";
14
15 my $evh = Feersum->new();
16 $evh->use_socket($socket);
17
18 {
19 package My::MagicScalar;
20 use Tie::Scalar;
21 use base 'Tie::StdScalar';
22 sub FETCH {
23 my $self = shift;
24 return uc($self->SUPER::FETCH(@_));
25 }
26 }
27
28 {
29 package My::MagicArray;
30 use Tie::Array;
31 use base 'Tie::StdArray';
32 sub FETCH {
33 my $self = shift;
34 my $e = $self->SUPER::FETCH(@_);
35 return ref($e) ? $e : uc($e);
36 }
37 sub SHIFT {
38 my $self = shift;
39 my $e = $self->SUPER::SHIFT(@_);
40 return ref($e) ? $e : uc($e);
41 }
42 }
43
44 $evh->request_handler(sub {
45 my $r = shift;
46 isa_ok $r, 'Feersum::Connection', 'got an object!';
47 my $env = $r->env();
48 ok $env, "got env";
49
50 my $type = $env->{HTTP_X_MAGIC_TYPE};
51 if ($type eq 'SCALAR') {
52 # magic scalar
53 tie my $ms, 'My::MagicScalar';
54 $ms = "foobar";
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
55 is exception {
b80ead56 »
2010-09-29 Treat tied vars in the response properly
56 $r->send_response("200 OK", [
57 'Content-Type' => 'text/plain',
58 ], \$ms);
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
59 }, undef, "sent response for $type";
b80ead56 »
2010-09-29 Treat tied vars in the response properly
60 }
61 elsif ($type eq 'ARRAY') {
62 # magic array
63 tie my @ma, 'My::MagicArray';
64 @ma = ("aaaa","bbb");
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
65 is exception {
b80ead56 »
2010-09-29 Treat tied vars in the response properly
66 $r->send_response("200 OK", [
67 'Content-Type' => 'text/plain',
68 ], \@ma);
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
69 }, undef, "sent response for $type";
b80ead56 »
2010-09-29 Treat tied vars in the response properly
70 }
71 else {
72 tie my $ms, 'My::MagicScalar';
73 $ms = "dddd";
74 tie my @ma, 'My::MagicArray';
75 @ma = ("cccc",\$ms);
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
76 is exception {
b80ead56 »
2010-09-29 Treat tied vars in the response properly
77 $r->send_response("200 OK", [
78 'Content-Type' => 'text/plain',
79 ], \@ma);
8fc2f19d »
2011-01-31 Convert to use Test::Fatal from Test::Exception
80 }, undef, "sent response for $type";
b80ead56 »
2010-09-29 Treat tied vars in the response properly
81 }
82 });
83
84 my $cv = AE::cv;
85 $cv->begin;
86
87 my $w = simple_client GET => '/',
88 name => 'scalar',
89 headers => { 'X-Magic-Type' => 'SCALAR' },
90 timeout => 3,
91 sub {
92 my ($body, $hdr) = @_;
93 is $hdr->{Status}, 200, "client 1 got 200";
94 is $hdr->{'content-length'}, 6, 'content-length was overwritten by the engine';
95 is $body, 'FOOBAR', "magic body used for scalar";
96 $cv->end;
97 };
98
99 $cv->begin;
100 my $w2 = simple_client GET => '/',
101 name => 'array',
102 headers => { 'X-Magic-Type' => 'ARRAY' },
103 timeout => 3,
104 sub {
105 my ($body, $hdr) = @_;
106 is $hdr->{Status}, 200, "client 1 got 200";
107 is $hdr->{'content-length'}, 7, 'content-length';
108 is $body, 'AAAABBB', "magic body used for array";
109 $cv->end;
110 };
111
112 $cv->begin;
113 my $w3 = simple_client GET => '/',
114 name => 'array',
115 headers => { 'X-Magic-Type' => 'SCALAR-in-ARRAY' },
116 timeout => 3,
117 sub {
118 my ($body, $hdr) = @_;
119 is $hdr->{Status}, 200, "client 1 got 200";
120 is $hdr->{'content-length'}, 8, 'content-length';
121 is $body, 'CCCCDDDD', "magic body used for scalar in array";
122 $cv->end;
123 };
124
125 $cv->recv;
126 pass "all done";
Something went wrong with that request. Please try again.