gdb/testsuite/lib/dap-support.exp - binutils-gdb - Git at Google

 # Copyright 2022-2023 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 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

 # 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 [standard_output_file "dap.log.$gdb_instances"]
 	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.
 proc _dap_read_json {} {
     set length ""
     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 {
 	    error "timeout reading json header"
 	}
 	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)}]
 	gdb_expect {
 	    -re "^.{$this_len}" {
 		append json $expect_out(0,string)
 	    }
 	    timeout {
 		error "timeout reading json body"
 	    }
 	    eof {
 		error "eof reading json body"
 	    }
 	}
 	incr length -$this_len
     }

     set ton [ton::json2ton $json]
     return [namespace eval ton::2dict $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

 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.  Callers not caring about this should probably use
 # dap_launch.  Returns the empty string on failure.  NAME is used as
 # the test name.
 proc _dap_initialize {name} {
     if {[dap_gdb_start]} {
 	return ""
     }
     return [dap_check_request_and_response $name initialize]
 }

 # Start gdb, send a DAP initialize request, and then 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.  After this is called, gdb will be ready to accept
 # breakpoint requests.  NAME is used as the test name.  It has a
 # reasonable default but can be overridden in case a test needs to
 # launch gdb more than once.
 proc dap_launch {file {name startup}} {
     if {[_dap_initialize "$name - initialize"] == ""} {
 	return ""
     }
     return [dap_check_request_and_response "$name - launch" launch \
 		[format {o program [%s]} \
 		     [list s [standard_output_file $file]]]]
 }

 # Cleanly shut down gdb.  NAME is used as the test name.
 proc dap_shutdown {{name shutdown}} {
     dap_check_request_and_response $name disconnect
 }

 # 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]
 }
	# Copyright 2022-2023 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 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

	# 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 [standard_output_file "dap.log.$gdb_instances"]
	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.
	proc _dap_read_json {} {
	set length ""
	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 {
	error "timeout reading json header"
	}
	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)}]
	gdb_expect {
	-re "^.{$this_len}" {
	append json $expect_out(0,string)
	}
	timeout {
	error "timeout reading json body"
	}
	eof {
	error "eof reading json body"
	}
	}
	incr length -$this_len
	}

	set ton [ton::json2ton $json]
	return [namespace eval ton::2dict $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

	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. Callers not caring about this should probably use
	# dap_launch. Returns the empty string on failure. NAME is used as
	# the test name.
	proc _dap_initialize {name} {
	if {[dap_gdb_start]} {
	return ""
	}
	return [dap_check_request_and_response $name initialize]
	}

	# Start gdb, send a DAP initialize request, and then 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. After this is called, gdb will be ready to accept
	# breakpoint requests. NAME is used as the test name. It has a
	# reasonable default but can be overridden in case a test needs to
	# launch gdb more than once.
	proc dap_launch {file {name startup}} {
	if {[_dap_initialize "$name - initialize"] == ""} {
	return ""
	}
	return [dap_check_request_and_response "$name - launch" launch \
	[format {o program [%s]} \
	[list s [standard_output_file $file]]]]
	}

	# Cleanly shut down gdb. NAME is used as the test name.
	proc dap_shutdown {{name shutdown}} {
	dap_check_request_and_response $name disconnect
	}

	# 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]
	}