gdb/testsuite/lib/gdbreplay-support.exp

# Copyright 2024-2026 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# We're going to reuse some helper function from the gdbserver library.
load_lib gdbserver-support.exp

if {![info exists GDBREPLAY]} {
    set GDBREPLAY [findfile $base_dir/../../gdbserver/gdbreplay]
}

global GDBREPLAY
verbose "using GDBREPLAY = $GDBREPLAY" 2

# Check is non empty and we're running on the host.
proc has_gdbreplay {} {
    global GDBREPLAY
    if {$GDBREPLAY == ""} {
	return false
    }

    # We currently rely on running gdbreplay on the same machine as
    # GDB.
    if {[is_remote target]} {
	return false
    }

    return true
}

# Write the command line used to invocate gdbserver to the cmd file.

proc gdbreplay_write_cmd_file { cmdline } {
    set logfile [standard_output_file_with_gdb_instance gdbreplay.cmd]
    set cmd_file [open $logfile w]
    puts $cmd_file $cmdline
    catch {close $cmd_file}
}

# Start gdbreplay using REMOTELOG as the log file.  Return a list of
# two elements, the protocol and the hostname:port string.  This
# result list has the same format as gdbserver_start.

proc gdbreplay_start { remotelog } {
    # Port id -- either specified in baseboard file, or managed here.
    set portnum [get_portnum]

    # Extract the protocol
    if {[target_info exists gdb_protocol]} {
	set protocol [target_info gdb_protocol]
    } else {
	set protocol "remote"
    }

    # Loop till we find a free port.
    while 1 {
	# Fire off the debug agent.
	set gdbreplay_command "$::GDBREPLAY $remotelog localhost:$portnum"

	gdbreplay_write_cmd_file $gdbreplay_command

	global gdbreplay_spawn_id
	set gdbreplay_spawn_id [remote_spawn target $gdbreplay_command]

	# Wait for the server to open its TCP socket, so that GDB can connect.
	expect {
	    -i $gdbreplay_spawn_id
	    -timeout 120
	    -notransfer
	    -re "Replay logfile using" { }
	    -re "Can't (bind address|listen on socket): Address already in use\\.\r\n" {
		verbose -log "Port $portnum is already in use."
		set other_portnum [get_portnum]
		if { $other_portnum != $portnum } {
		    # Bump the port number to avoid the conflict.
		    wait -i $expect_out(spawn_id)
		    set portnum $other_portnum
		    continue
		}
	    }
	    -re ".*: cannot resolve name: .*\r\n" {
		error "gdbserver cannot resolve name."
	    }
	    -re "Can't open socket: Address family not supported by protocol." {
		return {}
	    }
	    timeout {
		error "Timeout waiting for gdbreplay response."
	    }
	}
	break
    }

    return [list $protocol "localhost:$portnum"]
}

# MATCH_REGEXP matches lines from GDB to gdbserver.  Once a match is
# found then NEWLINE is used to build a replacement line to send from
# gdbserver to GDB.
#
# Examples of MATCH_REGEXP:  "vMustReplyEmpty"
#
# Example usage:
#
# update_log $logname "${logname}.updated" "vMustReplyEmpty" "E.failed"

proc update_log { filename_in filename_out match_regexp newline truncate } {
    set fh_in [open $filename_in r]
    set fh_out [open $filename_out w]

    while { [gets $fh_in line] >= 0 } {
	# Print the line to the file.
	puts $fh_out $line

	# If this line matches, then inject NEWLINE.
	if { $match_regexp ne "" && [regexp $match_regexp $line] } {
	    # Print out NEWLINE.
	    puts $fh_out "r +\$${newline}"

	    # Discard the line this just replaced.
	    gets $fh_in line

	    if { $truncate } {
		# Don't truncate the file, otherwise gdbreplay will
		# close the connection early and this might impact
		# what GDB does.  We want GDB to get a chance to
		# process the error.
		puts $fh_out "c q"
		puts $fh_out "w \$qTStatus#49"
		puts $fh_out "End of log"

		break
	    }

	    # Clear MATCH_REGEXP so no further lines will match.
	    set match_regexp ""
	}
    }

    close $fh_out
    close $fh_in
}

# Return the line immediately after the first line in FILENAME that
# matches MATCH_REGEXP.  If MATCH_REGEXP matches a packet sent from
# GDB to gdbserver, then the line returned should be the reply packet.
#
# If anything goes wrong, e.g. MATCH_REGEXP doesn't match anything,
# then an empty string is returned.

proc get_reply_line { filename match_regexp } {
    set fh_in [open $filename r]
    set reply ""

    while { [gets $fh_in line] >= 0 } {
	if { [regexp $match_regexp $line] } {
	    gets $fh_in reply
	    break
	}
    }

    close $fh_in

    return $reply
}