view release on metacpan or  search on metacpan

lib/App/DubiousHTTP/TestServer.pm  view on Meta::CPAN

	    goto handle_data;

	} elsif ( length($rbuf)>4096 ) {
	    warn "request header too large";
	    delete_client($cl);
	    return;
	}
    };

    $write = sub {
	my $cl = shift;

	handle_data:
	if ( ! @wbuf ) {
	    # nothing to write
	    if ($rbuf eq '' && $close) {
		# done
		$DEBUG && _debug("close client because all done and close flag set");
		delete_client($cl);
	    } else {
		$SELECT->mask($cl,1,0);
	    }
	    return;
	} 
	my $n = syswrite($cl,$wbuf[0]);
	$DEBUG && _debug("write on ".fileno($cl)." -> ".(defined $n ? $n : $!));
	if ( ! $n ) {
	    if ( defined($n) || ! $!{EAGAIN} ) {
		# connection broke
		delete_client($cl);
	    } else {
		# try later
		$SELECT->mask($cl,1,1);
	    }
	    return;
	}

	$clients{fileno($cl)}{time} = time();
	substr($wbuf[0],0,$n,'');
	if ($wbuf[0] eq '') {
	    shift @wbuf;
	    if (@wbuf) {
		# delay sending of next packet
		$SELECT->mask($cl,1,0);  # disable write
		$SELECT->timer($cl,1, sub { $write->($cl); });
		return;
	    }
	}
	goto handle_data;
    };

    $SELECT->handler($cl,0,$read,1,$write);
    $SELECT->mask($cl,0,1);
}


sub _mustclose {
    my $hdr = shift;
    my $close;
    my $type = $hdr =~m{^[A-Z]+ /} ? 'request':'response';
    while ($hdr =~m{^Connection:[ \t]*(?:(close)|keep-alive)}mig) {
	$close = $1 ? 1: ($close||-1);
    }
    if ($close) {
	$close = 0 if $close<0;
	$DEBUG && _debug("set close=$close because of connection header in $type");
    } elsif ($hdr =~m{\A(?:.* )?HTTP/1\.(?:0|(1))}) {
	$close = $1 ? 0:1;
	$DEBUG && _debug("set close=$close because of HTTP version in $type");
    } else {
	$close = 1;
	$DEBUG && _debug("set close=$close because no other information are known in $type");
    }
    return $close;
}

package App::DubiousHTTP::TestServer::Select;
use Scalar::Util 'weaken';
use Time::HiRes 'gettimeofday';

my $maxfn = 0;
my @handler;
my @didit;
my @timeout;
my @timer;
my @mask = ('','');
my @tmpmask;
my $now = gettimeofday();
*_debug = \&App::DubiousHTTP::TestServer::_debug;

sub new { bless {},shift }
sub delete {
    my ($self,$cl) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    $DEBUG && _debug("remove fd $fn");
    vec($mask[0],$fn,1) = vec($mask[1],$fn,1) = 0;
    vec($tmpmask[0],$fn,1) = vec($tmpmask[1],$fn,1) = 0 if @tmpmask;
    $handler[$fn] = $didit[$fn] = $timeout[$fn] = $timer[$fn] = undef;
    if ($maxfn == $fn) {
	$maxfn-- while ($maxfn>=0 && !$handler[$maxfn]);
    }
}

sub handler {
    my ($self,$cl,%sub) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    $maxfn = $fn if $fn>$maxfn;
    weaken(my $wcl = $cl);
    while (my ($rw,$sub) = each %sub) {
	$sub = [ $sub ] if ref($sub) eq 'CODE';
	splice(@$sub,1,0,$wcl);
	$handler[$fn][$rw] = $sub;
	$DEBUG && _debug("add handler($fn,$rw)");
    }
}

sub timer {
    my ($self,$cl,$to,$cb) = @_;
    defined( my $fn = fileno($cl) ) or die "invalid fd";
    ($cb, my @arg) = ref($cb) eq 'CODE' ? ($cb):@$cb;
    push @{ $timer[$fn] }, [ $now+$to,$cb,@arg ];