tcl_tests/test.tcl

   1 # Установка номера тестового ПРА
   2
   3 namespace eval vizir {
   4         set regnumPRA 0000000000000001
   5 }
   6
   7 #
   8 #
   9 # Собственно тестовый фреймворк
  10
  11
  12
  13 namespace eval test {
  14         # Уровень логгинга по умолчанию. Может быть переопределен явным
  15         # присваиванием перед созданием контекста. Действует на контексты
  16         # созданные makeCtx, makeCtx2 и threecontexts.
  17         # Задание -logminpriority в test::ctxParams имеет приоритет.
  18         set logLevel 3
  19         # Переменная хранящая имя динамической библиотеки для userlib
  20         variable userlib {}
  21         # Чтобы timestamp была определена всегда
  22         variable timestamp [clock seconds]
  23         proc findUserLib {} {
  24                 variable userlib
  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"} {
  29                                 lappend dirlist\
  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"} {
  33                                 lappend dirlist\
  34                                 [file normalize [file join [file dirname [info script]] ..  obj_sid.lnx]]
  35                         } elseif {$::tcl_platform(os) == "SunOS"} {
  36                                 if {$::tcl_platform(wordSize) == 8} {
  37                                         set for s64
  38                                 } elseif {$::tcl_platform(byteOrder) == "littleEndian"} {
  39                                         set for s86
  40                                 } else {
  41                                         set for s32
  42                                 }
  43                                 lappend dirlist\
  44                                 [file normalize [file join [file dirname [info script]] ..  obj_sid.$for]]
  45                         }
  46                         foreach dir $dirlist {
  47                         set userlib_file [file join  $dir  usermci[info sharedlibextension]]
  48                                 if {[file exists $userlib_file]} {
  49                                         break
  50                                 }
  51                         }
  52                         if {![file exists $userlib_file]} {
  53                                 error "No usable userlib found in $dirlist"
  54                         }
  55                         set userlib [list -userlib $userlib_file]
  56                 } else {
  57                         set userlib {}
  58                 }
  59         }
  60         #
  61         #
  62         #
  63         # Вызывается в начале тестового скрипта. Инициализирует необходимые
  64         # переменные пакета, открывает лог и пишет в него заголовок
  65         # Параметры name - заголовок тестового скрипта.
  66         #
  67         # Побочные эффекты - создается <имя-скрипта>.log
  68         #
  69         proc start_tests {name} {
  70                 variable suffix
  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]"
  75                         } else {
  76                                 set suffix ""
  77                         }
  78                 }
  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}]} {
  82                         findUserLib
  83                 }
  84                 puts [format [rus "=========== Группа тестов: %s ================="] [rus $name]]
  85                 puts $::test::logchannel [format [rus "Группа тестов \"%s\""] $name]
  86         }
  87         #
  88         # Завершает выполнение теста и выводит отчет
  89         # Вызывает exit
  90         #
  91         proc end_tests {} {
  92                 variable no
  93                 variable ok
  94                 variable failed
  95                 variable p_skip
  96                 variable t_name
  97                 variable c_skip
  98                 variable logname
  99                 variable tempfiles
 100                 variable suffix
 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]
 105                 }
 106                 if {$failed} {
 107                         puts [format [rus "Смотри более подробную информацию в %s"] $logname]
 108                 }
 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]
 113                 close $stat
 114                 if {!$failed} {
 115                         foreach file $tempfiles {
 116
 117                                 if [info exists $file] {puts [test_log] "Deleting $file"
 118                                    file delete $file}
 119                         }
 120                 }
 121         }
 122    #
 123    # Вовзращает идентификатор канала, куда пишется лог тестов.
 124    # Рекомендуется назначать его в качестве -logchannel создаваемым
 125    # контекстам чтобы вся выдача была в одном месте
 126    #
 127    proc test_log {} {
 128                 variable logchannel
 129                 return $logchannel
 130         }
 131         #
 132         # Собственно тест
 133         #   Параметры
 134         #   1. Название теста
 135         #   2. Код (рекомендуется писать {
 136         #       код
 137         #     }
 138         #   3. Ожидаемый результат выполнения - 0 успешно 1 - ошибка. Варианты
 139         #     больше 1 (TCL_BREAK, TCL_CONTINUE и TCL_RETURN) возможны, но вряд
 140         #     ли интересны
 141         #   4. Ожидаемый возвращаемый результат
 142         #      Если предыдущий параметр 0, результат сравнивается на точное
 143         #      совпадение, если 1 - результат - регексп, которому должно
 144         #      удовлетворять сообщение об ошибке.
 145         proc test args {
 146                 array set opts {}
 147                 variable tempfiles
 148                 variable timestamp
 149                 while {[string match -* [lindex $args 0]]} {
 150                         set key [lindex $args 0]
 151                         set val [lindex $args 1]
 152                         set args [lrange $args 2 end]
 153                         set opts($key) $val
 154                 }
 155             foreach {message code exitStatus expectedResult} $args break
 156                 global errorInfo
 157                 if {[info exists opts(-platform)] && [lsearch -exact $opts(-platform) $::tcl_platform(platform)]==-1} {
 158                         logskip $message "platform"
 159                         return
 160                 }
 161                 if {[info exists opts(-platformex)] && ![uplevel expr $opts(-platformex)]} {
 162                         logskip $message "platform"
 163                         return
 164                 }
 165                 if {[info exists opts(-skip)] && [uplevel expr $opts(-skip)]} {
 166                         logskip $message "prereq"
 167                         return
 168                 }
 169                 if {[info exists opts(-fixme)] && [uplevel expr $opts(-fixme)]} {
 170                         logmiss $message "FIXME"
 171                         return
 172                 }
 173                 if {[info exists opts(-createsfiles)]} {
 174                         foreach file $opts(-createsfiles) {
 175                                 lappend tempfiles $file
 176                                 if {[file exists $file]} {file delete $file}
 177                         }
 178                 }
 179                 if {[info exists opts(-createsvars)]} {
 180                         foreach var $opts(-createsvars) {
 181                                 uplevel  "if {\[info exists $var\]} {unset $var}"
 182                         }
 183                 }
 184                 logbegin $message
 185                 set teststart [clock seconds]
 186                 set status [catch {uplevel $code} result]
 187                 set testend [clock seconds]
 188                 if {$teststart == $testend} {
 189                         set timestamp $teststart
 190                 } else {
 191                         # Handle negative intervals correctly
 192                         if {$teststart > $testend} {
 193                                 set timestamp "$testend+[expr $teststart-$testend]"
 194                         } else {
 195                                 set timestamp "$teststart+[expr $testend-$teststart]"
 196                         }
 197                 }
 198                 if {$status!=$exitStatus || ($status==1?![regexp --\
 199                         [rus $expectedResult] $result]:([info exists opts(-time)]?\
 200                     ![listcompare $result $expectedResult $opts(-time)]:\
 201                         [string compare "$result" "$expectedResult"]))} {
 202                         logend "failed"
 203                         if {$status == 1} {
 204                                 set expectedResult [rus $expectedResult]
 205                         }
 206                         log   "Code:----$code---------------"
 207                         log     "Expected status $exitStatus got $status"
 208                         log   "Expected result: [list $expectedResult]"
 209                         log     "     Got result: [list $result]"
 210                         if {$status == 1} {
 211                                 log "errorCode = $::errorCode"
 212                         }
 213                 } else {
 214                         logend "ok"
 215                 }
 216         }
 217 #
 218 # Внутренние (неэкспортируемые)процедуры
 219 #
 220 #
 221
 222 #
 223 # Сравнение списков с учетом того что некоторые элементы могут быть
 224 # метками времени, которые проверяются с точностью +-секунда
 225 # Параметр time - список, каждый элемент которого является индексом
 226 # элемента в списке, либо списком индексов во вложенных списках
 227 #
 228 proc listcompare {list1 list2 time} {
 229         foreach e $time {
 230                 if {[llength $e]>1} {
 231                         lappend a([lindex $e 0]) [lrange $e 1 end]
 232                 } else {
 233                         set a($e) {}
 234                 }
 235         }
 236         if {[llength $list1] !=[llength $list2]} {
 237                 return 0
 238         }
 239         set i 0
 240         foreach e1 $list1 e2 $list2 {
 241                 if {![info exists a($i)]} {
 242                         if {[string compare $e1 $e2]!=0} {
 243                                 return 0
 244                         }
 245                 } elseif {[llength $a($i)]} {
 246                         if {![listcompare $e1 $e2 $a($i)]} {
 247                                 return 0
 248                         }
 249                 } else {
 250                         if {$e2 == "::test::timestamp"} {
 251                                 set e2 $::test::timestamp
 252                         }
 253                         if {[regexp {^([[:digit:]]+)\+([[:digit:]]+)$} $e2 m start delta]} {
 254                                 if {$e1<$start || $e1 >$start+$delta} {
 255                                         return 0
 256                                 }
 257                         } elseif {abs($e1-$e2)>1} {
 258                                 return 0
 259                         }
 260                 }
 261                 incr i
 262         }
 263         return 1
 264 }
 265 proc rus {string} {
 266         return $string
 267 }
 268    #
 269    # Пишет строку в лог
 270    #
 271    proc log {message} {
 272                 variable logchannel
 273                 puts $logchannel $message
 274         }
 275         #
 276         # Вызывается при начале теста
 277         #
 278         proc logbegin {testname} {
 279                 variable no
 280                 variable curtest
 281                 incr no
 282                 puts -nonewline [rus [format "Тест%5d: %-60s:" $no [string range $testname 0 59]]]
 283                 flush stdout
 284                 set curtest $testname
 285                 log [rus "Тест $no: $testname start"]
 286         }
 287         #
 288         # Вызывается при пропуске теста
 289         #
 290         proc logskip {testname reason} {
 291                 variable no
 292                 variable p_skip
 293                 variable c_skip
 294                 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]skipped "
 295                 log "[rus "Тест $no: skipped "][expr {$reason=="platform"?"on
 296                 the platform $::tcl_platform(platform)":"due to failed prerequisites"}]:[rus $testname]"
 297                 incr no
 298                 if {$reason == "platform"} {
 299                         incr p_skip
 300                 } else {
 301                         incr c_skip
 302                 }
 303         }
 304
 305         #
 306         # Вызывается при игнорировании теста
 307         #
 308         proc logmiss {testname reason} {
 309                 variable no
 310                 variable c_skip
 311                 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]missed "
 312                 log "[rus "Тест $no: missed "][expr {$reason=="platform"?"on
 313                 the platform $::tcl_platform(platform)":"by reason: $reason"}]:[rus $testname]"
 314                 incr no
 315                 incr c_skip
 316         }
 317
 318         #
 319         # Вызывается конце теста и с параметром ok или failed
 320         #
 321         proc logend {status} {
 322                 variable no
 323                 variable curtest
 324                 variable $status
 325                 incr $status
 326                 puts $status
 327                 log [rus "Тест $no: $curtest ends $status"]
 328         }
 329
 330         #####################################################################
 331         # Вспомогательные процедуры, не специфичные для тестируемого
 332         # приложения
 333         #####################################################################
 334
 335         #
 336         # Записывает  данные из data в файл name. По умолчанию пишет в
 337         # текущей системной кодировке. Можно указать кодировку явно третьим
 338         # аргументом
 339         #
 340         proc makeFile {name data {encoding {}}} {
 341                 set f [open $name w]
 342                 setFileEncoding $f $encoding
 343                 puts -nonewline $f $data
 344                 close $f
 345         }
 346         proc setFileEncoding {f encoding} {
 347                 if {[string length $encoding]} {
 348                         if {"$encoding" == "binary"} {
 349                                 fconfigure $f -translation binary
 350                         } else {
 351                                 fconfigure $f -encoding $encoding
 352                         }
 353                 }
 354         }
 355 #
 356 # Возвращает содeржимое файла
 357 #
 358
 359 proc getFile {filename {encoding {}}} {
 360         set f [open $filename]
 361         setFileEncoding $f $encoding
 362         set data [read $f]
 363         close $f
 364         return $data
 365 }
 366 #
 367 # Возвращает содержимое бинарного файла. Для совместимости со старыми
 368 # тестами
 369 #
 370 proc getfile {filename} {
 371         return [getFile $filename binary]
 372 }
 373         #
 374         # Зачитывает указанный файл, удаляет его и возвращает содержимое.
 375         # По умолчанию читает файл в текущей системной кодировке. Можно
 376         # указать кодировку явно вторым аргументом.
 377         #
 378
 379         proc readAndDel {name {encoding {}}} {
 380                 set f [open $name]
 381                 setFileEncoding $f $encoding
 382                 set data [read $f]
 383                 close $f
 384                 file delete $name
 385                 return $data
 386         }
 387
 388
 389         #
 390         # Защищает файл от записи средствами операционной системы
 391         # denywrite filename ?boolean?
 392         # Если boolean не указан, или он true, файл становится read-only
 393         # Если указан - readwrite (для владельца. Впрочем для не-владельца все
 394         # равно не сработает)
 395         #
 396         proc denyWrite {filename {deny 1}} {
 397                 global tcl_platform
 398                 if {$tcl_platform(platform) == "unix"} {
 399                         set cur_attr [file attributes $filename -permissions]
 400                         if {$deny} {
 401                                 set new_attr [expr {$cur_attr &~ 0200}]
 402                         } else {
 403                                 set new_attr [expr {$cur_attr | 0200}]
 404                         }
 405                         file attributes $filename -permissions $new_attr
 406                 } else {
 407                         file attributes $filename -readonly $deny
 408                 }
 409         }
 410         #
 411         # Записывает в лог 16-ричный дамп указанной переменной
 412         #
 413
 414         proc hexdump {data } {
 415                 while {[string length $data]} {
 416                         set block [string range $data 0 15]
 417                         set data [string replace $data 0 15]
 418                         binary scan [encoding convertto $block] c* list
 419                         set line ""
 420                         set i 0
 421                         foreach code $list {
 422                                 append line [format "%02x " [expr $code>=0?$code:$code +256]]
 423                                 if {[incr i]%4==0} {
 424                                         append line "| "
 425                                 }
 426                         }
 427                         append line [string repeat " " [expr 56-[string length $line]]]
 428                         regsub -all "\[\0-\37\]" $block . printable
 429                         append line [rus $printable]
 430                         log $line
 431                 }
 432         }
 433         namespace export test start_tests end_tests test_log rus log\
 434         makeFile readAndDel hexdump denyWrite getFile getfile
 435 }
 436 namespace import ::test::*
 437
 438 package provide test 0.2