/ Check-in [ec9c4f6d]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Further tweaks to wapptest.tcl. Add the ability to run the extra (n)debug tests that releasetest.tcl runs.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | wapptest
Files: files | file ages | folders
SHA3-256: ec9c4f6d8da25dcc834812c2bb24bda1017833b1c572bdbbf87f0191e1310706
User & Date: dan 2019-04-11 19:03:15
Context
2019-04-11
19:04
Merge trunk changes into this branch. Closed-Leaf check-in: d805fc0c user: dan tags: wapptest
19:03
Further tweaks to wapptest.tcl. Add the ability to run the extra (n)debug tests that releasetest.tcl runs. check-in: ec9c4f6d user: dan tags: wapptest
06:50
Fix the checksymbols target in Makefile.in. check-in: 1956eb34 user: dan tags: wapptest
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to test/releasetest_data.tcl.

   383    383       lappend opts -DSQLITE_OS_WIN=1
   384    384     } else {
   385    385       lappend opts -DSQLITE_OS_UNIX=1
   386    386     }
   387    387   
   388    388     # Set the sub-directory to use.
   389    389     #
   390         -  set dir [string tolower [string map {- _ " " _} $name]]
          390  +  set dir [string tolower [string map {- _ " " _ "(" _ ")" _} $name]]
   391    391   
   392    392     # Join option lists into strings, using space as delimiter.
   393    393     #
   394    394     set makeOpts [join $makeOpts " "]
   395    395     set cflags   [join $cflags " "]
   396    396     set opts     [join $opts " "]
   397    397   

Changes to test/wapptest.tcl.

     1         -#!/bin/sh 
            1  +#!/bin/sh
     2      2   # \
     3      3   exec wapptclsh "$0" ${1+"$@"}
     4      4   
     5      5   # package required wapp
     6      6   source [file join [file dirname [info script]] wapp.tcl]
     7      7   
     8      8   # Read the data from the releasetest_data.tcl script.
................................................................................
    18     18   #   G(tcl)      - Use Tcl from this directory for builds.
    19     19   #   G(jobs)     - How many sub-processes to run simultaneously.
    20     20   #
    21     21   set G(platform) $::tcl_platform(os)-$::tcl_platform(machine)
    22     22   set G(test)     Normal
    23     23   set G(keep)     0
    24     24   set G(msvc)     0
    25         -set G(tcl)      ""
           25  +set G(tcl)      [::tcl::pkgconfig get libdir,install]
    26     26   set G(jobs)     3
           27  +set G(debug)    0
    27     28   
    28     29   proc wapptest_init {} {
    29     30     global G
    30     31   
    31         -  set lSave [list platform test keep msvc tcl jobs] 
           32  +  set lSave [list platform test keep msvc tcl jobs debug] 
    32     33     foreach k $lSave { set A($k) $G($k) }
    33     34     array unset G
    34     35     foreach k $lSave { set G($k) $A($k) }
    35     36   
    36     37     # The root of the SQLite source tree.
    37     38     set G(srcdir)   [file dirname [file dirname [info script]]]
    38     39   
................................................................................
    40     41     set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
    41     42   
    42     43     set G(sqlite_version) "unknown"
    43     44   
    44     45     # Either "config", "running" or "stopped":
    45     46     set G(state) "config"
    46     47   
    47         -  set G(host) "(unknown host)"
    48         -  catch { set G(host) [exec hostname] } 
           48  +  set G(hostname) "(unknown host)"
           49  +  catch { set G(hostname) [exec hostname] } 
           50  +  set G(host) $G(hostname)
    49     51     append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)"
    50     52     append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)"
    51     53   }
    52     54   
    53     55   # Check to see if there are uncommitted changes in the SQLite source
    54     56   # directory. Return true if there are, or false otherwise.
    55     57   #
................................................................................
    60     62     cd $G(srcdir)
    61     63     if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} {
    62     64       set ret 1
    63     65     }
    64     66     cd $pwd
    65     67     return $ret
    66     68   }
           69  +
           70  +proc generate_fossil_info {} {
           71  +  global G
           72  +  set pwd [pwd]
           73  +  cd $G(srcdir)
           74  +  if {[catch {exec fossil info}    r1]} return
           75  +  if {[catch {exec fossil changes} r2]} return
           76  +  cd $pwd
           77  +
           78  +  foreach line [split $r1 "\n"] {
           79  +    if {[regexp {^checkout: *(.*)$} $line -> co]} {
           80  +      wapp-trim { <br> %html($co) }
           81  +    }
           82  +  }
           83  +
           84  +  if {[string trim $r2]!=""} {
           85  +    wapp-trim { 
           86  +      <br><span class=warning> 
           87  +      WARNING: Uncommitted changes in checkout
           88  +      </span>
           89  +    }
           90  +  }
           91  +}
    67     92   
    68     93   # If the application is in "config" state, set the contents of the 
    69     94   # ::G(test_array) global to reflect the tests that will be run. If the
    70     95   # app is in some other state ("running" or "stopped"), this command
    71     96   # is a no-op.
    72     97   #
    73     98   proc set_test_array {} {
................................................................................
    98    123                 set target testfixture.exe
    99    124               }
   100    125             }
   101    126           }
   102    127         }
   103    128   
   104    129         lappend G(test_array) [dict create config $config target $target]
          130  +
          131  +      set exclude [list checksymbols valgrindtest fuzzoomtest]
          132  +      if {$G(debug) && !($target in $exclude)} {
          133  +        set debug_idx [lsearch -glob $::Configs($config) -DSQLITE_DEBUG*]
          134  +        set xtarget $target
          135  +        regsub -all {fulltest[a-z]*} $xtarget test xtarget
          136  +        if {$debug_idx<0} {
          137  +          lappend G(test_array) [
          138  +            dict create config $config-(Debug) target $target
          139  +          ]
          140  +        } else {
          141  +          lappend G(test_array) [
          142  +            dict create config $config-(NDebug) target $xtarget
          143  +          ]
          144  +        }
          145  +      }
   105    146       }
   106    147     }
   107    148   }
   108    149   
   109    150   proc count_tests_and_errors {name logfile} {
   110    151     global G
   111    152   
................................................................................
   238    279           set G(test.$name.start) [clock seconds]
   239    280           set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+]
   240    281           set G(test.$name.channel) $fd
   241    282           fconfigure $fd -blocking 0
   242    283           fileevent $fd readable [list slave_fileevent $name]
   243    284   
   244    285           puts $fd [list 0 $G(msvc) 0 $G(keep)]
   245         -        set L [make_test_suite $G(msvc) "" $name $target $::Configs($name)]
          286  +
          287  +        set wtcl ""
          288  +        if {$G(tcl)!=""} { set wtcl "--with-tcl=$G(tcl)" }
          289  +
          290  +        # If this configuration is named <name>-(Debug) or <name>-(NDebug),
          291  +        # then add or remove the SQLITE_DEBUG option from the base
          292  +        # configuration before running the test.
          293  +        if {[regexp -- {(.*)-(\(.*\))} $name -> head tail]} {
          294  +          set opts $::Configs($head)
          295  +          if {$tail=="(Debug)"} {
          296  +            append opts " -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1"
          297  +          } else {
          298  +            regsub { *-DSQLITE_MEMDEBUG[^ ]* *} $opts { } opts
          299  +            regsub { *-DSQLITE_DEBUG[^ ]* *} $opts { } opts
          300  +          }
          301  +        } else {
          302  +          set opts $::Configs($name)
          303  +        }
          304  +
          305  +        set L [make_test_suite $G(msvc) $wtcl $name $target $opts]
   246    306           puts $fd $L
   247    307           flush $fd
   248    308           set G(test.$name.log) [file join [lindex $L 1] test.log]
   249    309           incr nLaunch -1
   250    310         }
   251    311       }
   252    312     }
................................................................................
   265    325     wapp-trim { </select> }
   266    326   }
   267    327   
   268    328   proc generate_main_page {{extra {}}} {
   269    329     global G
   270    330     set_test_array
   271    331   
   272         -  # <meta http-equiv="refresh" content="5; URL=/">
          332  +  set hostname $G(hostname)
   273    333     wapp-trim {
   274    334       <html>
   275    335       <head>
          336  +      <title> %html($hostname): wapptest.tcl </title>
   276    337         <link rel="stylesheet" type="text/css" href="style.css"/>
   277    338       </head>
   278    339       <body>
   279    340     }
   280    341   
   281         -  # If the checkout contains uncommitted changs, put a warning at the top
   282         -  # of the page.
   283         -  if {[check_uncommitted]} {
   284         -    wapp-trim {
   285         -      <div class=warning>
   286         -        WARNING: Uncommitted changes in checkout.
   287         -      </div>
   288         -    }
   289         -  }
   290         -
   291    342     set host $G(host)
   292    343     wapp-trim {
   293         -      <div class=div>%string($host)</div>
   294         -      <div class=div id=controls> 
   295         -      <form action="control" method="post" name="control">
          344  +    <div class="border">%string($host)
          345  +  }
          346  +  generate_fossil_info
          347  +  wapp-trim {
          348  +    </div>
          349  +    <div class="border" id=controls> 
          350  +    <form action="control" method="post" name="control">
   296    351     }
   297    352   
   298    353     # Build the "platform" select widget. 
   299    354     set lOpt [array names ::Platforms]
   300    355     generate_select_widget Platform control_platform $lOpt $G(platform)
   301    356   
   302    357     # Build the "test" select widget. 
................................................................................
   332    387           <label> Tcl: </label>
   333    388           <input id="control_tcl" name="control_tcl"></input>
   334    389           <label> Keep files: </label>
   335    390           <input id="control_keep" name="control_keep" type=checkbox value=1>
   336    391           </input>
   337    392           <label> Use MSVC: </label>
   338    393           <input id="control_msvc" name="control_msvc" type=checkbox value=1>
          394  +        <label> Debug tests: </label>
          395  +        <input id="control_debug" name="control_debug" type=checkbox value=1>
   339    396           </input>
   340    397     }
   341    398     wapp-trim {
   342    399        </form>
   343    400     }
   344    401     wapp-trim {
   345    402        </div>
   346         -     <div class=div2 id=tests>
          403  +     <div id=tests>
   347    404     }
   348    405     wapp-page-tests
   349    406   
   350    407     set script "script/$G(state).js"
   351    408     wapp-trim {
   352    409       </div>
   353    410         <script src=%string($script)></script>
................................................................................
   358    415   
   359    416   proc wapp-default {} {
   360    417     generate_main_page
   361    418   }
   362    419   
   363    420   proc wapp-page-tests {} {
   364    421     global G
   365         -  wapp-trim { <table> }
          422  +  wapp-trim { <table class="border" width=100%> }
   366    423     foreach t $G(test_array) {
   367    424       set config [dict get $t config]
   368    425       set target [dict get $t target]
   369    426   
   370    427       set class "testwait"
   371    428       set seconds ""
   372    429   
................................................................................
   387    444         set  hr [format %.2d [expr $seconds / 3600]]
   388    445         set sec [format %.2d [expr $seconds % 60]]
   389    446         set seconds "$hr:$min:$sec"
   390    447       }
   391    448   
   392    449       wapp-trim {
   393    450         <tr class=%string($class)>
   394         -      <td class=testfield> %html($config) 
   395         -      <td class=testfield> %html($target)
   396         -      <td class=testfield> %html($seconds)
   397         -      <td class=testfield>
          451  +      <td class="nowrap"> %html($config) 
          452  +      <td class="padleft nowrap"> %html($target)
          453  +      <td class="padleft nowrap"> %html($seconds)
          454  +      <td class="padleft nowrap">
   398    455       }
   399    456       if {[info exists G(test.$config.log)]} {
   400    457         set log $G(test.$config.log)
   401    458         set uri "log/$log"
   402    459         wapp-trim {
   403    460           <a href=%url($uri)> %html($log) </a>
   404    461         }
   405    462       }
   406    463       if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} {
   407    464         set errmsg $G(test.$config.errmsg)
   408    465         wapp-trim {
   409    466           <tr class=testfail>
   410         -        <td class=testfield>
   411         -        <td class=testfield colspan=3> %html($errmsg)
          467  +        <td> <td class="padleft" colspan=3> %html($errmsg)
   412    468         }
   413    469       }
   414    470     }
   415    471   
   416    472     wapp-trim { </table> }
   417    473   
   418    474     if {[info exists G(result)]} {
................................................................................
   426    482   # URI: /control
   427    483   #
   428    484   # Whenever the form at the top of the application page is submitted, it
   429    485   # is submitted here.
   430    486   #
   431    487   proc wapp-page-control {} {
   432    488     global G
   433         -  catch { puts [wapp-param control_msvc] }
   434    489     if {$::G(state)=="config"} {
   435         -    set lControls [list platform test tcl jobs keep msvc]
          490  +    set lControls [list platform test tcl jobs keep msvc debug]
   436    491       set G(msvc) 0
   437    492       set G(keep) 0
          493  +    set G(debug) 0
   438    494     } else {
   439    495       set lControls [list jobs]
   440    496     }
   441    497     foreach v $lControls {
   442    498       if {[wapp-param-exists control_$v]} {
   443    499         set G($v) [wapp-param control_$v]
   444    500       }
................................................................................
   478    534   
   479    535   # URI: /style.css
   480    536   #
   481    537   # Return the stylesheet for the application main page.
   482    538   #
   483    539   proc wapp-page-style.css {} {
   484    540     wapp-subst {
   485         -    .div {
   486         -      border: 3px groove #444444;
   487         -      margin: 1em;
   488         -      padding: 1em;
   489         -    }
   490    541   
          542  +    /* The boxes with black borders use this class */
   491    543       .border {
   492    544         border: 3px groove #444444;
   493    545         padding: 1em;
   494    546         margin-top: 1em;
   495    547         margin-bottom: 1em;
   496    548       }
   497    549   
   498         -    .div2 {
   499         -      margin: 1em;
   500         -    }
          550  +    /* Float to the right (used for the Run/Stop/Reset button) */
          551  +    .right { float: right; }
   501    552   
   502         -    table {
   503         -      padding: 1em;
   504         -      width:100%;
   505         -      border: 3px groove #444444;
   506         -    }
   507         -
          553  +    /* Style for the large red warning at the top of the page */
   508    554       .warning {
   509         -      text-align:center;
   510    555         color: red;
   511         -      font-size: 2em;
   512    556         font-weight: bold;
   513    557       }
   514    558   
   515         -    .testfield {
   516         -      padding-right: 10ex;
   517         -      white-space: nowrap;
   518         -    }
          559  +    /* Styles used by cells in the test table */
          560  +    .padleft { padding-left: 5ex; }
          561  +    .nowrap  { white-space: nowrap; }
   519    562   
   520         -    .testwait {}
   521         -    .testrunning { color: blue }
   522         -    .testdone { color: green }
   523         -    .testfail { color: red }
   524         -
   525         -    .right { float: right; }
   526         -
          563  +    /* Styles for individual tests, depending on the outcome */
          564  +    .testwait    {              }
          565  +    .testrunning { color: blue  }
          566  +    .testdone    { color: green }
          567  +    .testfail    { color: red   }
   527    568     }
   528    569   }
   529    570   
   530    571   # URI: /script/${state}.js
   531    572   #
   532    573   # The last part of this URI is always "config.js", "running.js" or 
   533    574   # "stopped.js", depending on the state of the application. It returns
................................................................................
   536    577   #
   537    578   proc wapp-page-script {} {
   538    579     regexp {[^/]*$} [wapp-param REQUEST_URI] script
   539    580   
   540    581     set tcl $::G(tcl)
   541    582     set keep $::G(keep)
   542    583     set msvc $::G(msvc)
          584  +  set debug $::G(debug)
   543    585     
   544    586     wapp-subst {
   545    587       var lElem = \["control_platform", "control_test", "control_msvc", 
   546         -        "control_jobs"
          588  +        "control_jobs", "control_debug"
   547    589       \];
   548    590       lElem.forEach(function(e) {
   549    591         var elem = document.getElementById(e);
   550    592         elem.addEventListener("change", function() { control.submit() } );
   551    593       })
   552    594   
   553    595       elem = document.getElementById("control_tcl");
................................................................................
   554    596       elem.value = "%string($tcl)"
   555    597   
   556    598       elem = document.getElementById("control_keep");
   557    599       elem.checked = %string($keep);
   558    600   
   559    601       elem = document.getElementById("control_msvc");
   560    602       elem.checked = %string($msvc);
          603  +
          604  +    elem = document.getElementById("control_debug");
          605  +    elem.checked = %string($debug);
   561    606     }
   562    607   
   563    608     if {$script != "config.js"} {
   564    609       wapp-subst {
   565    610         var lElem = \["control_platform", "control_test", 
   566    611             "control_tcl", "control_keep", "control_msvc"
   567    612         \];