1# Copyright (C) 2009-2020 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
19load_lib gdb-guile.exp
20
21standard_testfile
22
23if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } {
24    return
25}
26
27# Skip all tests if Guile scripting is not enabled.
28if { [skip_guile_tests] } { continue }
29
30if ![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
37gdb_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
47gdb_test "guile (print (command? test-cmd))" "= #t"
48gdb_test "guile (print (command? 42))" "= #f"
49
50gdb_test "test-cmd ugh" "test-cmd output, arg = ugh" "call simple command"
51
52# Test a prefix command, and a subcommand within it.
53
54gdb_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
64gdb_test "prefix-cmd ugh" "prefix-cmd output, arg = ugh" "call prefix command"
65
66gdb_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
74gdb_test "prefix-cmd subcmd ugh" "subcmd output, arg = ugh" "call subcmd"
75
76# Test a subcommand in an existing GDB prefix.
77
78gdb_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
86gdb_test "info newsubcmd ugh" "newsubcmd output, arg = ugh" "call newsubcmd"
87
88# Test a command that throws gdb:user-error.
89
90gdb_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
98gdb_test "test-error-cmd ugh" "ERROR: you lose! ugh" "call error command"
99
100# Test string->argv.
101
102gdb_test "guile (raw-print (string->argv \"1 2 3\"))" \
103    {= \("1" "2" "3"\)} \
104    "(string->argv \"1 2 3\")"
105
106gdb_test "guile (raw-print (string->argv \"'1 2' 3\"))" \
107    {= \("1 2" "3"\)} \
108    "(string->argv \"'1 2' 3\")"
109
110gdb_test "guile (raw-print (string->argv \"\\\"1 2\\\" 3\"))" \
111    {= \("1 2" "3"\)} \
112    "(string->argv (\"\\\"1 2\\\" 3\")"
113
114gdb_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
120gdb_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
129gdb_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`.
133test_user_defined_class_help {"test-help -- Docstring[\r\n]"}
134
135# Make sure the command does not show up in `show user`.
136gdb_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
141gdb_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
150gdb_test "complete expr-test bar\." \
151    "expr-test bar\.bc.*expr-test bar\.ij.*" \
152    "test completion through complete command"
153
154set test "complete 'expr-test bar.i'"
155send_gdb "expr-test bar\.i\t\t"
156gdb_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
169gdb_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
179gdb_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
185gdb_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
193gdb_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
200gdb_test_no_output "guile (gc)"
201