|
Packit |
3f4df8 |
package Util;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
use strict;
|
|
Packit |
3f4df8 |
use warnings;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
use IO::File qw(SEEK_SET SEEK_END);
|
|
Packit |
3f4df8 |
use IO::Dir;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
BEGIN {
|
|
Packit |
3f4df8 |
our @EXPORT_OK = qw(
|
|
Packit |
3f4df8 |
rewind
|
|
Packit |
3f4df8 |
tmpfile
|
|
Packit |
3f4df8 |
dir_list
|
|
Packit |
3f4df8 |
slurp
|
|
Packit |
3f4df8 |
parse_case
|
|
Packit |
3f4df8 |
hashify
|
|
Packit |
3f4df8 |
sort_headers
|
|
Packit |
3f4df8 |
connect_args
|
|
Packit |
3f4df8 |
clear_socket_source
|
|
Packit |
3f4df8 |
set_socket_source
|
|
Packit |
3f4df8 |
monkey_patch
|
|
Packit |
3f4df8 |
$CRLF
|
|
Packit |
3f4df8 |
$LF
|
|
Packit |
3f4df8 |
);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
require Exporter;
|
|
Packit |
3f4df8 |
*import = \&Exporter::import;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
our $CRLF = "\x0D\x0A";
|
|
Packit |
3f4df8 |
our $LF = "\x0A";
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub rewind(*) {
|
|
Packit |
3f4df8 |
seek($_[0], 0, SEEK_SET)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't rewind file handle: '$!'/);
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub tmpfile {
|
|
Packit |
3f4df8 |
my $fh = IO::File->new_tmpfile
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't create a new temporary file: '$!'/);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
binmode($fh)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't binmode temporary file handle: '$!'/);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
if (@_) {
|
|
Packit |
3f4df8 |
print({$fh} @_)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't write to temporary file handle: '$!'/);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
seek($fh, 0, SEEK_SET)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't rewind temporary file handle: '$!'/);
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
return $fh;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub dir_list {
|
|
Packit |
3f4df8 |
my ($dir, $filter) = @_;
|
|
Packit |
3f4df8 |
$filter ||= qr/./;
|
|
Packit |
3f4df8 |
my $d = IO::Dir->new($dir)
|
|
Packit |
3f4df8 |
or return;
|
|
Packit |
3f4df8 |
return map { "$dir/$_" } sort grep { /$filter/ } grep { /^[^.]/ } $d->read;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub slurp (*) {
|
|
Packit |
3f4df8 |
my ($fh) = @_;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
seek($fh, 0, SEEK_END)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't navigate to EOF on file handle: '$!'/);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
my $exp = tell($fh);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
rewind($fh);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
binmode($fh)
|
|
Packit |
3f4df8 |
|| die(qq/Couldn't binmode file handle: '$!'/);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
my $buf = do { local $/; <$fh> };
|
|
Packit |
3f4df8 |
my $got = length $buf;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
($exp == $got)
|
|
Packit |
3f4df8 |
|| die(qq[I/O read mismatch (expexted: $exp got: $got)]);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
return $buf;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub parse_case {
|
|
Packit |
3f4df8 |
my ($case) = @_;
|
|
Packit |
3f4df8 |
my %args;
|
|
Packit |
3f4df8 |
my $key = '';
|
|
Packit |
3f4df8 |
for my $line ( split "\n", $case ) {
|
|
Packit |
3f4df8 |
chomp $line;
|
|
Packit |
3f4df8 |
if ( substr($line,0,1) eq q{ } ) {
|
|
Packit |
3f4df8 |
$line =~ s/^\s+//;
|
|
Packit |
3f4df8 |
push @{$args{$key}}, $line;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
else {
|
|
Packit |
3f4df8 |
$key = $line;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
return \%args;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub hashify {
|
|
Packit |
3f4df8 |
my ($lines) = @_;
|
|
Packit |
3f4df8 |
return unless $lines;
|
|
Packit |
3f4df8 |
my %hash;
|
|
Packit |
3f4df8 |
for my $line ( @$lines ) {
|
|
Packit |
3f4df8 |
my ($k,$v) = ($line =~ m{^([^:]+): (.*)$}g);
|
|
Packit |
3f4df8 |
$hash{$k} = [ $hash{$k} ] if exists $hash{$k} && ref $hash{$k} ne 'ARRAY';
|
|
Packit |
3f4df8 |
if ( ref($hash{$k}) eq 'ARRAY' ) {
|
|
Packit |
3f4df8 |
push @{$hash{$k}}, $v;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
else {
|
|
Packit |
3f4df8 |
$hash{$k} = $v;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
return %hash;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub sort_headers {
|
|
Packit |
3f4df8 |
my ($text) = shift;
|
|
Packit |
3f4df8 |
my @lines = split /$CRLF/, $text;
|
|
Packit |
3f4df8 |
my $request = shift(@lines) || '';
|
|
Packit |
3f4df8 |
my @headers;
|
|
Packit |
3f4df8 |
while (my $line = shift @lines) {
|
|
Packit |
3f4df8 |
last unless length $line;
|
|
Packit |
3f4df8 |
push @headers, $line;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
@headers = sort @headers;
|
|
Packit |
3f4df8 |
return join($CRLF, $request, @headers, '', @lines);
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
{
|
|
Packit |
3f4df8 |
my (@req_fh, @res_fh, $monkey_host, $monkey_port);
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub clear_socket_source {
|
|
Packit |
3f4df8 |
@req_fh = ();
|
|
Packit |
3f4df8 |
@res_fh = ();
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub set_socket_source {
|
|
Packit |
3f4df8 |
my ($req_fh, $res_fh) = @_;
|
|
Packit |
3f4df8 |
push @req_fh, $req_fh;
|
|
Packit |
3f4df8 |
push @res_fh, $res_fh;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub connect_args { return ($monkey_host, $monkey_port) }
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
sub monkey_patch {
|
|
Packit |
3f4df8 |
no warnings qw/redefine once/;
|
|
Packit |
3f4df8 |
*HTTP::Tiny::Handle::can_read = sub {1};
|
|
Packit |
3f4df8 |
*HTTP::Tiny::Handle::can_write = sub {1};
|
|
Packit |
3f4df8 |
*HTTP::Tiny::Handle::connect = sub {
|
|
Packit |
3f4df8 |
my ($self, $scheme, $host, $port, $peer) = @_;
|
|
Packit |
3f4df8 |
$self->{host} = $monkey_host = $host;
|
|
Packit |
3f4df8 |
$self->{port} = $monkey_port = $port;
|
|
Packit |
3f4df8 |
$self->{peer} = $peer;
|
|
Packit |
3f4df8 |
$self->{scheme} = $scheme;
|
|
Packit |
3f4df8 |
$self->{fh} = shift @req_fh;
|
|
Packit |
3f4df8 |
$self->{pid} = $$;
|
|
Packit |
3f4df8 |
$self->{tid} = HTTP::Tiny::Handle::_get_tid();
|
|
Packit |
3f4df8 |
return $self;
|
|
Packit |
3f4df8 |
};
|
|
Packit |
3f4df8 |
my $original_write_request = \&HTTP::Tiny::Handle::write_request;
|
|
Packit |
3f4df8 |
*HTTP::Tiny::Handle::write_request = sub {
|
|
Packit |
3f4df8 |
my ($self, $request) = @_;
|
|
Packit |
3f4df8 |
$original_write_request->($self, $request);
|
|
Packit |
3f4df8 |
$self->{fh} = shift @res_fh;
|
|
Packit |
3f4df8 |
};
|
|
Packit |
3f4df8 |
*HTTP::Tiny::Handle::close = sub { 1 }; # don't close our temps
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
# don't try to proxy in mock-mode
|
|
Packit |
3f4df8 |
delete $ENV{$_} for map { $_, uc($_) } qw/http_proxy https_proxy all_proxy/;
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
}
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
1;
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
|
|
Packit |
3f4df8 |
# vim: et ts=4 sts=4 sw=4:
|