This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f6c5f321de7f7345ceac015f35561375877c2b66
[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 q[SEEK_SET];
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     rewind($fh);
76
77     binmode($fh)
78       || die(qq/Couldn't binmode file handle: '$!'/);
79
80     my $exp = -s $fh;
81     my $buf = do { local $/; <$fh> };
82     my $got = length $buf;
83
84     ($exp == $got)
85       || die(qq[I/O read mismatch (expexted: $exp got: $got)]);
86
87     return $buf;
88 }
89
90 sub parse_case {
91     my ($case) = @_;
92     my %args;
93     my $key = '';
94     for my $line ( split "\n", $case ) {
95         chomp $line;
96         if ( substr($line,0,1) eq q{ } ) {
97             $line =~ s/^\s+//;
98             push @{$args{$key}}, $line;
99         }
100         else {
101             $key = $line;
102         }
103     }
104     return \%args;
105 }
106
107 sub hashify {
108     my ($lines) = @_;
109     return unless $lines;
110     my %hash;
111     for my $line ( @$lines ) {
112         my ($k,$v) = ($line =~ m{^([^:]+): (.*)$}g);
113         $hash{$k} = [ $hash{$k} ] if exists $hash{$k} && ref $hash{$k} ne 'ARRAY';
114         if ( ref($hash{$k}) eq 'ARRAY' ) {
115             push @{$hash{$k}}, $v;
116         }
117         else {
118             $hash{$k} = $v;
119         }
120     }
121     return %hash;
122 }
123
124 sub sort_headers {
125     my ($text) = shift;
126     my @lines = split /$CRLF/, $text;
127     my $request = shift(@lines) || '';
128     my @headers;
129     while (my $line = shift @lines) {
130         last unless length $line;
131         push @headers, $line;
132     }
133     @headers = sort @headers;
134     return join($CRLF, $request, @headers, '', @lines);
135 }
136
137 {
138     my (@req_fh, @res_fh, $monkey_host, $monkey_port);
139
140     sub clear_socket_source {
141         @req_fh = ();
142         @res_fh = ();
143     }
144
145     sub set_socket_source {
146         my ($req_fh, $res_fh) = @_;
147         push @req_fh, $req_fh;
148         push @res_fh, $res_fh;
149     }
150
151     sub connect_args { return ($monkey_host, $monkey_port) }
152
153     sub monkey_patch {
154         no warnings qw/redefine once/;
155         *HTTP::Tiny::Handle::can_read = sub {1};
156         *HTTP::Tiny::Handle::can_write = sub {1};
157         *HTTP::Tiny::Handle::connect = sub {
158             my ($self, $scheme, $host, $port) = @_;
159             $self->{host} = $monkey_host = $host;
160             $self->{port} = $monkey_port = $port;
161             $self->{fh} = shift @req_fh;
162             return $self;
163         };
164         my $original_write_request = \&HTTP::Tiny::Handle::write_request;
165         *HTTP::Tiny::Handle::write_request = sub {
166             my ($self, $request) = @_;
167             $original_write_request->($self, $request);
168             $self->{fh} = shift @res_fh;
169         };
170         *HTTP::Tiny::Handle::close = sub { 1 }; # don't close our temps
171     }
172 }
173
174 1;
175
176
177 # vim: et ts=4 sts=4 sw=4: