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