1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
package t::Util;
use strict;
use warnings;
use IO::File qw(SEEK_SET SEEK_END);
use IO::Dir;
BEGIN {
our @EXPORT_OK = qw(
rewind
tmpfile
dir_list
slurp
parse_case
hashify
sort_headers
connect_args
clear_socket_source
set_socket_source
monkey_patch
$CRLF
$LF
);
require Exporter;
*import = \&Exporter::import;
}
our $CRLF = "\x0D\x0A";
our $LF = "\x0A";
sub rewind(*) {
seek($_[0], 0, SEEK_SET)
|| die(qq/Couldn't rewind file handle: '$!'/);
}
sub tmpfile {
my $fh = IO::File->new_tmpfile
|| die(qq/Couldn't create a new temporary file: '$!'/);
binmode($fh)
|| die(qq/Couldn't binmode temporary file handle: '$!'/);
if (@_) {
print({$fh} @_)
|| die(qq/Couldn't write to temporary file handle: '$!'/);
seek($fh, 0, SEEK_SET)
|| die(qq/Couldn't rewind temporary file handle: '$!'/);
}
return $fh;
}
sub dir_list {
my ($dir, $filter) = @_;
$filter ||= qr/./;
my $d = IO::Dir->new($dir)
or return;
return map { "$dir/$_" } sort grep { /$filter/ } grep { /^[^.]/ } $d->read;
}
sub slurp (*) {
my ($fh) = @_;
seek($fh, 0, SEEK_END)
|| die(qq/Couldn't navigate to EOF on file handle: '$!'/);
my $exp = tell($fh);
rewind($fh);
binmode($fh)
|| die(qq/Couldn't binmode file handle: '$!'/);
my $buf = do { local $/; <$fh> };
my $got = length $buf;
($exp == $got)
|| die(qq[I/O read mismatch (expexted: $exp got: $got)]);
return $buf;
}
sub parse_case {
my ($case) = @_;
my %args;
my $key = '';
for my $line ( split "\n", $case ) {
chomp $line;
if ( substr($line,0,1) eq q{ } ) {
$line =~ s/^\s+//;
push @{$args{$key}}, $line;
}
else {
$key = $line;
}
}
return \%args;
}
sub hashify {
my ($lines) = @_;
return unless $lines;
my %hash;
for my $line ( @$lines ) {
my ($k,$v) = ($line =~ m{^([^:]+): (.*)$}g);
$hash{$k} = [ $hash{$k} ] if exists $hash{$k} && ref $hash{$k} ne 'ARRAY';
if ( ref($hash{$k}) eq 'ARRAY' ) {
push @{$hash{$k}}, $v;
}
else {
$hash{$k} = $v;
}
}
return %hash;
}
sub sort_headers {
my ($text) = shift;
my @lines = split /$CRLF/, $text;
my $request = shift(@lines) || '';
my @headers;
while (my $line = shift @lines) {
last unless length $line;
push @headers, $line;
}
@headers = sort @headers;
return join($CRLF, $request, @headers, '', @lines);
}
{
my (@req_fh, @res_fh, $monkey_host, $monkey_port);
sub clear_socket_source {
@req_fh = ();
@res_fh = ();
}
sub set_socket_source {
my ($req_fh, $res_fh) = @_;
push @req_fh, $req_fh;
push @res_fh, $res_fh;
}
sub connect_args { return ($monkey_host, $monkey_port) }
sub monkey_patch {
no warnings qw/redefine once/;
*HTTP::Tiny::Handle::can_read = sub {1};
*HTTP::Tiny::Handle::can_write = sub {1};
*HTTP::Tiny::Handle::connect = sub {
my ($self, $scheme, $host, $port) = @_;
$self->{host} = $monkey_host = $host;
$self->{port} = $monkey_port = $port;
$self->{scheme} = $scheme;
$self->{fh} = shift @req_fh;
return $self;
};
my $original_write_request = \&HTTP::Tiny::Handle::write_request;
*HTTP::Tiny::Handle::write_request = sub {
my ($self, $request) = @_;
$original_write_request->($self, $request);
$self->{fh} = shift @res_fh;
};
*HTTP::Tiny::Handle::close = sub { 1 }; # don't close our temps
# don't try to proxy in mock-mode
delete $ENV{http_proxy};
delete $ENV{$_} for map { $_, uc($_) } qw/https_proxy all_proxy/;
}
}
1;
# vim: et ts=4 sts=4 sw=4:
|
