view release on metacpan or  search on metacpan

lib/Claude/Agent/MCP/SDKRunner.pm  view on Meta::CPAN

        jsonrpc => '2.0',
        id      => $id,
        error   => {
            code    => -32601,
            message => "Method not found: $safe_method",
        },
    };
}

sub _generate_uuid {
    # Generate a UUID v4-like string to avoid request ID collisions
    # Uses cryptographically secure random bytes for robust uniqueness
    require Crypt::URandom;
    my $random_bytes = Crypt::URandom::urandom(16);
    my $uuid = unpack('H*', $random_bytes);
    $uuid =~ s/(.{8})(.{4})(.{4})(.{4})(.{12})/$1-$2-$3-$4-$5/;
    return $uuid;
}

sub call_parent_handler {
    my ($tool_name, $args) = @_;

    # Use UUID-based request IDs to eliminate any possibility of ID collision
    # even if async/threaded handling is added in the future
    my $request_id = _generate_uuid();

    # Send request to parent via async stream
    my $request = $state->{jsonl}->encode([{
        id   => $request_id,
        tool => $tool_name,
        args => $args,
    }]);

    $log->debug(sprintf("SDKRunner: Sending request to parent id=%s", $request_id));
    $log->trace(sprintf("SDKRunner: Request payload: %s", $request));

    $state->{socket_stream}->write($request);

    # Reset response flag before waiting
    $state->{got_response} = 0;

    # Wait for response with configurable timeout using actual elapsed time
    require Time::HiRes;
    my $timeout = $ENV{CLAUDE_AGENT_TOOL_TIMEOUT} // 60;
    my $max_timeout = 300;
    # Ensure numeric value between 1-300 seconds (1 sec to 5 minutes)
    # Non-numeric, empty, zero, or out-of-range values fall back to 60s default
    # Security note: Lower maximum (300s) prevents resource exhaustion attacks.
    # For operations requiring longer timeouts, consider breaking them into smaller steps.
    if (!defined $timeout || $timeout !~ /^\d+$/ || $timeout < 1) {
        $timeout = 60;
    } elsif ($timeout > $max_timeout) {
        $log->warning(sprintf("CLAUDE_AGENT_TOOL_TIMEOUT=%d exceeds maximum (%d seconds), capping to %d seconds",
            $timeout, $max_timeout, $max_timeout));
        $timeout = $max_timeout;
    }
    my $start_time = Time::HiRes::time();
    my $backoff = 0.1;
    my $last_buffer_size = length($state->{response_buffer});
    my $stall_count = 0;
    my $max_stall_iterations = 100;  # ~10 seconds at max backoff before declaring stall

    while (!$state->{got_response}) {
        # Check elapsed time before loop_once to ensure accurate timeout enforcement
        my $elapsed = Time::HiRes::time() - $start_time;
        last if $elapsed >= $timeout;

        $state->{loop}->loop_once($backoff);
        $backoff = $backoff * 1.5 if $backoff < 1.0;  # Exponential backoff up to 1 second

        # Detect buffer growth without complete JSON lines (malformed/incomplete data)
        # Use tiered limits to detect issues early before memory spikes
        my $current_buffer_size = length($state->{response_buffer});
        my $warn_buffer_size = 5_000_000;   # 5MB warning threshold
        my $max_buffer_size = 10_000_000;   # 10MB hard limit
        if ($current_buffer_size > $max_buffer_size) {
            $log->debug(sprintf("SDKRunner: Buffer overflow (size: %d bytes), aborting", $current_buffer_size));
            # Clear buffer to reclaim memory before returning error
            $state->{response_buffer} = '';
            last;
        }
        elsif ($current_buffer_size > $warn_buffer_size) {
            # Log warning at 5MB to alert before hitting hard limit
            $log->debug(sprintf("SDKRunner: Buffer approaching limit (size: %d bytes, limit: %d)",
                $current_buffer_size, $max_buffer_size));
        }
        if ($current_buffer_size > 0 && $current_buffer_size == $last_buffer_size) {
            $stall_count++;
            if ($stall_count >= $max_stall_iterations) {
                $log->debug(sprintf("SDKRunner: Buffer stalled with incomplete data (size: %d)",
                    $current_buffer_size));
                last;
            }
        } elsif ($current_buffer_size != $last_buffer_size) {
            # Buffer changed - reset stall counter but don't reset backoff
            $stall_count = 0;
            $last_buffer_size = $current_buffer_size;
        }

        # Re-check elapsed time after loop_once in case it took longer than expected
        last if (Time::HiRes::time() - $start_time) >= $timeout;
    }

    # Extract the response line from buffer, matching by request ID
    my $response_line;
    # First check if we have a pending response for this request ID (from previous calls)
    # NOTE: pending_responses is initialized in reset_state() which is called at start of run().
    # Always verify initialization to catch bugs early - uninitialized state indicates
    # reset_state() was not called properly, which is a programming error.
    if (!defined $state->{pending_responses}) {
        require Carp;
        Carp::croak("BUG: pending_responses not initialized - reset_state() was not called properly. "
            . "This is a programming error that must be fixed.");
    }
    if (exists $state->{pending_responses}{$request_id}) {
        my $pending = delete $state->{pending_responses}{$request_id};
        $response_line = $pending->{line};
    }
    else {
        # Parse all complete lines and find matching response by ID
        # Store unmatched responses in a hash keyed by request ID for efficient lookup
        while ($state->{response_buffer} =~ s/^(.+)\n//) {
            my $line = $1;
            my ($resp, $parse_err);
            try {
                ($resp) = $state->{jsonl}->decode($line);
            } catch {
                $parse_err = $_;
            };
            if ($parse_err || !$resp) {
                # Log unparseable lines at debug level to aid troubleshooting
                $log->debug(sprintf("SDKRunner: Failed to parse buffered line (discarding): %s", $line));
                next;
            }
            if ($resp->{id} && $resp->{id} eq $request_id) {
                $response_line = $line;
                last;
            }
            # Store unmatched responses in hash keyed by ID for later retrieval
            # This avoids buffer corruption from re-joining partial data
            if ($resp->{id}) {
                $state->{pending_responses}{$resp->{id}} = { line => $line, resp => $resp };
            }
        }
    }
    # Reset flag if no more complete lines
    $state->{got_response} = 0 unless $state->{response_buffer} =~ /\n/;

    unless ($response_line) {