AnyEvent-HTTP

 view release on metacpan or  search on metacpan

HTTP.pm  view on Meta::CPAN

   };

   undef $request;

=cut

#############################################################################
# wait queue/slots

sub _slot_schedule;
sub _slot_schedule($) {
   my $host = shift;

   while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
      if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
         # somebody wants that slot
         ++$CO_SLOT{$host}[0];
         ++$ACTIVE;

         $cb->(AnyEvent::Util::guard {
            --$ACTIVE;

HTTP.pm  view on Meta::CPAN

         });
      } else {
         # nobody wants the slot, maybe we can forget about it
         delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
         last;
      }
   }
}

# wait for a free slot on host, call callback
sub _get_slot($$) {
   push @{ $CO_SLOT{$_[0]}[1] }, $_[1];

   _slot_schedule $_[0];
}

#############################################################################
# cookie handling

# expire cookies
sub cookie_jar_expire($;$) {
   my ($jar, $session_end) = @_;

   %$jar = () if $jar->{version} != 2;

   my $anow = AE::now;

   while (my ($chost, $paths) = each %$jar) {
      next unless ref $paths;

      while (my ($cpath, $cookies) = each %$paths) {

HTTP.pm  view on Meta::CPAN

         delete $paths->{$cpath}
            unless %$cookies;
      }

      delete $jar->{$chost}
         unless %$paths;
   }
}
 
# extract cookies from jar
sub cookie_jar_extract($$$$) {
   my ($jar, $scheme, $host, $path) = @_;

   %$jar = () if $jar->{version} != 2;

   $host = AnyEvent::Util::idn_to_ascii $host
      if $host =~ /[^\x00-\x7f]/;

   my @cookies;

   while (my ($chost, $paths) = each %$jar) {

HTTP.pm  view on Meta::CPAN

            push @cookies, "$cookie=$value";
         }
      }
   }

   \@cookies
}
 
# parse set_cookie header into jar
sub cookie_jar_set_cookie($$$$) {
   my ($jar, $set_cookie, $host, $date) = @_;

   %$jar = () if $jar->{version} != 2;

   my $anow = int AE::now;
   my $snow; # server-now

   for ($set_cookie) {
      # parse NAME=VALUE
      my @kv;

HTTP.pm  view on Meta::CPAN

      $jar->{lc $cdom}{$cpath}{$name} = \%kv;

      redo if /\G\s*,/gc;
   }
}

#############################################################################
# keepalive/persistent connection cache

# fetch a connection from the keepalive cache
sub ka_fetch($) {
   my $ka_key = shift;

   my $hdl = pop @{ $KA_CACHE{$ka_key} }; # currently we reuse the MOST RECENTLY USED connection
   delete $KA_CACHE{$ka_key}
      unless @{ $KA_CACHE{$ka_key} };

   $hdl
}

sub ka_store($$) {
   my ($ka_key, $hdl) = @_;

   my $kaa = $KA_CACHE{$ka_key} ||= [];

   my $destroy = sub {
      my @ka = grep $_ != $hdl, @{ $KA_CACHE{$ka_key} };

      $hdl->destroy;

      @ka

HTTP.pm  view on Meta::CPAN

   $hdl->timeout  ($PERSISTENT_TIMEOUT);

   push @$kaa, $hdl;
   shift @$kaa while @$kaa > $MAX_PER_HOST;
}

#############################################################################
# utilities

# continue to parse $_ for headers and place them into the arg
sub _parse_hdr() {
   my %hdr;

   # things seen, not parsed:
   # p3pP="NON CUR OTPi OUR NOR UNI"

   $hdr{lc $1} .= ",$2"
      while /\G
            ([^:\000-\037]*):
            [\011\040]*
            ((?: [^\012]+ | \012[\011\040] )*)

HTTP.pm  view on Meta::CPAN

#############################################################################
# http_get

our $qr_nlnl = qr{(?<![^\012])\015?\012};

our $TLS_CTX_LOW  = { cache => 1, sslv2 => 1 };
our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };

# maybe it should just become a normal object :/

sub _destroy_state(\%) {
   my ($state) = @_;

   $state->{handle}->destroy if $state->{handle};
   %$state = ();
}

sub _error(\%$$) {
   my ($state, $cb, $hdr) = @_;

   &_destroy_state ($state);

   $cb->(undef, $hdr);
   ()
}

our %IDEMPOTENT = (
   DELETE		=> 1,

HTTP.pm  view on Meta::CPAN

   SEARCH		=> 1,
   UNBIND		=> 1,
   UNCHECKOUT		=> 1,
   UNLINK		=> 1,
   UNLOCK		=> 1,
   UPDATE		=> 1,
   UPDATEREDIRECTREF	=> 1,
   "VERSION-CONTROL"	=> 1,
);

sub http_request($$@) {
   my $cb = pop;
   my ($method, $url, %arg) = @_;

   my %hdr;

   $arg{tls_ctx} = $TLS_CTX_LOW  if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
   $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";

   $method = uc $method;

HTTP.pm  view on Meta::CPAN

         my $tcp_connect = $arg{tcp_connect}
                           || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };

         $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
      }
   };

   defined wantarray && AnyEvent::Util::guard { _destroy_state %state }
}

sub http_get($@) {
   unshift @_, "GET";
   &http_request
}

sub http_head($@) {
   unshift @_, "HEAD";
   &http_request
}

sub http_post($$@) {
   my $url = shift;
   unshift @_, "POST", $url, "body";
   &http_request
}

=back

=head2 DNS CACHING

AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for

HTTP.pm  view on Meta::CPAN

running requests, but the number of currently open and non-idle TCP
connections. This number can be useful for load-leveling.

=back

=cut

our @month   = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);

sub format_date($) {
   my ($time) = @_;

   # RFC 822/1123 format
   my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;

   sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
      $weekday[$wday], $mday, $month[$mon], $year + 1900,
      $H, $M, $S;
}

sub parse_date($) {
   my ($date) = @_;

   my ($d, $m, $y, $H, $M, $S);

   if ($date =~ /^[A-Z][a-z][a-z]+, ([0-9][0-9]?)[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) GMT$/) {
      # RFC 822/1123, required by RFC 2616 (with " ")
      # cookie dates (with "-")

      ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);

HTTP.pm  view on Meta::CPAN

   for (0..11) {
      if ($m eq $month[$_]) {
         require Time::Local;
         return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
      }
   }

   undef
}

sub set_proxy($) {
   if (length $_[0]) {
      $_[0] =~ m%^(http):// ([^:/]+) (?: : (\d*) )?%ix
         or Carp::croak "$_[0]: invalid proxy URL";
      $PROXY = [$2, $3 || 3128, $1]
   } else {
      undef $PROXY;
   }
}

# initialise proxy from environment