Add DAP support for C++ exceptions

[binutils-gdb.git] / gdb / testsuite / lib / dap-support.exp

# 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 \
                {o clientID [s "gdb testsuite"] \
                     supportsVariableType [l true] \
                     supportsVariablePaging [l true]}]
}

# 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.  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 {}}} {
    if {[_dap_initialize "startup - initialize"] == ""} {
        return ""
    }
    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} {
    if {[_dap_initialize "startup - initialize"] == ""} {
        return ""
    }
    return [dap_check_request_and_response "startup - attach" attach \
                [format {o pid [i %s]} $pid]]
}

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

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

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