Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
cases	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
000_load.t	217 B	-r--r--r--	2014-12-27 11:48
001_api.t	705 B	-r--r--r--	2014-12-27 11:48
002_croakage.t	925 B	-r--r--r--	2014-12-27 11:49
003_agent.t	1.24 KB	-r--r--r--	2014-12-27 11:48
010_url.t	1.66 KB	-r--r--r--	2014-12-27 11:48
020_headers.t	1.47 KB	-r--r--r--	2014-12-27 11:49
030_response.t	1021 B	-r--r--r--	2014-12-27 11:48
040_content.t	939 B	-r--r--r--	2014-12-27 11:48
050_chunked_body.t	1.4 KB	-r--r--r--	2014-12-27 11:48
060_http_date.t	759 B	-r--r--r--	2014-12-27 11:48
070_cookie_jar.t	1.06 KB	-r--r--r--	2014-12-27 11:48
100_get.t	3 KB	-r--r--r--	2014-12-27 11:49
101_head.t	1.9 KB	-r--r--r--	2014-12-27 11:49
102_put.t	1.9 KB	-r--r--r--	2014-12-27 11:49
103_delete.t	1.9 KB	-r--r--r--	2014-12-27 11:49
104_post.t	1.9 KB	-r--r--r--	2014-12-27 11:49
110_mirror.t	2.44 KB	-r--r--r--	2014-12-27 11:49
130_redirect.t	2.07 KB	-r--r--r--	2014-12-27 11:49
140_proxy.t	706 B	-r--r--r--	2014-12-27 11:49
141_no_proxy.t	1.71 KB	-r--r--r--	2014-12-27 11:48
150_post_form.t	2.1 KB	-r--r--r--	2014-12-27 11:49
160_cookies.t	2.44 KB	-r--r--r--	2014-12-27 11:49
161_basic_auth.t	2.06 KB	-r--r--r--	2014-12-27 11:49
162_proxy_auth.t	2.07 KB	-r--r--r--	2014-12-27 11:49
170_keepalive.t	2.15 KB	-r--r--r--	2014-12-27 11:49
BrokenCookieJar.pm	263 B	-r--r--r--	2014-12-27 11:48
SimpleCookieJar.pm	470 B	-r--r--r--	2014-12-27 11:48
Util.pm	3.96 KB	-r--r--r--	2014-12-27 11:49

Rename

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/;
    }
}

# vim: et ts=4 sts=4 sw=4: