tcl_tests/test.tcl

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