| 1 | # Copyright (C) 2009-2019 Free Software Foundation, Inc. |
| 2 | |
| 3 | # This program is free software; you can redistribute it and/or modify |
| 4 | # it under the terms of the GNU General Public License as published by |
| 5 | # the Free Software Foundation; either version 3 of the License, or |
| 6 | # (at your option) any later version. |
| 7 | # |
| 8 | # This program is distributed in the hope that it will be useful, |
| 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 11 | # GNU General Public License for more details. |
| 12 | # |
| 13 | # You should have received a copy of the GNU General Public License |
| 14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. |
| 15 | |
| 16 | # This file is part of the GDB testsuite. It tests the mechanism |
| 17 | # for defining new GDB commands in Scheme. |
| 18 | |
| 19 | load_lib gdb-guile.exp |
| 20 | |
| 21 | standard_testfile |
| 22 | |
| 23 | if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } { |
| 24 | return |
| 25 | } |
| 26 | |
| 27 | # Skip all tests if Guile scripting is not enabled. |
| 28 | if { [skip_guile_tests] } { continue } |
| 29 | |
| 30 | if ![gdb_guile_runto_main] { |
| 31 | fail "can't run to main" |
| 32 | return |
| 33 | } |
| 34 | |
| 35 | # Test a simple command, and command? while we're at it. |
| 36 | |
| 37 | gdb_test_multiline "input simple command" \ |
| 38 | "guile" "" \ |
| 39 | "(define test-cmd" "" \ |
| 40 | " (make-command \"test-cmd\"" "" \ |
| 41 | " #:command-class COMMAND_OBSCURE" "" \ |
| 42 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 43 | " (display (format #f \"test-cmd output, arg = ~a\\n\" arg)))))" "" \ |
| 44 | "(register-command! test-cmd)" "" \ |
| 45 | "end" "" |
| 46 | |
| 47 | gdb_test "guile (print (command? test-cmd))" "= #t" |
| 48 | gdb_test "guile (print (command? 42))" "= #f" |
| 49 | |
| 50 | gdb_test "test-cmd ugh" "test-cmd output, arg = ugh" "call simple command" |
| 51 | |
| 52 | # Test a prefix command, and a subcommand within it. |
| 53 | |
| 54 | gdb_test_multiline "input prefix command" \ |
| 55 | "guile" "" \ |
| 56 | "(register-command! (make-command \"prefix-cmd\"" "" \ |
| 57 | " #:command-class COMMAND_OBSCURE" "" \ |
| 58 | " #:completer-class COMPLETE_NONE" "" \ |
| 59 | " #:prefix? #t" "" \ |
| 60 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 61 | " (display (format #f \"prefix-cmd output, arg = ~a\\n\" arg)))))" "" \ |
| 62 | "end" "" |
| 63 | |
| 64 | gdb_test "prefix-cmd ugh" "prefix-cmd output, arg = ugh" "call prefix command" |
| 65 | |
| 66 | gdb_test_multiline "input subcommand" \ |
| 67 | "guile" "" \ |
| 68 | "(register-command! (make-command \"prefix-cmd subcmd\"" "" \ |
| 69 | " #:command-class COMMAND_OBSCURE" "" \ |
| 70 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 71 | " (display (format #f \"subcmd output, arg = ~a\\n\" arg)))))" "" \ |
| 72 | "end" "" |
| 73 | |
| 74 | gdb_test "prefix-cmd subcmd ugh" "subcmd output, arg = ugh" "call subcmd" |
| 75 | |
| 76 | # Test a subcommand in an existing GDB prefix. |
| 77 | |
| 78 | gdb_test_multiline "input new subcommand" \ |
| 79 | "guile" "" \ |
| 80 | "(register-command! (make-command \"info newsubcmd\"" "" \ |
| 81 | " #:command-class COMMAND_OBSCURE" "" \ |
| 82 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 83 | " (display (format #f \"newsubcmd output, arg = ~a\\n\" arg)))))" "" \ |
| 84 | "end" "" |
| 85 | |
| 86 | gdb_test "info newsubcmd ugh" "newsubcmd output, arg = ugh" "call newsubcmd" |
| 87 | |
| 88 | # Test a command that throws gdb:user-error. |
| 89 | |
| 90 | gdb_test_multiline "input command to throw error" \ |
| 91 | "guile" "" \ |
| 92 | "(register-command! (make-command \"test-error-cmd\"" "" \ |
| 93 | " #:command-class COMMAND_OBSCURE" "" \ |
| 94 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 95 | " (throw-user-error \"you lose! ~a\" arg))))" "" \ |
| 96 | "end" "" |
| 97 | |
| 98 | gdb_test "test-error-cmd ugh" "ERROR: you lose! ugh" "call error command" |
| 99 | |
| 100 | # Test string->argv. |
| 101 | |
| 102 | gdb_test "guile (raw-print (string->argv \"1 2 3\"))" \ |
| 103 | {= \("1" "2" "3"\)} \ |
| 104 | "(string->argv \"1 2 3\")" |
| 105 | |
| 106 | gdb_test "guile (raw-print (string->argv \"'1 2' 3\"))" \ |
| 107 | {= \("1 2" "3"\)} \ |
| 108 | "(string->argv \"'1 2' 3\")" |
| 109 | |
| 110 | gdb_test "guile (raw-print (string->argv \"\\\"1 2\\\" 3\"))" \ |
| 111 | {= \("1 2" "3"\)} \ |
| 112 | "(string->argv (\"\\\"1 2\\\" 3\")" |
| 113 | |
| 114 | gdb_test "guile (raw-print (string->argv \"1\\\\ 2 3\"))" \ |
| 115 | {= \("1 2" "3"\)} \ |
| 116 | "(string->argv \"1\\\\ 2 3\")" |
| 117 | |
| 118 | # Test user-defined guile commands. |
| 119 | |
| 120 | gdb_test_multiline "input simple user-defined command" \ |
| 121 | "guile" "" \ |
| 122 | "(register-command! (make-command \"test-help\"" "" \ |
| 123 | " #:doc \"Docstring\"" "" \ |
| 124 | " #:command-class COMMAND_USER" "" \ |
| 125 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 126 | " (display (format #f \"test-cmd output, arg = ~a\\n\" arg)))))" "" \ |
| 127 | "end" "" |
| 128 | |
| 129 | gdb_test "test-help ugh" "test-cmd output, arg = ugh" \ |
| 130 | "call simple user-defined command" |
| 131 | |
| 132 | # Make sure the command shows up in `help user-defined`. |
| 133 | test_user_defined_class_help {"test-help -- Docstring[\r\n]"} |
| 134 | |
| 135 | # Make sure the command does not show up in `show user`. |
| 136 | gdb_test "show user test-help" "Not a user command\." \ |
| 137 | "don't show user-defined scheme command in `show user command`" |
| 138 | |
| 139 | # Test expression completion on fields. |
| 140 | |
| 141 | gdb_test_multiline "expression completion command" \ |
| 142 | "guile" "" \ |
| 143 | "(register-command! (make-command \"expr-test\"" "" \ |
| 144 | " #:command-class COMMAND_USER" ""\ |
| 145 | " #:completer-class COMPLETE_EXPRESSION" "" \ |
| 146 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 147 | " (display (format #f \"invoked on = ~a\\n\" arg)))))" "" \ |
| 148 | "end" "" |
| 149 | |
| 150 | gdb_test "complete expr-test bar\." \ |
| 151 | "expr-test bar\.bc.*expr-test bar\.ij.*" \ |
| 152 | "test completion through complete command" |
| 153 | |
| 154 | set test "complete 'expr-test bar.i'" |
| 155 | send_gdb "expr-test bar\.i\t\t" |
| 156 | gdb_test_multiple "" "$test" { |
| 157 | -re "expr-test bar\.ij \\\x07$" { |
| 158 | send_gdb "\n" |
| 159 | gdb_test_multiple "" $test { |
| 160 | -re "invoked on = bar.ij.*$gdb_prompt $" { |
| 161 | pass "$test" |
| 162 | } |
| 163 | } |
| 164 | } |
| 165 | } |
| 166 | |
| 167 | # Test using a function for completion. |
| 168 | |
| 169 | gdb_test_multiline "completer-as-function command" \ |
| 170 | "guile" "" \ |
| 171 | "(register-command! (make-command \"completer-as-function\"" "" \ |
| 172 | " #:command-class COMMAND_USER" ""\ |
| 173 | " #:completer-class (lambda (self text word)" "" \ |
| 174 | " (list \"1\" \"2\" \"3\"))" "" \ |
| 175 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 176 | " (display (format #f \"invoked on = ~a\\n\" arg)))))" "" \ |
| 177 | "end" "" |
| 178 | |
| 179 | gdb_test "complete completer-as-function 42\." \ |
| 180 | "completer-as-function 42\.1.*completer-as-function 42\.2.*completer-as-function 42\.3" \ |
| 181 | "test completion with completion function" |
| 182 | |
| 183 | # Test Scheme error in invoke function. |
| 184 | |
| 185 | gdb_test_multiline "input command with Scheme error" \ |
| 186 | "guile" "" \ |
| 187 | "(register-command! (make-command \"test-scheme-error-cmd\"" "" \ |
| 188 | " #:command-class COMMAND_OBSCURE" "" \ |
| 189 | " #:invoke (lambda (self arg from-tty)" "" \ |
| 190 | " oops-bad-spelling)))" "" \ |
| 191 | "end" "" |
| 192 | |
| 193 | gdb_test "test-scheme-error-cmd ugh" \ |
| 194 | "Error occurred in Scheme-implemented GDB command." \ |
| 195 | "call scheme-error command" |
| 196 | |
| 197 | # If there is a problem with object management, this can often trigger it. |
| 198 | # It is useful to do this last, after we've created a bunch of command objects. |
| 199 | |
| 200 | gdb_test_no_output "guile (gc)" |