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