gdb.exp

这个是LINUX下的GDB调度工具的源码

# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004
# 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 2 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, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  

# This file was written by Fred Fish. ([e-mail])

# Generic gdb subroutines that should work for any target.  If these
# need to be modified for any target, it can be done with a variable
# or by passing arguments.

load_lib libgloss.exp

global GDB

if [info exists TOOL_EXECUTABLE] {
    set GDB $TOOL_EXECUTABLE;
}
if ![info exists GDB] {
    if ![is_remote host] {
	set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
    } else {
	set GDB [transform gdb];
    }
}
verbose "using GDB = $GDB" 2

global GDBFLAGS
if ![info exists GDBFLAGS] {
    set GDBFLAGS "-nx"
}
verbose "using GDBFLAGS = $GDBFLAGS" 2

# The variable gdb_prompt is a regexp which matches the gdb prompt.
# Set it if it is not already set.
global gdb_prompt
if ![info exists gdb_prompt] then {
    set gdb_prompt "\[(\]gdb\[)\]"
}

# Needed for some tests under Cygwin.
global EXEEXT
global env

if ![info exists env(EXEEXT)] {
    set EXEEXT ""
} else {
    set EXEEXT $env(EXEEXT)
}

### Only procedures should come after this point.

#
# gdb_version -- extract and print the version number of GDB
#
proc default_gdb_version {} {
    global GDB
    global GDBFLAGS
    global gdb_prompt
    set fileid [open "gdb_cmd" w];
    puts $fileid "q";
    close $fileid;
    set cmdfile [remote_download host "gdb_cmd"];
    set output [remote_exec host "$GDB -nw --command $cmdfile"]
    remote_file build delete "gdb_cmd";
    remote_file host delete "$cmdfile";
    set tmp [lindex $output 1];
    set version ""
    regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
    if ![is_remote host] {
	clone_output "[which $GDB] version $version $GDBFLAGS\n"
    } else {
	clone_output "$GDB on remote host version $version $GDBFLAGS\n"
    }
}

proc gdb_version { } {
    return [default_gdb_version];
}

#
# gdb_unload -- unload a file if one is loaded
#

proc gdb_unload {} {
    global verbose
    global GDB
    global gdb_prompt
    send_gdb "file\n"
    gdb_expect 60 {
	-re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
	-re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
	-re "A program is being debugged already..*Kill it.*y or n. $"\
	    { send_gdb "y\n"
		verbose "\t\tKilling previous program being debugged"
	    exp_continue
	}
	-re "Discard symbol table from .*y or n.*$" {
	    send_gdb "y\n"
	    exp_continue
	}
	-re "$gdb_prompt $" {}
	timeout {
	    perror "couldn't unload file in $GDB (timed out)."
	    return -1
	}
    }
}

# Many of the tests depend on setting breakpoints at various places and
# running until that breakpoint is reached.  At times, we want to start
# with a clean-slate with respect to breakpoints, so this utility proc 
# lets us do this without duplicating this code everywhere.
#

proc delete_breakpoints {} {
    global gdb_prompt

    # we need a larger timeout value here or this thing just confuses
    # itself.  May need a better implementation if possible. - guo
    #
    send_gdb "delete breakpoints\n"
    gdb_expect 100 {
	 -re "Delete all breakpoints.*y or n.*$" {
	    send_gdb "y\n";
	    exp_continue
	}
	 -re "$gdb_prompt $" { # This happens if there were no breakpoints
	    }
	 timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
    }
    send_gdb "info breakpoints\n"
    gdb_expect 100 {
	 -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
	 -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
	 -re "Delete all breakpoints.*or n.*$" {
	    send_gdb "y\n";
	    exp_continue
	}
	 timeout { perror "info breakpoints (timeout)" ; return }
    }
}


#
# Generic run command.
#
# The second pattern below matches up to the first newline *only*.
# Using ``.*$'' could swallow up output that we attempt to match
# elsewhere.
#
proc gdb_run_cmd {args} {
    global gdb_prompt

    if [target_info exists gdb_init_command] {
	send_gdb "[target_info gdb_init_command]\n";
	gdb_expect 30 {
	    -re "$gdb_prompt $" { }
	    default {
		perror "gdb_init_command for target failed";
		return;
	    }
	}
    }

    if [target_info exists use_gdb_stub] {
	if [target_info exists gdb,do_reload_on_run] {
	    # Specifying no file, defaults to the executable
	    # currently being debugged.
	    if { [gdb_load ""] != 0 } {
		return;
	    }
	    send_gdb "continue\n";
	    gdb_expect 60 {
		-re "Continu\[^\r\n\]*\[\r\n\]" {}
		default {}
	    }
	    return;
	}

	if [target_info exists gdb,start_symbol] {
	    set start [target_info gdb,start_symbol];
	} else {
	    set start "start";
	}
	send_gdb  "jump *$start\n"
	set start_attempt 1;
	while { $start_attempt } {
	    # Cap (re)start attempts at three to ensure that this loop
	    # always eventually fails.  Don't worry about trying to be
	    # clever and not send a command when it has failed.
	    if [expr $start_attempt > 3] {
		perror "Jump to start() failed (retry count exceeded)";
		return;
	    }
	    set start_attempt [expr $start_attempt + 1];
	    gdb_expect 30 {
		-re "Continuing at \[^\r\n\]*\[\r\n\]" {
		    set start_attempt 0;
		}
		-re "No symbol \"_start\" in current.*$gdb_prompt $" {
		    perror "Can't find start symbol to run in gdb_run";
		    return;
		}
		-re "No symbol \"start\" in current.*$gdb_prompt $" {
		    send_gdb "jump *_start\n";
		}
		-re "No symbol.*context.*$gdb_prompt $" {
		    set start_attempt 0;
		}
		-re "Line.* Jump anyway.*y or n. $" {
		    send_gdb "y\n"
		}
		-re "The program is not being run.*$gdb_prompt $" {
		    if { [gdb_load ""] != 0 } {
			return;
		    }
		    send_gdb "jump *$start\n";
		}
		timeout {
		    perror "Jump to start() failed (timeout)"; 
		    return
		}
	    }
	}
	if [target_info exists gdb_stub] {
	    gdb_expect 60 {
		-re "$gdb_prompt $" {
		    send_gdb "continue\n"
		}
	    }
	}
	return
    }

    if [target_info exists gdb,do_reload_on_run] {
	if { [gdb_load ""] != 0 } {
	    return;
	}
    }
    send_gdb "run $args\n"
# This doesn't work quite right yet.
    gdb_expect 60 {
	-re "The program .* has been started already.*y or n. $" {
	    send_gdb "y\n"
	    exp_continue
	}
	-re "Starting program: \[^\r\n\]*" {}
    }
}

# Set a breakpoint at FUNCTION.  If there is an additional argument it is
# a list of options; the only currently supported option is allow-pending.

proc gdb_breakpoint { function args } {
    global gdb_prompt
    global decimal

    set pending_response n
    if {[lsearch -exact [lindex $args 0] allow-pending] != -1} {
	set pending_response y
    }

    send_gdb "break $function\n"
    # The first two regexps are what we get with -g, the third is without -g.
    gdb_expect 30 {
	-re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
	-re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
	-re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {}
	-re "Breakpoint \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" {
		if {$pending_response == "n"} {
			fail "setting breakpoint at $function"
			return 0
		}
	}
	-re "Make breakpoint pending.*y or \\\[n\\\]. $" { 
		send_gdb "$pending_response\n"
		exp_continue
	}
	-re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 }
	timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
    }
    return 1;
}    

# Set breakpoint at function and run gdb until it breaks there.
# Since this is the only breakpoint that will be set, if it stops
# at a breakpoint, we will assume it is the one we want.  We can't
# just compare to "function" because it might be a fully qualified,
# single quoted C++ function specifier.  If there's an additional argument,
# pass it to gdb_breakpoint.

proc runto { function args } {
    global gdb_prompt
    global decimal

    delete_breakpoints

    if ![gdb_breakpoint $function [lindex $args 0]] {
	return 0;
    }

    gdb_run_cmd
    
    # the "at foo.c:36" output we get with -g.
    # the "in func" output we get without -g.
    gdb_expect 30 {
	-re "Break.* at .*:$decimal.*$gdb_prompt $" {
	    return 1
	}
	-re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { 
	    return 1
	}
	-re "$gdb_prompt $" { 
	    fail "running to $function in runto"
	    return 0
	}
	timeout { 
	    fail "running to $function in runto (timeout)"
	    return 0
	}
    }
    return 1
}

#
# runto_main -- ask gdb to run until we hit a breakpoint at main.
#		The case where the target uses stubs has to be handled
#		specially--if it uses stubs, assuming we hit
#		breakpoint() and just step out of the function.
#
proc runto_main { } {
    global gdb_prompt
    global decimal

    if ![target_info exists gdb_stub] {
	return [runto main]
    }			

    delete_breakpoints

    gdb_step_for_stub;

    return 1
}


### Continue, and expect to hit a breakpoint.
### Report a pass or fail, depending on whether it seems to have
### worked.  Use NAME as part of the test name; each call to
### continue_to_breakpoint should use a NAME which is unique within
### that test file.
proc gdb_continue_to_breakpoint {name} {
    global gdb_prompt
    set full_name "continue to breakpoint: $name"

    send_gdb "continue\n"
    gdb_expect {
	-re "Breakpoint .* at .*\r\n$gdb_prompt $" {
	    pass $full_name
	}
	-re ".*$gdb_prompt $" {
	    fail $full_name
	}
	timeout { 
	    fail "$full_name (timeout)"
	}
    }
}


# gdb_internal_error_resync:
#
# Answer the questions GDB asks after it reports an internal error
# until we get back to a GDB prompt.  Decline to quit the debugging
# session, and decline to create a core file.  Return non-zero if the
# resync succeeds.
#
# This procedure just answers whatever questions come up until it sees
# a GDB prompt; it doesn't require you to have matched the input up to
# any specific point.  However, it only answers questions it sees in
# the output itself, so if you've matched a question, you had better
# answer it yourself before calling this.
#
# You can use this function thus:
#
# gdb_expect {
#     ...
#     -re ".*A problem internal to GDB has been detected" {
#         gdb_internal_error_resync
#     }
#     ...
# }
#
proc gdb_internal_error_resync {} {
    global gdb_prompt

    set count 0
    while {$count < 10} {
	gdb_expect {
	    -re "Quit this debugging session\\? \\(y or n\\) $" {
		send_gdb "n\n"
		incr count
	    }
	    -re "Create a core file of GDB\\? \\(y or n\\) $" {
		send_gdb "n\n"
		incr count
	    }
	    -re "$gdb_prompt $" {
		# We're resynchronized.
		return 1
	    }
	    timeout {
		perror "Could not resync from internal error (timeout)"
		return 0
	    }
	}
    }
    perror "Could not resync from internal error (resync count exceeded)"
    return 0
}


# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS
# Send a command to gdb; test the result.
#
# COMMAND is the command to execute, send to GDB with send_gdb.  If
#   this is the null string no command is sent.
# MESSAGE is a message to be printed with the built-in failure patterns
#   if one of them matches.  If MESSAGE is empty COMMAND will be used.
# EXPECT_ARGUMENTS will be fed to expect in addition to the standard
#   patterns.  Pattern elements will be evaluated in the caller's
#   context; action elements will be executed in the caller's context.
#   Unlike patterns for gdb_test, these patterns should generally include
#   the final newline and prompt.
#
# Returns:
#    1 if the test failed, according to a built-in failure pattern
#    0 if only user-supplied patterns matched
#   -1 if there was an internal error.
#  
# You can use this function thus:
#
# gdb_test_multiple "print foo" "test foo" {
#    -re "expected output 1" {
#        pass "print foo"
#    }
#    -re "expected output 2" {
#        fail "print foo"
#    }
# }
#
# The standard patterns, such as "Program exited..." and "A problem
# ...", all being implicitly appended to that list.
#
proc gdb_test_multiple { command message user_code } {
    global verbose
    global gdb_prompt
    global GDB
    upvar timeout timeout
    upvar expect_out expect_out

    if { $message == "" } {
	set message $command
    }

    # TCL/EXPECT WART ALERT
    # Expect does something very strange when it receives a single braced
    # argument.  It splits it along word separators and performs substitutions.
    # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is
    # evaluated as "\[ab\]".  But that's not how TCL normally works; inside a
    # double-quoted list item, "\[ab\]" is just a long way of representing
    # "[ab]", because the backslashes will be removed by lindex.

    # Unfortunately, there appears to be no easy way to duplicate the splitting
    # that expect will do from within TCL.  And many places make use of the
    # "\[0-9\]" construct, so we need to support that; and some places make use
    # of the "[func]" construct, so we need to support that too.  In order to
    # get this right we have to substitute quoted list elements differently
    # from braced list elements.

    # We do this roughly the same way that Expect does it.  We have to use two
    # lists, because if we leave unquoted newlines in the argument to uplevel
    # they'll be treated as command separators, and if we escape newlines
    # we mangle newlines inside of command blocks.  This assumes that the
    # input doesn't contain a pattern which contains actual embedded newlines
    # at this point!

    regsub -all {\n} ${user_code} { } subst_code
    set subst_code [uplevel list $subst_code]

    set processed_code ""
    set patterns ""
    set expecting_action 0
    foreach item $user_code subst_item $subst_code {
	if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } {
	    lappend processed_code $item
	    continue
	}
	if {$item == "-indices" || $item == "-re" || $item == "-ex"} {
	    lappend processed_code $item
	    continue
	}
	if { $expecting_action } {
	    lappend processed_code "uplevel [list $item]"
	    set expecting_action 0
	    # Cosmetic, no effect on the list.
	    append processed_code "\n"
	    continue
	}