view release on metacpan or  search on metacpan

lib/Clustericious/Client.pm  view on Meta::CPAN

        } elsif (ref $arg eq 'CODE') {
            $cb = $self->_mycallback($arg);
        } elsif (my $code = $url_modifier{$arg}) {
            $url = $code->($url, shift @args);
        } elsif (my $code2 = $payload_modifer{$arg}) {
            $body = $code2->($body, shift @args);
        } elsif ($method eq "GET" && $arg =~ s/^--//) {
            my $value = shift @args;
            $parameters->append($arg => $value);
        } elsif ($method eq "GET" && $arg =~ s/^-//) {
            # example: $client->esdt(-range => [1 => 100]);
            my $value = shift @args;
            if (ref $value eq 'ARRAY') {
                $value = "items=$value->[0]-$value->[1]";
            }
            $headers->{$arg} = $value;
        } elsif ($method eq "POST" && !ref $arg) {
            $body = $arg;
            $headers = shift @args if $args[0] && ref $args[0] eq 'HASH';
        } else {
            push @{ $url->path->parts }, $arg;
        }
    }
    $url = $url->to_abs unless $url->is_abs || $self->{app};
    WARN "url $url is not absolute" unless $url =~ /^http/i;

    $url->userinfo($self->userinfo) if $self->userinfo;

    DEBUG ( (ref $self)." : $method " ._sanitize_url($url));
    $headers->{Connection} ||= 'Close';
    $headers->{Accept}     ||= 'application/json';

    if($body && ref $body eq 'HASH' || ref $body eq 'ARRAY')
    {
        $headers->{'Content-Type'} = 'application/json';
        $body = encode_json $body;
    }

    return $self->ua->build_tx($method, $url, $headers, $body, $cb) if $cb;

    my $tx = $self->ua->build_tx($method, $url, $headers, $body);

    $tx = $self->ua->start($tx);
    my $res = $tx->res;
    $self->res($res);
    $self->tx($tx);

    my $auth_header;
    if (($tx->res->code||0) == 401 && ($auth_header = $tx->res->headers->www_authenticate)
        && !$url->userinfo && ($self->_has_auth || $self->_can_auth)) {
        DEBUG "received code 401, trying again with credentials";
        my ($realm) = $auth_header =~ /realm=(.*)$/i;
        my $host = $url->host;
        $self->login( $self->_has_auth ? () : $self->_get_user_pw($host,$realm) );
        return $self->_doit($meta ? $meta : (), @_);
    }

    if ($res->is_success) {
        TRACE "Got response : ".$res->to_string;
        my $content_type = $res->headers->content_type || do {
            WARN "No content-type from "._sanitize_url($url);
            "text/plain";
        };
        return $method =~ /HEAD|DELETE/       ? 1
            : $content_type =~ qr[application/json] ? decode_json($res->body)
            : $res->body;
    }

    # Failed.
    my $err = $tx->error;
    my ($msg, $code) = ($err->{message}, $err->{code});
    $msg ||= 'unknown error';
    my $s_url = _sanitize_url($url);

    if ($code) {
        if ($code == 404) {
            TRACE "$method $url : $code $msg"
                 unless $ENV{ACPS_SUPPRESS_404}
                     && $url =~ /$ENV{ACPS_SUPPRESS_404}/;
        } else {
            ERROR "Error trying to $method $s_url : $code $msg";
            TRACE "Full error body : ".$res->body if $res->body;
            my $brief = $res->body || '';
            $brief =~ s/\n/ /g;
            ERROR substr($brief,0,200) if $brief;
        }
        # No failover for legitimate status codes.
        return undef;
    }

    unless ($auto_failover) {
        ERROR "Error trying to $method $s_url : $msg";
        ERROR $res->body if $res->body;
        return undef;
    }
    my $failover_urls = $self->config->failover_urls(default => []);
    unless (@$failover_urls) {
        ERROR $msg;
        return undef;
    }
    INFO "$msg but will try up to ".@$failover_urls." failover urls";
    TRACE "Failover urls : @$failover_urls";
    for my $url (@$failover_urls) {
        DEBUG "Trying $url";
        $self->server_url($url);
        my $got = $self->_doit(@_);
        return $got if $got;
    }

    return undef;
}

sub _mycallback
{
    my $self = shift;
    my $cb = shift;
    sub
    {
        my ($ua, $tx) = @_;

        $self->res($tx->res);