binutils-gdb/gdb/testsuite/lib/dap-support.exp

# Copyright 2022-2024 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/>.

# The JSON parser.
load_lib ton.tcl

# The sequence number for the currently-executing instance of gdb
# launched via dap_gdb_start.  This is used for log-file checking
# after the run is complete.  Zero means gdb hasn't started yet.
set dap_gdb_instance 0

# The sequence number for the next DAP request.  This is used by the
# automatic sequence-counting code below.  It is reset each time GDB
# is restarted.
set dap_seq 1

# Return the current DAP log file.
proc current_dap_log_file {} {
    global dap_gdb_instance
    return [standard_output_file "dap.log.$dap_gdb_instance"]
}

# Return a new DAP log file.
proc new_dap_log_file {} {
    global dap_gdb_instance
    incr dap_gdb_instance
    return [current_dap_log_file]
}

# Start gdb using the DAP interpreter.
proc dap_gdb_start {} {
    # Keep track of the number of times GDB has been launched.
    global gdb_instances
    incr gdb_instances

    gdb_stdin_log_init

    global GDBFLAGS stty_init
    save_vars { GDBFLAGS stty_init } {
	set stty_init "-echo raw"
	set logfile [new_dap_log_file]
	append GDBFLAGS " -iex \"set debug dap-log-file $logfile\" -q -i=dap"
	set res [gdb_spawn]
	if {$res != 0} {
	    return $res
	}
    }

    # Reset the counter.
    set ::dap_seq 1

    return 0
}

# A helper for dap_to_ton that decides if the list L is a JSON object
# or if it is an array.
proc _dap_is_obj {l} {
    if {[llength $l] % 2 != 0} {
	return 0
    }
    foreach {key value} $l {
	if {![string is alpha $key]} {
	    return 0
	}
    }
    return 1
}

# The "TON" format is a bit of a pain to write by hand, so this proc
# can be used to convert an ordinary Tcl list into TON by guessing at
# the correct forms to use.  This can't be used in all cases, because
# Tcl can't really differentiate between literal forms.  For example,
# there's no way to decide if "true" should be a string or the literal
# true.
#
# JSON objects must be passed in a particular form here -- as a list
# with an even number of elements, alternating keys and values.  Each
# key must consist only of letters, no digits or other non-letter
# characters.  Note that this is compatible with the Tcl 'dict'
# representation.
proc dap_to_ton {obj} {
    if {[string is list $obj] && [llength $obj] > 1} {
	if {[_dap_is_obj $obj]} {
	    set result o
	    foreach {key value} $obj {
		lappend result $key \[[dap_to_ton $value]\]
	    }
	} else {
	    set result a
	    foreach val $obj {
		lappend result \[[dap_to_ton $val]\]
	    }
	}
    } elseif {[string is entier $obj]} {
	set result [list i $obj]
    } elseif {[string is double $obj]} {
	set result [list d $obj]
    } elseif {$obj == "true" || $obj == "false" || $obj == "null"} {
	set result [list l $obj]
    } else {
	set result [list s $obj]
    }
    return $result
}

# Format the object OBJ, in TON format, as JSON and send it to gdb.
proc _dap_send_ton {obj} {
    set json [namespace eval ton::2json $obj]
    # FIXME this is wrong for non-ASCII characters.
    set len [string length $json]
    verbose -log ">>> $json"
    send_gdb "Content-Length: $len\r\n\r\n$json"
}

# Send a DAP request to gdb.  COMMAND is the request's "command"
# field, and OBJ is the "arguments" field.  If OBJ is empty, it is
# omitted.  The sequence number of the request is automatically added,
# and this is also the return value.  OBJ is assumed to already be in
# TON form.
proc dap_send_request {command {obj {}}} {
    # We can construct this directly as a TON object.
    set result $::dap_seq
    incr ::dap_seq
    set req [format {o seq [i %d] type [s request] command [%s]} \
		 $result [list s $command]]
    if {$obj != ""} {
	append req " arguments \[$obj\]"
    }
    _dap_send_ton $req
    return $result
}

# Read a JSON response from gdb.  This will return a dict on
# success, or throw an exception on error.  On success, the global
# "last_ton" will be set to the TON form of the result.
proc _dap_read_json {} {
    set length ""
    set seen_timeout 0
    set seen_eof 0
    gdb_expect {
	-re "^Content-Length: (\[0-9\]+)\r\n" {
	    set length $expect_out(1,string)
	    exp_continue
	}
	-re "^(\[^\r\n\]+)\r\n" {
	    # Any other header field.
	    exp_continue
	}
	-re "^\r\n" {
	    # Done.
	}
	timeout {
	    set seen_timeout 1
	}
	eof {
	    set seen_eof 1
	}
    }

    if {$seen_timeout} {
	error "timeout reading json header"	
    }
    if {$seen_eof} {
	error "eof reading json header"
    }

    if {$length == ""} {
	error "didn't find content-length"
    }

    set json ""
    while {$length > 0} {
	# Tcl only allows up to 255 characters in a {} expression in a
	# regexp, so we may need to read in chunks.
	set this_len [expr {min ($length, 255)}]
	set seen_timeout 0
	set seen_eof 0
	gdb_expect {
	    -re "^.{$this_len}" {
		append json $expect_out(0,string)
	    }
	    timeout {
		set seen_timeout 1
	    }
	    eof {
		set seen_eof 1
	    }
	}

	if {$seen_timeout} {
	    error "timeout reading json header"	
	}
	if {$seen_eof} {
	    error "eof reading json header"
	}

	incr length -$this_len
    }

    global last_ton
    set last_ton [ton::json2ton $json]
    return [namespace eval ton::2dict $last_ton]
}

# Read a sequence of JSON objects from gdb, until a response object is
# seen.  If the response object has the request sequence number NUM,
# and is for command CMD, return a list of two elements: the response
# object and a list of any preceding events, in the order they were
# emitted.  The objects are dicts.  If a response object is seen but
# has the wrong sequence number or command, throw an exception If a
# response is seen, this leaves the global "last_ton" set to the TON
# for the response.

proc dap_read_response {cmd num} {
    set result {}
    while 1 {
	set d [_dap_read_json]
	if {[dict get $d type] == "response"} {
	    if {[dict get $d request_seq] != $num} {
		error "saw wrong request_seq in $obj"
	    } elseif {[dict get $d command] != $cmd} {
		error "saw wrong command in $obj"
	    } else {
		return [list $d $result]
	    }
	} else {
	    lappend result $d
	}
    }
}

# A wrapper for dap_send_request and dap_read_response.  This sends a
# request to gdb and returns the response as a dict.
proc dap_request_and_response {command {obj {}}} {
    set seq [dap_send_request $command $obj]
    return [dap_read_response $command $seq]
}

# Like dap_request_and_response, but also checks that the response
# indicates success.  NAME is used to issue a test result.
proc dap_check_request_and_response {name command {obj {}}} {
    set response_and_events [dap_request_and_response $command $obj]
    set response [lindex $response_and_events 0]
    if {[dict get $response success] != "true"} {
	verbose "request failure: $response"
	fail "$name success"
	return ""
    }
    pass "$name success"
    return $response_and_events
}

# Start gdb, send a DAP initialization request and return the
# response.  This approach lets the caller check the feature list, if
# desired.  Returns the empty string on failure.  NAME is used as the
# test name.
proc dap_initialize {{name "initialize"}} {
    if {[dap_gdb_start]} {
	return ""
    }
    return [dap_check_request_and_response $name initialize \
		{o clientID [s "gdb testsuite"] \
		     supportsVariableType [l true] \
		     supportsVariablePaging [l true] \
		     supportsMemoryReferences [l true]}]
}

# Send a launch request specifying FILE as the program to use for the
# inferior.  Returns the empty string on failure, or the response
# object from the launch request.  If specified, ARGS is a dictionary
# of key-value pairs, each passed to the launch request.  Valid keys
# are:
#
# * arguments - value is a list of strings passed as command-line
#   arguments to the inferior
# * env - value is a list of pairs of the form {VAR VALUE} that is
#   used to populate the inferior's environment.
# * stop_at_main - value is ignored, the presence of this means that
#   "stopAtBeginningOfMainSubprogram" will be passed to the launch
#   request.
# * cwd - value is the working directory to use.
#
# After this proc is called, gdb will be ready to accept breakpoint
# requests.
proc dap_launch {file {args {}}} {
    set params "o program"
    append params " [format {[%s]} [list s [standard_output_file $file]]]"

    foreach {key value} $args {
	switch -exact -- $key {
	    arguments {
		append params " args"
		set arglist ""
		foreach arg $value {
		    append arglist " \[s [list $arg]\]"
		}
		append params " \[a $arglist\]"
	    }

	    env {
		append params " env"
		set envlist ""
		foreach pair $value {
		    lassign $pair var value
		    append envlist " $var"
		    append envlist " [format {[%s]} [list s $value]]"
		}
		append params " \[o $envlist\]"
	    }

	    stop_at_main {
		append params { stopAtBeginningOfMainSubprogram [l true]}
	    }

	    cwd {
		append envlist " cwd [format {[%s]} [list s $value]]"
	    }

	    default {
		error "unrecognized parameter $key"
	    }
	}
    }

    return [dap_check_request_and_response "startup - launch" launch $params]
}

# Start gdb, send a DAP initialize request, and then an attach request
# specifying PID as the inferior process ID.  Returns the empty string
# on failure, or the response object from the attach request.
proc dap_attach {pid {prog ""}} {
    if {[dap_initialize "startup - initialize"] == ""} {
	return ""
    }

    set args [format {o pid [i %s]} $pid]
    if {$prog != ""} {
	append args [format { program [s %s]} $prog]
    }

    return [dap_check_request_and_response "startup - attach" attach $args]
}

# Start gdb, send a DAP initialize request, and then an attach request
# specifying TARGET as the remote target.  Returns the empty string on
# failure, or the response object from the attach request.
proc dap_target_remote {target} {
    if {[dap_initialize "startup - initialize"] == ""} {
	return ""
    }
    return [dap_check_request_and_response "startup - target" attach \
		[format {o target [s %s]} $target]]
}

# Read the most recent DAP log file and check it for exceptions.
proc dap_check_log_file {} {
    set fd [open [current_dap_log_file]]
    set contents [read $fd]
    close $fd

    set ok 1
    foreach line [split $contents "\n"] {
	if {[regexp "^Traceback" $line]} {
	    set ok 0
	    break
	}
    }

    if {$ok} {
	pass "exceptions in log file"
    } else {
	verbose -log --  "--- DAP LOG START ---"
	verbose -log -- $contents
	verbose -log --  "--- DAP LOG END ---"
	fail "exceptions in log file"
    }
}

# Read the most recent DAP log file and check that regexp RE matches.
proc dap_check_log_file_re { re } {
    set fd [open [current_dap_log_file]]
    set contents [read $fd]
    close $fd

    set ok [regexp $re $contents]
    gdb_assert {$ok} "log file matched $re"
}

# Cleanly shut down gdb.  TERMINATE is passed as the terminateDebuggee
# parameter to the request.
proc dap_shutdown {{terminate false}} {
    dap_check_request_and_response "shutdown" disconnect \
	[format {o terminateDebuggee [l %s]} $terminate]

    # Check gdb's exit status.
    global gdb_spawn_id
    set result [wait -i $gdb_spawn_id]
    gdb_assert {[lindex $result 2] == 0}
    gdb_assert {[lindex $result 3] == 0}

    clear_gdb_spawn_id

    dap_check_log_file
}

# Search the event list EVENTS for an output event matching the regexp
# RX.  Pass the test NAME if found, fail if not.
proc dap_search_output {name rx events} {
    foreach d $events {
	if {[dict get $d type] != "event"
	    || [dict get $d event] != "output"} {
	    continue
	}
	if {[regexp $rx [dict get $d body output]]} {
	    pass $name
	    return
	}
    }
    fail $name
}

# Check that D (a dict object) has values that match the
# key/value pairs given in ARGS.  NAME is used as the test name.
proc dap_match_values {name d args} {
    foreach {key value} $args {
	if {[eval dict get [list $d] $key] != $value} {
	    fail "$name (checking $key)"
	    return ""
	}
    }
    pass $name
}

# A helper for dap_wait_for_event_and_check that reads events, looking for one
# matching TYPE.
#
# Return a list of two items:
#
#  - the matched event
#  - a list of any JSON objects (events or others) seen before the matched
#    event.
proc _dap_wait_for_event { {type ""} } {
    set preceding [list]

    while 1 {
	# We don't do any extra error checking here for the time
	# being; we'll just get a timeout thrown instead.
	set d [_dap_read_json]
	if {[dict get $d type] == "event"
	    && ($type == "" || [dict get $d event] == $type)} {
	    return [list $d $preceding]
	}

	lappend preceding $d
    }
}

# Read JSON objects looking for an event whose "event" field is TYPE.
#
# NAME is used as the test name; it defaults to TYPE.  Extra arguments
# are used to check fields of the event; the arguments alternate
# between a field name (in "dict get" form) and its expected value.
#
# Return a list of two items:
#
#  - the matched event (regardless of whether it passed the field validation or
#    not)
#  - a list of any JSON objects (events or others) seen before the matched
#    event.
proc dap_wait_for_event_and_check {name type args} {
    if {$name == ""} {
	set name $type
    }

    set result [_dap_wait_for_event $type]
    set event [lindex $result 0]
    eval dap_match_values [list $name $event] $args

    return $result
}

# A convenience function to extract the breakpoint number when a new
# breakpoint is created.  OBJ is an object as returned by
# dap_check_request_and_response.
proc dap_get_breakpoint_number {obj} {
    set d [lindex $obj 0]
    set bplist [dict get $d body breakpoints]
    return [dict get [lindex $bplist 0] id]
}