home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #31 / NN_1992_31.iso / spool / comp / lang / tcl / 2257 < prev    next >
Encoding:
Text File  |  1992-12-28  |  4.1 KB  |  124 lines
  1. Newsgroups: comp.lang.tcl
  2. Path: sparky!uunet!walter!thumper!tjj
  3. From: tjj@thumper..bellcore.com (J Tim Jordan)
  4. Subject: Regression test recorder now broken
  5. Message-ID: <1992Dec28.170527.11315@walter.bellcore.com>
  6. Sender: news@walter.bellcore.com
  7. Nntp-Posting-Host: thumper.bellcore.com
  8. Reply-To: tjj@nomas.bellcore.com (J Tim Jordan)
  9. Organization: Bellcore MRE
  10. Date: Mon, 28 Dec 92 17:05:27 GMT
  11. Lines: 111
  12.  
  13. In version tk1.4 I had written a couple of simple tcl procedures to 
  14. tk so that as I used any tk application my actions would be recorded
  15. in such a way that the replaying of my actions could be done by simply
  16. sourcing a file. I used this to generate regression tests. But when
  17. I left 1.4 and went to 2.3, I started getting the error:
  18.  
  19. can't read "tk_priv(relief)": no such element in array
  20.  
  21. This is how I built the recording of a button: 
  22. ($RFH points to a file which holds the output which can be replayed)
  23.  
  24.     rename button button.old
  25.     proc button {w args} {
  26.         eval button.old $w $args
  27.         bind $w <Button-1> "+global RFH; puts \$RFH {{$w invoke}}; flush \$RFH"
  28.     }
  29.  
  30. I changed this to test my hypothesis of the problem to:
  31.  
  32.     rename button button.old
  33.     proc button {w args} {
  34.         eval button.old $w $args
  35.         bind $w <Button-1> "puts stdout got_here"
  36.     }
  37.  
  38. and still got the error message. This use to be a very 
  39. easy way of generating regression tests by simply having the 
  40. user recreate the problem for me, record the steps and then
  41. after the fix, rerun the test with the good data and simply 
  42. add this to the stack of tests run nightly or a 
  43. release time. As a work around I could go into all my
  44. tcl code (which is a lot) and change button to button.regon
  45. but there is no automatic way of doing this. Plus I use
  46. to be able to run regression test on production code
  47. with out worrying that I can be adding bugs to it. I really 
  48. hate to loose my regression testing system. Does anybody 
  49. know of any solutions?
  50.  
  51. Tim 
  52.  
  53. Here is the entire code which composed my regression testing.
  54. To rerun a test I simply did a foreach loop on the output
  55. and sent it to the application being tested with a small sleep
  56. in the loop.
  57.  
  58. proc eos_init {} {
  59.     global env
  60.     set tt [catch {set env(EOS_RECORD)}]
  61.     if {$tt == 0} {
  62.     set rec [set env(EOS_RECORD)]
  63.     if { $rec == "on" } {
  64.     global RFH
  65.     set time [exec date {+%y%m%d%H%M}]
  66.     set fn REG/rec.$time
  67.     set RFH [open $fn w+]
  68.     puts $RFH {{global DIFF; set DIFF [open DIFF w+]}}
  69.     bind . <Shift-Button-3> "puts $RFH {{#FINISHED}}"
  70.     set resfn REG/res.$time
  71.     global DIFF; set DIFF [open $resfn w+]
  72.     proc bind.new {w args} {
  73.         global RFH
  74.         eval bind.old $w $args
  75.         if { [llength $args] > 1} {
  76.             set seq [lindex $args 0]
  77.             set cmd [lindex $args 1]
  78.             bind.old $w $seq "+global RFH; puts $RFH {{$cmd}} ; flush $RFH"
  79.         }
  80.     }
  81.     rename bind bind.old
  82.     rename bind.new bind
  83.     proc radiobutton.new {w args} {
  84.         eval radiobutton.old $w $args
  85.         bind.old $w <Button-1> "+global RFH; puts \$RFH {{$w invoke}}; flush \$RFH"
  86.     }
  87.     rename radiobutton radiobutton.old
  88.     rename radiobutton.new radiobutton
  89.     rename button button.old
  90.     proc button {w args} {
  91.         eval button.old $w $args
  92. #        bind.old $w <Button-1> "+global RFH; puts \$RFH {{$w invoke}}; flush \$RFH"
  93.         bind.old $w <Button-1> "puts stdout got_here"
  94.     }
  95.     proc listbox.new {w args} {
  96.         eval listbox.oldd $w $args
  97.         bind.old $w <Shift-Button-2> "+global RFH; puts \$RFH {{puts \$DIFF \"\[listall $w \]\" ; flush \$DIFF}}; flush \$RFH;  puts \$DIFF \"\[listall $w \]\"; flush \$DIFF"
  98.         set cmda [lindex [$w config -yscrollcommand] 4]
  99.         set cmd [lindex $cmda 0]
  100.         if {[string compare [info command $cmd] {}] == {} } {
  101.             puts stderr "ERROR: The command \"$cmd\"
  102.             does not exist yet."
  103.             coredump
  104.         } 
  105.         while {[set cmdc [info cmdcount]; catch "rename $cmd $cmd.$cmdc" ] != 0} {}
  106.         eval "proc $cmd {args} {
  107.             global RFH
  108.             eval $cmd.$cmdc \$args
  109.             puts \$RFH \"{$w view \[lindex \$args 3\]}\"
  110.             flush \$RFH
  111.         }"
  112.     }
  113.     rename listbox listbox.oldd
  114.     rename listbox.new listbox
  115.     proc entry.new {w args} {
  116.         eval entry.old $w $args
  117.         bind.old $w <Shift-Button-2> "+global RFH; puts \$RFH {{puts \$DIFF \"\[$w get \]\" ; flush \$DIFF}}; flush \$RFH;  puts \$DIFF \"\[$w get \]\"; flush \$DIFF"
  118.     }
  119.     rename entry entry.old
  120.     rename entry.new entry
  121.     } }
  122. }
  123.  
  124.