1# Copyright 2014-2024 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# Utility procedures, shared between test suite domains.
17
18# A helper procedure to retrieve commands to send to GDB before a program
19# is started.
20
21proc gdb_init_commands {} {
22    set commands ""
23    if [target_info exists gdb_init_command] {
24          lappend commands [target_info gdb_init_command]
25    }
26    if [target_info exists gdb_init_commands] {
27          set commands [concat $commands [target_info gdb_init_commands]]
28    }
29    return $commands
30}
31
32# Given an input string, adds backslashes as needed to create a
33# regexp that will match the string.
34
35proc string_to_regexp {str} {
36    set result $str
37    regsub -all {[]?*+.|(){}^$\[\\]} $str {\\&} result
38    return $result
39}
40
41# Given a list of strings, adds backslashes as needed to each string to
42# create a regexp that will match the string, and join the result.
43
44proc string_list_to_regexp { args } {
45    set result ""
46    foreach arg $args {
47          set arg [string_to_regexp $arg]
48       append result $arg
49    }
50    return $result
51}
52
53# Wrap STR in an ANSI terminal escape sequences -- one to set the
54# style to STYLE, and one to reset the style to the default.  The
55# return value is suitable for use as a regular expression.
56
57# STYLE can either be the payload part of an ANSI terminal sequence,
58# or a shorthand for one of the gdb standard styles: "file",
59# "function", "variable", or "address".
60
61proc style {str style} {
62    switch -exact -- $style {
63          title { set style 1 }
64          file { set style 32 }
65          function { set style 33 }
66          highlight { set style 31 }
67          variable { set style 36 }
68          address { set style 34 }
69          metadata { set style 2 }
70          version { set style "35;1" }
71          none { return $str }
72    }
73    return "\033\\\[${style}m${str}\033\\\[m"
74}
75
76# gdb_get_bp_addr num
77#
78# Purpose:
79#    Get address of a particular breakpoint.
80#
81# Parameter:
82#    The parameter "num" indicates the number of the breakpoint to get.
83#    Note that *currently* this parameter must be an integer value.
84#    E.g., -1 means that we're gonna get the first internal breakpoint;
85#    2 means to get the second user-defined breakpoint.
86#
87# Return:
88#    First address for a particular breakpoint.
89#
90# TODO:
91#    It would be nice if this procedure could accept floating point value.
92#    E.g., 'gdb_get_bp_addr 1.2' means to get the address of the second
93#    location of breakpoint #1.
94#
95proc gdb_get_bp_addr { num } {
96    gdb_test_multiple "maint info break $num" "find address of specified bp $num" {
97          -re -wrap ".*(0x\[0-9a-f\]+).*" {
98              return $expect_out(1,string)
99          }
100    }
101    return ""
102}
103
104# Compare the version numbers in L1 to those in L2 using OP, and
105# return 1 if the comparison is true.  OP can be "<", "<=", or "==".
106# It is ok if the lengths of the lists differ.
107
108proc version_compare { l1 op l2 } {
109    switch -exact $op {
110          "=="    -
111          "<="    -
112          "<"     {}
113          default { error "unsupported op: $op" }
114    }
115
116    # Handle ops < and ==.
117    foreach v1 $l1 v2 $l2 {
118          if {$v1 == ""} {
119              # This is: "1.2 OP 1.2.1".
120              if {$op != "=="} {
121                    return 1
122              }
123              return 0
124          }
125          if {$v2 == ""} {
126              # This is: "1.2.1 OP 1.2".
127              return 0
128          }
129          if {$v1 == $v2} {
130              continue
131          }
132          return [expr $v1 $op $v2]
133    }
134
135    if {$op == "<"} {
136          # They are equal.
137          return 0
138    }
139    return 1
140}
141
142# Acquire lock file LOCKFILE.  Tries forever until the lock file is
143# successfully created.
144
145proc lock_file_acquire {lockfile} {
146    verbose -log "acquiring lock file: $::subdir/${::gdb_test_file_name}.exp"
147    while {true} {
148          if {![catch {open $lockfile {WRONLY CREAT EXCL}} rc]} {
149              set msg "locked by $::subdir/${::gdb_test_file_name}.exp"
150              verbose -log "lock file: $msg"
151              # For debugging, put info in the lockfile about who owns
152              # it.
153              puts  $rc $msg
154              flush $rc
155              return [list $rc $lockfile]
156          }
157          after 10
158    }
159}
160
161# Release a lock file.
162
163proc lock_file_release {info} {
164    verbose -log "releasing lock file: $::subdir/${::gdb_test_file_name}.exp"
165
166    if {![catch {fconfigure [lindex $info 0]}]} {
167          if {![catch {
168              close [lindex $info 0]
169              file delete -force [lindex $info 1]
170          } rc]} {
171              return ""
172          } else {
173              return -code error "Error releasing lockfile: '$rc'"
174          }
175    } else {
176          error "invalid lock"
177    }
178}
179
180# Return directory where we keep lock files.
181
182proc lock_dir {} {
183    if { [info exists ::GDB_LOCK_DIR] } {
184          # When using check//.
185          return $::GDB_LOCK_DIR
186    }
187
188    return [make_gdb_parallel_path cache]
189}
190
191# Run body under lock LOCK_FILE.
192
193proc with_lock { lock_file body } {
194    if {[info exists ::GDB_PARALLEL]} {
195          set lock_file [file join [lock_dir] $lock_file]
196          set lock_rc [lock_file_acquire $lock_file]
197    }
198
199    set code [catch {uplevel 1 $body} result]
200
201    if {[info exists ::GDB_PARALLEL]} {
202          lock_file_release $lock_rc
203    }
204
205    if {$code == 1} {
206          global errorInfo errorCode
207          return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
208    } else {
209          return -code $code $result
210    }
211}
212