]>
Commit | Line | Data |
---|---|---|
3666a048 | 1 | # Copyright (C) 2009-2021 Free Software Foundation, Inc. |
e698b8c4 DE |
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 | ||
5b362f04 | 23 | if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } { |
e698b8c4 DE |
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] { | |
bc6c7af4 | 31 | fail "can't run to main" |
e698b8c4 DE |
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`. | |
206584bd | 133 | test_user_defined_class_help {"test-help -- Docstring[\r\n]"} |
e698b8c4 | 134 | |
a9f116cb GKB |
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 | ||
e698b8c4 DE |
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)" |