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                         # signal to a caller that we had failures
 122                         exit 1
 123                 }
 124         }
 125    #
 126    # Вовзращает идентификатор канала, куда пишется лог тестов.
 127    # Рекомендуется назначать его в качестве -logchannel создаваемым
 128    # контекстам чтобы вся выдача была в одном месте
 129    #
 130    proc test_log {} {
 131                 variable logchannel
 132                 return $logchannel
 133         }
 134         #
 135         # Собственно тест
 136         #   Параметры
 137         #   1. Название теста
 138         #   2. Код (рекомендуется писать {
 139         #       код
 140         #     }
 141         #   3. Ожидаемый результат выполнения - 0 успешно 1 - ошибка. Варианты
 142         #     больше 1 (TCL_BREAK, TCL_CONTINUE и TCL_RETURN) возможны, но вряд
 143         #     ли интересны
 144         #   4. Ожидаемый возвращаемый результат
 145         #      Если предыдущий параметр 0, результат сравнивается на точное
 146         #      совпадение, если 1 - результат - регексп, которому должно
 147         #      удовлетворять сообщение об ошибке.
 148         proc test args {
 149                 array set opts {}
 150                 variable tempfiles
 151                 variable timestamp
 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]
 156                         set opts($key) $val
 157                 }
 158             foreach {message code exitStatus expectedResult} $args break
 159                 global errorInfo
 160                 if {[info exists opts(-platform)] && [lsearch -exact $opts(-platform) $::tcl_platform(platform)]==-1} {
 161                         logskip $message "platform"
 162                         return
 163                 }
 164                 if {[info exists opts(-platformex)] && ![uplevel expr $opts(-platformex)]} {
 165                         logskip $message "platform"
 166                         return
 167                 }
 168                 if {[info exists opts(-skip)] && [uplevel expr $opts(-skip)]} {
 169                         logskip $message "prereq"
 170                         return
 171                 }
 172                 if {[info exists opts(-fixme)] && [uplevel expr $opts(-fixme)]} {
 173                         logmiss $message "FIXME"
 174                         return
 175                 }
 176                 if {[info exists opts(-createsfiles)]} {
 177                         foreach file $opts(-createsfiles) {
 178                                 lappend tempfiles $file
 179                                 if {[file exists $file]} {file delete $file}
 180                         }
 181                 }
 182                 if {[info exists opts(-createsvars)]} {
 183                         foreach var $opts(-createsvars) {
 184                                 uplevel  "if {\[info exists $var\]} {unset $var}"
 185                         }
 186                 }
 187                 logbegin $message
 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
 193                 } else {
 194                         # Handle negative intervals correctly
 195                         if {$teststart > $testend} {
 196                                 set timestamp "$testend+[expr $teststart-$testend]"
 197                         } else {
 198                                 set timestamp "$teststart+[expr $testend-$teststart]"
 199                         }
 200                 }
 201                 if {$status!=$exitStatus || ($status==1?![regexp --\
 202                         [rus $expectedResult] $result]:([info exists opts(-time)]?\
 203                     ![listcompare $result $expectedResult $opts(-time)]:\
 204                         [string compare "$result" "$expectedResult"]))} {
 205                         logend "failed"
 206                         if {$status == 1} {
 207                                 set expectedResult [rus $expectedResult]
 208                         }
 209                         log   "Code:----$code---------------"
 210                         log     "Expected status $exitStatus got $status"
 211                         log   "Expected result: [list $expectedResult]"
 212                         log     "     Got result: [list $result]"
 213                         if {$status == 1} {
 214                                 log "errorCode = $::errorCode"
 215                         }
 216                 } else {
 217                         logend "ok"
 218                 }
 219         }
 220 #
 221 # Внутренние (неэкспортируемые)процедуры
 222 #
 223 #
 224
 225 #
 226 # Сравнение списков с учетом того что некоторые элементы могут быть
 227 # метками времени, которые проверяются с точностью +-секунда
 228 # Параметр time - список, каждый элемент которого является индексом
 229 # элемента в списке, либо списком индексов во вложенных списках
 230 #
 231 proc listcompare {list1 list2 time} {
 232         foreach e $time {
 233                 if {[llength $e]>1} {
 234                         lappend a([lindex $e 0]) [lrange $e 1 end]
 235                 } else {
 236                         set a($e) {}
 237                 }
 238         }
 239         if {[llength $list1] !=[llength $list2]} {
 240                 return 0
 241         }
 242         set i 0
 243         foreach e1 $list1 e2 $list2 {
 244                 if {![info exists a($i)]} {
 245                         if {[string compare $e1 $e2]!=0} {
 246                                 return 0
 247                         }
 248                 } elseif {[llength $a($i)]} {
 249                         if {![listcompare $e1 $e2 $a($i)]} {
 250                                 return 0
 251                         }
 252                 } else {
 253                         if {$e2 == "::test::timestamp"} {
 254                                 set e2 $::test::timestamp
 255                         }
 256                         if {[regexp {^([[:digit:]]+)\+([[:digit:]]+)$} $e2 m start delta]} {
 257                                 if {$e1<$start || $e1 >$start+$delta} {
 258                                         return 0
 259                                 }
 260                         } elseif {abs($e1-$e2)>1} {
 261                                 return 0
 262                         }
 263                 }
 264                 incr i
 265         }
 266         return 1
 267 }
 268 proc rus {string} {
 269         return $string
 270 }
 271    #
 272    # Пишет строку в лог
 273    #
 274    proc log {message} {
 275                 variable logchannel
 276                 puts $logchannel $message
 277         }
 278         #
 279         # Вызывается при начале теста
 280         #
 281         proc logbegin {testname} {
 282                 variable no
 283                 variable curtest
 284                 incr no
 285                 puts -nonewline [rus [format "Тест%5d: %-60s:" $no [string range $testname 0 59]]]
 286                 flush stdout
 287                 set curtest $testname
 288                 log [rus "\n\nТест $no: $testname start"]
 289         }
 290         #
 291         # Вызывается при пропуске теста
 292         #
 293         proc logskip {testname reason} {
 294                 variable no
 295                 variable p_skip
 296                 variable c_skip
 297                 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]skipped "
 298                 log "[rus "Тест $no: skipped "][expr {$reason=="platform"?"on
 299                 the platform $::tcl_platform(platform)":"due to failed prerequisites"}]:[rus $testname]"
 300                 incr no
 301                 if {$reason == "platform"} {
 302                         incr p_skip
 303                 } else {
 304                         incr c_skip
 305                 }
 306         }
 307
 308         #
 309         # Вызывается при игнорировании теста
 310         #
 311         proc logmiss {testname reason} {
 312                 variable no
 313                 variable c_skip
 314                 puts "[rus [format "Тест%5d: %-60s:" $no [string rang $testname 0 59]]]missed "
 315                 log "[rus "Тест $no: missed "][expr {$reason=="platform"?"on
 316                 the platform $::tcl_platform(platform)":"by reason: $reason"}]:[rus $testname]"
 317                 incr no
 318                 incr c_skip
 319         }
 320
 321         #
 322         # Вызывается конце теста и с параметром ok или failed
 323         #
 324         proc logend {status} {
 325                 variable no
 326                 variable curtest
 327                 variable $status
 328                 incr $status
 329                 puts $status
 330                 log [rus "Тест $no: $curtest ends $status"]
 331         }
 332
 333         #####################################################################
 334         # Вспомогательные процедуры, не специфичные для тестируемого
 335         # приложения
 336         #####################################################################
 337
 338         #
 339         # Записывает  данные из data в файл name. По умолчанию пишет в
 340         # текущей системной кодировке. Можно указать кодировку явно третьим
 341         # аргументом
 342         #
 343         proc makeFile {name data {encoding {}}} {
 344                 set f [open $name w]
 345                 setFileEncoding $f $encoding
 346                 puts -nonewline $f $data
 347                 close $f
 348         }
 349         proc setFileEncoding {f encoding} {
 350                 if {[string length $encoding]} {
 351                         if {"$encoding" == "binary"} {
 352                                 fconfigure $f -translation binary
 353                         } else {
 354                                 fconfigure $f -encoding $encoding
 355                         }
 356                 }
 357         }
 358 #
 359 # Возвращает содeржимое файла
 360 #
 361
 362 proc getFile {filename {encoding {}}} {
 363         set f [open $filename]
 364         setFileEncoding $f $encoding
 365         set data [read $f]
 366         close $f
 367         return $data
 368 }
 369 #
 370 # Возвращает содержимое бинарного файла. Для совместимости со старыми
 371 # тестами
 372 #
 373 proc getfile {filename} {
 374         return [getFile $filename binary]
 375 }
 376         #
 377         # Зачитывает указанный файл, удаляет его и возвращает содержимое.
 378         # По умолчанию читает файл в текущей системной кодировке. Можно
 379         # указать кодировку явно вторым аргументом.
 380         #
 381
 382         proc readAndDel {name {encoding {}}} {
 383                 set f [open $name]
 384                 setFileEncoding $f $encoding
 385                 set data [read $f]
 386                 close $f
 387                 file delete $name
 388                 return $data
 389         }
 390
 391
 392         #
 393         # Защищает файл от записи средствами операционной системы
 394         # denywrite filename ?boolean?
 395         # Если boolean не указан, или он true, файл становится read-only
 396         # Если указан - readwrite (для владельца. Впрочем для не-владельца все
 397         # равно не сработает)
 398         #
 399         proc denyWrite {filename {deny 1}} {
 400                 global tcl_platform
 401                 if {$tcl_platform(platform) == "unix"} {
 402                         set cur_attr [file attributes $filename -permissions]
 403                         if {$deny} {
 404                                 set new_attr [expr {$cur_attr &~ 0200}]
 405                         } else {
 406                                 set new_attr [expr {$cur_attr | 0200}]
 407                         }
 408                         file attributes $filename -permissions $new_attr
 409                 } else {
 410                         file attributes $filename -readonly $deny
 411                 }
 412         }
 413         #
 414         # Записывает в лог 16-ричный дамп указанной переменной
 415         #
 416
 417         proc hexdump {data } {
 418                 while {[string length $data]} {
 419                         set block [string range $data 0 15]
 420                         set data [string replace $data 0 15]
 421                         binary scan [encoding convertto $block] c* list
 422                         set line ""
 423                         set i 0
 424                         foreach code $list {
 425                                 append line [format "%02x " [expr $code>=0?$code:$code +256]]
 426                                 if {[incr i]%4==0} {
 427                                         append line "| "
 428                                 }
 429                         }
 430                         append line [string repeat " " [expr 56-[string length $line]]]
 431                         regsub -all "\[\0-\37\]" $block . printable
 432                         append line [rus $printable]
 433                         log $line
 434                 }
 435         }
 436         namespace export test start_tests end_tests test_log rus log\
 437         makeFile readAndDel hexdump denyWrite getFile getfile
 438 }
 439 namespace import ::test::*
 440
 441 package provide test 0.2