1 # Установка номера тестового ПРА
4 set regnumPRA 0000000000000001
9 # Собственно тестовый фреймворк
14 # Уровень логгинга по умолчанию. Может быть переопределен явным
15 # присваиванием перед созданием контекста. Действует на контексты
16 # созданные makeCtx, makeCtx2 и threecontexts.
17 # Задание -logminpriority в test::ctxParams имеет приоритет.
19 # Переменная хранящая имя динамической библиотеки для userlib
21 # Чтобы timestamp была определена всегда
22 variable timestamp [clock seconds]
25 if {$::tcl_platform(platform)!="dos"} {
26 set dirlist [list [file dirname [info script]]\
27 [file dirname [info nameofexecutable]]]
28 if {$::tcl_platform(platform) == "windows"} {
30 [file normalize [file join [file dirname [info script]] .. obj_mid.w32]]\
31 [file normalize [file join [file dirname [info script]] .. obj_mid.w32]]
32 } elseif {$::tcl_platform(os) == "Linux"} {
34 [file normalize [file join [file dirname [info script]] .. obj_sid.lnx]]
35 } elseif {$::tcl_platform(os) == "SunOS"} {
36 if {$::tcl_platform(wordSize) == 8} {
38 } elseif {$::tcl_platform(byteOrder) == "littleEndian"} {
44 [file normalize [file join [file dirname [info script]] .. obj_sid.$for]]
46 foreach dir $dirlist {
47 set userlib_file [file join $dir usermci[info sharedlibextension]]
48 if {[file exists $userlib_file]} {
52 if {![file exists $userlib_file]} {
53 error "No usable userlib found in $dirlist"
55 set userlib [list -userlib $userlib_file]
63 # Вызывается в начале тестового скрипта. Инициализирует необходимые
64 # переменные пакета, открывает лог и пишет в него заголовок
65 # Параметры name - заголовок тестового скрипта.
67 # Побочные эффекты - создается <имя-скрипта>.log
69 proc start_tests {name} {
71 if {![info exists suffix]} {
72 set binary [file rootname [file tail [info nameofexecutable]]]
73 if {$binary != "tclsh"} {
74 set suffix "_[string range [file tail [info nameofexecutable]] 0 2]"
79 variable logname [file rootname [file tail [info script]]]$suffix.log
80 variable no 0 ok 0 failed 0 p_skip 0 c_skip 0 t_name $name logchannel [open $logname w] tempfiles {}
81 if {![catch {package present Vizir}]} {
84 puts [format [rus "=========== Группа тестов: %s ================="] [rus $name]]
85 puts $::test::logchannel [format [rus "Группа тестов \"%s\""] $name]
88 # Завершает выполнение теста и выводит отчет
101 puts "==================================================="
102 puts [format [rus "Всего %d тестов. Выполнено %d успешно, %d неуспешно"] $no $ok $failed]
103 if {$p_skip || $c_skip} {
104 puts [format [rus "Пропущено: %d на данной платформе %d из-за невыполнения других тестов"] $p_skip $c_skip]
107 puts [format [rus "Смотри более подробную информацию в %s"] $logname]
109 set test_id [file rootname [file tail [info script]]]$suffix
110 set stat [open "stats" a]
111 fconfigure $stat -encoding utf-8
112 puts $stat [list $test_id [rus $t_name] $no $ok $failed $p_skip $c_skip]
115 foreach file $tempfiles {
117 if [info exists $file] {puts [test_log] "Deleting $file"
121 # signal to a caller that we had failures
126 # Вовзращает идентификатор канала, куда пишется лог тестов.
127 # Рекомендуется назначать его в качестве -logchannel создаваемым
128 # контекстам чтобы вся выдача была в одном месте
138 # 2. Код (рекомендуется писать {
141 # 3. Ожидаемый результат выполнения - 0 успешно 1 - ошибка. Варианты
142 # больше 1 (TCL_BREAK, TCL_CONTINUE и TCL_RETURN) возможны, но вряд
144 # 4. Ожидаемый возвращаемый результат
145 # Если предыдущий параметр 0, результат сравнивается на точное
146 # совпадение, если 1 - результат - регексп, которому должно
147 # удовлетворять сообщение об ошибке.
152 while {[string match -* [lindex $args 0]]} {
153 set key [lindex $args 0]
154 set val [lindex $args 1]
155 set args [lrange $args 2 end]
158 foreach {message code exitStatus expectedResult} $args break
160 if {[info exists opts(-platform)] && [lsearch -exact $opts(-platform) $::tcl_platform(platform)]==-1} {
161 logskip $message "platform"
164 if {[info exists opts(-platformex)] && ![uplevel expr $opts(-platformex)]} {
165 logskip $message "platform"
168 if {[info exists opts(-skip)] && [uplevel expr $opts(-skip)]} {
169 logskip $message "prereq"
172 if {[info exists opts(-fixme)] && [uplevel expr $opts(-fixme)]} {
173 logmiss $message "FIXME"
176 if {[info exists opts(-createsfiles)]} {
177 foreach file $opts(-createsfiles) {
178 lappend tempfiles $file
179 if {[file exists $file]} {file delete $file}
182 if {[info exists opts(-createsvars)]} {
183 foreach var $opts(-createsvars) {
184 uplevel "if {\[info exists $var\]} {unset $var}"
188 set teststart [clock seconds]
189 set status [catch {uplevel $code} result]
190 set testend [clock seconds]
191 if {$teststart == $testend} {
192 set timestamp $teststart
194 # Handle negative intervals correctly
195 if {$teststart > $testend} {
196 set timestamp "$testend+[expr $teststart-$testend]"
198 set timestamp "$teststart+[expr $testend-$teststart]"
201 if {($exitStatus!=-1 && $status!=$exitStatus) ||
202 ($exitStatus!=0?![regexp --\
203 [rus $expectedResult] $result]:([info exists opts(-time)]?\
204 ![listcompare $result $expectedResult $opts(-time)]:\
205 [string compare "$result" "$expectedResult"]))} {
208 set expectedResult [rus $expectedResult]
210 log "Code:----$code---------------"
211 log "Expected status $exitStatus got $status"
212 log "Expected result: [list $expectedResult]"
213 log " Got result: [list $result]"
215 log "errorCode = $::errorCode"
222 # Внутренние (неэкспортируемые)процедуры
227 # Сравнение списков с учетом того что некоторые элементы могут быть
228 # метками времени, которые проверяются с точностью +-секунда
229 # Параметр time - список, каждый элемент которого является индексом
230 # элемента в списке, либо списком индексов во вложенных списках
232 proc listcompare {list1 list2 time} {
234 if {[llength $e]>1} {
235 lappend a([lindex $e 0]) [lrange $e 1 end]
240 if {[llength $list1] !=[llength $list2]} {
244 foreach e1 $list1 e2 $list2 {
245 if {![info exists a($i)]} {
246 if {[string compare $e1 $e2]!=0} {
249 } elseif {[llength $a($i)]} {
250 if {![listcompare $e1 $e2 $a($i)]} {
254 if {$e2 == "::test::timestamp"} {
255 set e2 $::test::timestamp
257 if {[regexp {^([[:digit:]]+)\+([[:digit:]]+)$} $e2 m start delta]} {
258 if {$e1<$start || $e1 >$start+$delta} {
261 } elseif {abs($e1-$e2)>1} {
277 puts $logchannel $message
280 # Вызывается при начале теста
282 proc logbegin {testname} {
286 puts -nonewline [rus [format "Тест%5d: %-60s:" $no [string range $testname 0 59]]]
288 set curtest $testname
289 log [rus "\n\nТест $no: $testname start"]
292 # Вызывается при пропуске теста
294 proc logskip {testname reason} {
298 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]skipped "
299 log "[rus "Тест $no: skipped "][expr {$reason=="platform"?"on
300 the platform $::tcl_platform(platform)":"due to failed prerequisites"}]:[rus $testname]"
302 if {$reason == "platform"} {
310 # Вызывается при игнорировании теста
312 proc logmiss {testname reason} {
315 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]missed "
316 log "[rus "Тест $no: missed "][expr {$reason=="platform"?"on
317 the platform $::tcl_platform(platform)":"by reason: $reason"}]:[rus $testname]"
323 # Вызывается конце теста и с параметром ok или failed
325 proc logend {status} {
331 log [rus "Тест $no: $curtest ends $status"]
334 #####################################################################
335 # Вспомогательные процедуры, не специфичные для тестируемого
337 #####################################################################
340 # Записывает данные из data в файл name. По умолчанию пишет в
341 # текущей системной кодировке. Можно указать кодировку явно третьим
344 proc makeFile {name data {encoding {}}} {
346 setFileEncoding $f $encoding
347 puts -nonewline $f $data
350 proc setFileEncoding {f encoding} {
351 if {[string length $encoding]} {
352 if {"$encoding" == "binary"} {
353 fconfigure $f -translation binary
355 fconfigure $f -encoding $encoding
360 # Возвращает содeржимое файла
363 proc getFile {filename {encoding {}}} {
364 set f [open $filename]
365 setFileEncoding $f $encoding
371 # Возвращает содержимое бинарного файла. Для совместимости со старыми
374 proc getfile {filename} {
375 return [getFile $filename binary]
378 # Зачитывает указанный файл, удаляет его и возвращает содержимое.
379 # По умолчанию читает файл в текущей системной кодировке. Можно
380 # указать кодировку явно вторым аргументом.
383 proc readAndDel {name {encoding {}}} {
385 setFileEncoding $f $encoding
394 # Защищает файл от записи средствами операционной системы
395 # denywrite filename ?boolean?
396 # Если boolean не указан, или он true, файл становится read-only
397 # Если указан - readwrite (для владельца. Впрочем для не-владельца все
398 # равно не сработает)
400 proc denyWrite {filename {deny 1}} {
402 if {$tcl_platform(platform) == "unix"} {
403 set cur_attr [file attributes $filename -permissions]
405 set new_attr [expr {$cur_attr &~ 0200}]
407 set new_attr [expr {$cur_attr | 0200}]
409 file attributes $filename -permissions $new_attr
411 file attributes $filename -readonly $deny
415 # Записывает в лог 16-ричный дамп указанной переменной
418 proc hexdump {data } {
419 while {[string length $data]} {
420 set block [string range $data 0 15]
421 set data [string replace $data 0 15]
422 binary scan [encoding convertto $block] c* list
426 append line [format "%02x " [expr $code>=0?$code:$code +256]]
431 append line [string repeat " " [expr 56-[string length $line]]]
432 regsub -all "\[\0-\37\]" $block . printable
433 append line [rus $printable]
437 namespace export test start_tests end_tests test_log rus log\
438 makeFile readAndDel hexdump denyWrite getFile getfile
440 namespace import ::test::*
442 package provide test 0.2