]> wagner.pp.ru Git - openssl-gost/engine.git/blob - tcl_tests/test.tcl
gost_crypt: Add magma_ctr_acpkm_omac_cipher
[openssl-gost/engine.git] / 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