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 {($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"]))} {
 206                         logend "failed"
 207                         if {$status == 1} {
 208                                 set expectedResult [rus $expectedResult]
 209                         }
 210                         log   "Code:----$code---------------"
 211                         log     "Expected status $exitStatus got $status"
 212                         log   "Expected result: [list $expectedResult]"
 213                         log     "     Got result: [list $result]"
 214                         if {$status == 1} {
 215                                 log "errorCode = $::errorCode"
 216                         }
 217                 } else {
 218                         logend "ok"
 219                 }
 220         }
 221 #
 222 # Внутренние (неэкспортируемые)процедуры
 223 #
 224 #
 225
 226 #
 227 # Сравнение списков с учетом того что некоторые элементы могут быть
 228 # метками времени, которые проверяются с точностью +-секунда
 229 # Параметр time - список, каждый элемент которого является индексом
 230 # элемента в списке, либо списком индексов во вложенных списках
 231 #
 232 proc listcompare {list1 list2 time} {
 233         foreach e $time {
 234                 if {[llength $e]>1} {
 235                         lappend a([lindex $e 0]) [lrange $e 1 end]
 236                 } else {
 237                         set a($e) {}
 238                 }
 239         }
 240         if {[llength $list1] !=[llength $list2]} {
 241                 return 0
 242         }
 243         set i 0
 244         foreach e1 $list1 e2 $list2 {
 245                 if {![info exists a($i)]} {
 246                         if {[string compare $e1 $e2]!=0} {
 247                                 return 0
 248                         }
 249                 } elseif {[llength $a($i)]} {
 250                         if {![listcompare $e1 $e2 $a($i)]} {
 251                                 return 0
 252                         }
 253                 } else {
 254                         if {$e2 == "::test::timestamp"} {
 255                                 set e2 $::test::timestamp
 256                         }
 257                         if {[regexp {^([[:digit:]]+)\+([[:digit:]]+)$} $e2 m start delta]} {
 258                                 if {$e1<$start || $e1 >$start+$delta} {
 259                                         return 0
 260                                 }
 261                         } elseif {abs($e1-$e2)>1} {
 262                                 return 0
 263                         }
 264                 }
 265                 incr i
 266         }
 267         return 1
 268 }
 269 proc rus {string} {
 270         return $string
 271 }
 272    #
 273    # Пишет строку в лог
 274    #
 275    proc log {message} {
 276                 variable logchannel
 277                 puts $logchannel $message
 278         }
 279         #
 280         # Вызывается при начале теста
 281         #
 282         proc logbegin {testname} {
 283                 variable no
 284                 variable curtest
 285                 incr no
 286                 puts -nonewline [rus [format "Тест%5d: %-60s:" $no [string range $testname 0 59]]]
 287                 flush stdout
 288                 set curtest $testname
 289                 log [rus "\n\nТест $no: $testname start"]
 290         }
 291         #
 292         # Вызывается при пропуске теста
 293         #
 294         proc logskip {testname reason} {
 295                 variable no
 296                 variable p_skip
 297                 variable c_skip
 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]"
 301                 incr no
 302                 if {$reason == "platform"} {
 303                         incr p_skip
 304                 } else {
 305                         incr c_skip
 306                 }
 307         }
 308
 309         #
 310         # Вызывается при игнорировании теста
 311         #
 312         proc logmiss {testname reason} {
 313                 variable no
 314                 variable c_skip
 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]"
 318                 incr no
 319                 incr c_skip
 320         }
 321
 322         #
 323         # Вызывается конце теста и с параметром ok или failed
 324         #
 325         proc logend {status} {
 326                 variable no
 327                 variable curtest
 328                 variable $status
 329                 incr $status
 330                 puts $status
 331                 log [rus "Тест $no: $curtest ends $status"]
 332         }
 333
 334         #####################################################################
 335         # Вспомогательные процедуры, не специфичные для тестируемого
 336         # приложения
 337         #####################################################################
 338
 339         #
 340         # Записывает  данные из data в файл name. По умолчанию пишет в
 341         # текущей системной кодировке. Можно указать кодировку явно третьим
 342         # аргументом
 343         #
 344         proc makeFile {name data {encoding {}}} {
 345                 set f [open $name w]
 346                 setFileEncoding $f $encoding
 347                 puts -nonewline $f $data
 348                 close $f
 349         }
 350         proc setFileEncoding {f encoding} {
 351                 if {[string length $encoding]} {
 352                         if {"$encoding" == "binary"} {
 353                                 fconfigure $f -translation binary
 354                         } else {
 355                                 fconfigure $f -encoding $encoding
 356                         }
 357                 }
 358         }
 359 #
 360 # Возвращает содeржимое файла
 361 #
 362
 363 proc getFile {filename {encoding {}}} {
 364         set f [open $filename]
 365         setFileEncoding $f $encoding
 366         set data [read $f]
 367         close $f
 368         return $data
 369 }
 370 #
 371 # Возвращает содержимое бинарного файла. Для совместимости со старыми
 372 # тестами
 373 #
 374 proc getfile {filename} {
 375         return [getFile $filename binary]
 376 }
 377         #
 378         # Зачитывает указанный файл, удаляет его и возвращает содержимое.
 379         # По умолчанию читает файл в текущей системной кодировке. Можно
 380         # указать кодировку явно вторым аргументом.
 381         #
 382
 383         proc readAndDel {name {encoding {}}} {
 384                 set f [open $name]
 385                 setFileEncoding $f $encoding
 386                 set data [read $f]
 387                 close $f
 388                 file delete $name
 389                 return $data
 390         }
 391
 392
 393         #
 394         # Защищает файл от записи средствами операционной системы
 395         # denywrite filename ?boolean?
 396         # Если boolean не указан, или он true, файл становится read-only
 397         # Если указан - readwrite (для владельца. Впрочем для не-владельца все
 398         # равно не сработает)
 399         #
 400         proc denyWrite {filename {deny 1}} {
 401                 global tcl_platform
 402                 if {$tcl_platform(platform) == "unix"} {
 403                         set cur_attr [file attributes $filename -permissions]
 404                         if {$deny} {
 405                                 set new_attr [expr {$cur_attr &~ 0200}]
 406                         } else {
 407                                 set new_attr [expr {$cur_attr | 0200}]
 408                         }
 409                         file attributes $filename -permissions $new_attr
 410                 } else {
 411                         file attributes $filename -readonly $deny
 412                 }
 413         }
 414         #
 415         # Записывает в лог 16-ричный дамп указанной переменной
 416         #
 417
 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
 423                         set line ""
 424                         set i 0
 425                         foreach code $list {
 426                                 append line [format "%02x " [expr $code>=0?$code:$code +256]]
 427                                 if {[incr i]%4==0} {
 428                                         append line "| "
 429                                 }
 430                         }
 431                         append line [string repeat " " [expr 56-[string length $line]]]
 432                         regsub -all "\[\0-\37\]" $block . printable
 433                         append line [rus $printable]
 434                         log $line
 435                 }
 436         }
 437         namespace export test start_tests end_tests test_log rus log\
 438         makeFile readAndDel hexdump denyWrite getFile getfile
 439 }
 440 namespace import ::test::*
 441
 442 package provide test 0.2