view release on metacpan or  search on metacpan

lib/HTTP/LoadGen.pm  view on Meta::CPAN

}

sub delay {
  my ($prefix, $param)=@_;
  return if delete $param->{'skip'.$prefix.'delay'};
  return unless exists $param->{$prefix.'delay'};
  my $sec=$param->{$prefix.'delay'};
  if( exists $param->{$prefix.'jitter'} ) {
    my $jitter=$param->{$prefix.'jitter'};
    $sec+=-$jitter+rnd(2*$jitter);
  }
  #D warn "\u${prefix}Delay: $sec sec\n";
  Coro::Timer::sleep $sec if $sec>0;
}

my (%services, %known_iterators);

sub register_iterator {
  my $code=pop;
  if( Scalar::Util::reftype $code eq 'CODE' ) {
    @known_iterators{@_}=($code)x(+@_);
  } else {
    die "CODE reference expected";
  }
}

sub get_iterator {
  my ($name)=@_;
  exists $known_iterators{$name} and return $known_iterators{$name};
  return $known_iterators{''};
}

{
  my %keep=('user-agent'=>1, 'referer'=>1);
  sub follow_3XX {
    my ($rc, $el)=@_;

    # we are stricter here than most browsers because we do not follow
    # partial URLs.
    if( $rc->[RC_STATUS]=~/^3/ and
	exists $rc->[RC_HEADERS]->{location} and
	$rc->[RC_HEADERS]->{location}->[0]=~m!^(https?):// # scheme
					      ([^:/]+)	   # host
					      (:[0-9]+)?   # optional port
					      (.*)!ix ) {  # uri
      # follow location
      my $scheme=lc($1);
      my $host=$2;
      my $port=$3||$services{$scheme};
      my $uri=$4||'/';

      my @h;
      if( exists $el->[RQ_PARAM]->{headers} ) {
	my $hdr=$el->[RQ_PARAM]->{headers};
	for (my $i=0; $i<@$hdr; $i+=2) {
	  push @h, $hdr->[$i], $hdr->[$i+1] if exists $keep{lc $hdr->[$i]};
	}
      }

      return ['GET', $scheme, $host, $port, $uri,
	      {keepalive=>KEEPALIVE, followed=>1, headers=>\@h}];
    }
  }
}

BEGIN {
  %services=(http=>80, https=>443);

  register_iterator '', default=>sub {
    my $urls=options->{URLList};
    my $nurls=@$urls;
    my $i=0;
    return sub {
      return if $i>=$nurls;
      return $urls->[$i++];
    };
  };

  register_iterator random_start=>sub {
    my $urls=options->{URLList};
    my $nurls=@$urls;
    my ($i, $off)=(0, int rnd $nurls);
    return sub {
      return if $i>=$nurls;
      return $urls->[($off+$i++) % $nurls];
    };
  };

  register_iterator follow=>sub {
    my %save_delay;
    my $it=@_ ? $_[0] : get_iterator('')->();
    return sub {
      my ($rc, $el)=@_;

      my $next=follow_3XX $rc, $el;
      return $next if $next;

      delay 'post', \%save_delay;

      # get next request
      $next=$it->($rc, $el);
      return unless $next;;

      # save postdelay
      if( exists $next->[RQ_PARAM]->{postdelay} ) {
	$save_delay{postdelay}=$next->[RQ_PARAM]->{postdelay};
	$save_delay{postjitter}=$next->[RQ_PARAM]->{postjitter}
	  if exists $next->[RQ_PARAM]->{postjitter};
	$next->[RQ_PARAM]->{skippostdelay}=1;
      }

      return $next;
    };
  };

  register_iterator random_start_follow=>sub {
    @_=get_iterator('random_start')->();
    goto &{get_iterator 'follow'};
  };
}