Add lib/dg.exp unit tests for xfail by target
[dejagnu.git] / lib / tip.exp
blob642421dd513bb5683fb714d7e1919af7911836e7
1 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
3 # This file is part of DejaGnu.
5 # DejaGnu is free software; you can redistribute it and/or modify it
6 # under the terms of the GNU General Public License as published by
7 # the Free Software Foundation; either version 3 of the License, or
8 # (at your option) any later version.
10 # DejaGnu is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with DejaGnu; if not, write to the Free Software Foundation,
17 # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
19 # Connect to HOSTNAME using tip(1). Sets the board's fileid field
20 # with the spawn_id on success and returns the spawn id, otherwise
21 # returns -1.
23 proc tip_open { hostname } {
24 global verbose
25 global spawn_id
27 set tries 0
28 set result -1
30 if {[board_info $hostname exists name]} {
31 set hostname [board_info $hostname name]
33 set port [board_info $hostname tipname]
34 if {[board_info $hostname exists shell_prompt]} {
35 set shell_prompt [board_info $hostname shell_prompt]
36 } else {
37 # Pick something reasonably generic.
38 set shell_prompt ".*> "
41 if {[board_info $hostname exists fileid]} {
42 unset board_info($hostname,fileid)
44 spawn tip -v $port
45 if { $spawn_id < 0 } {
46 perror "invalid spawn id from tip"
47 return -1
49 expect {
50 -re ".*connected.*$" {
51 send "\r\n"
52 expect {
53 -re ".*$shell_prompt.*$" {
54 verbose "Got prompt\n"
55 set result 0
56 incr tries
58 timeout {
59 warning "Never got prompt."
60 set result -1
61 incr tries
62 if { $tries <= 2 } {
63 exp_continue
68 -re "all ports busy.*$" {
69 set result -1
70 perror "All ports busy."
71 incr tries
72 if { $tries <= 2 } {
73 exp_continue
76 -re "Connection Closed.*$" {
77 perror "Never connected."
78 set result -1
79 incr tries
80 if { $tries <= 2 } {
81 exp_continue
84 -re ".*: Permission denied.*link down.*$" {
85 perror "Link down."
86 set result -1
87 incr tries
89 timeout {
90 perror "Timed out trying to connect."
91 set result -1
92 incr tries
93 if { $tries <= 2 } {
94 exp_continue
97 eof {
98 perror "Got unexpected EOF from tip."
99 set result -1
100 incr tries
104 send "\n~s"
105 expect {
106 "~\[set\]*" {
107 verbose "Setting verbose mode" 1
108 send "verbose\n\n\n"
112 if { $result < 0 } {
113 perror "Couldn't connect after $tries tries."
114 return -1
115 } else {
116 set board_info($hostname,fileid) $spawn_id
117 return $spawn_id
121 # Download FILE to DEST using the ~put command in tip(1).
122 # Returns -1 if an error occurred, otherwise returns 0.
124 proc tip_download { dest file args } {
125 global verbose
126 global decimal
127 global expect_out
129 if {[board_info $dest exists shell_prompt]} {
130 set shell_prompt [board_info $dest shell_prompt]
131 } else {
132 set shell_prompt ".*>"
135 set result ""
136 if {![board_info $dest exists fileid]} {
137 perror "tip_download: no connection to $dest."
138 return $result
140 set shell_id [board_info $dest fileid]
142 if {![file exists $file]} {
143 perror "$file doesn't exist."
144 return $result
147 send -i $shell_id "\n~p"
148 expect {
149 -i $shell_id "~\[put\]*" {
150 verbose "Downloading $file, please wait" 1
151 send -i $shell_id "$file\n"
152 set timeout 50
153 expect {
154 -i $shell_id -re ".*$file.*$" {
155 exp_continue
157 -i $shell_id -re ".*lines transferred in.*minute.*seconds.*$shell_prompt.*$" {
158 verbose "Download $file successfully" 1
159 set result $file
161 -i $shell_id -re ".*Invalid command.*$shell_prompt$" {
162 warning "Got an invalid command to the remote shell."
164 -i $shell_id -re ".*$decimal\r" {
165 if {[info exists expect_out(buffer)]} {
166 verbose $expect_out(buffer)
167 exp_continue
170 -i $shell_id timeout {
171 perror "Timed out trying to download."
175 timeout {
176 perror "Timed out waiting for response to put command."
179 set timeout 10
180 return $result