SQLite

Check-in [07e527d781]
Login

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

Overview
Comment:Update wapptest.tcl to use a simpler slave script. And to leave scripts wapptest_configure.sh and wapptest_make.sh in each test directory.
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 07e527d781838412b2a434e64baaa49cbf7410a51c7393f54adc7b8eaffd5229
User & Date: dan 2019-04-30 20:43:10.531
Context
2019-05-01
08:48
Fix an incompatibility with auto-vacuum mode in new test script recover.test. (check-in: 36dd5b0804 user: dan tags: trunk)
2019-04-30
20:43
Update wapptest.tcl to use a simpler slave script. And to leave scripts wapptest_configure.sh and wapptest_make.sh in each test directory. (check-in: 07e527d781 user: dan tags: trunk)
15:36
Fix a problem allowing a Table object to be deleted from within a call to the xDestroy method of the associated virtual table, causing a use-after-free error. (check-in: 1dbbb0101e user: dan tags: trunk)
Changes
Unified Diff Ignore Whitespace Patch
Changes to test/wapptest.tcl.
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73

74
75

76

77
78
79
80
81
82
83
  foreach k $lSave { set A($k) $G($k) }
  array unset G
  foreach k $lSave { set G($k) $A($k) }

  # The root of the SQLite source tree.
  set G(srcdir)   [file dirname [file dirname [info script]]]

  # releasetest.tcl script
  set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]

  set G(sqlite_version) "unknown"

  # Either "config", "running" or "stopped":
  set G(state) "config"

  set G(hostname) "(unknown host)"
  catch { set G(hostname) [exec hostname] } 
  set G(host) $G(hostname)
  append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)"
  append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)"
}

# Check to see if there are uncommitted changes in the SQLite source
# directory. Return true if there are, or false otherwise.
#
proc check_uncommitted {} {
  global G
  set ret 0
  set pwd [pwd]
  cd $G(srcdir)
  if {[catch {exec fossil changes} res]==0 && [string trim $res]!=""} {
    set ret 1
  }
  cd $pwd
  return $ret
}

proc generate_fossil_info {} {
  global G
  set pwd [pwd]
  cd $G(srcdir)

  if {[catch {exec fossil info}    r1]} return
  if {[catch {exec fossil changes} r2]} return

  cd $pwd


  foreach line [split $r1 "\n"] {
    if {[regexp {^checkout: *(.*)$} $line -> co]} {
      wapp-trim { <br> %html($co) }
    }
  }








<
<
<












|
|
<
|
<
<
<
<
<
<
<
<
<
<
|




>
|
|
>

>







33
34
35
36
37
38
39



40
41
42
43
44
45
46
47
48
49
50
51
52
53

54










55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
  foreach k $lSave { set A($k) $G($k) }
  array unset G
  foreach k $lSave { set G($k) $A($k) }

  # The root of the SQLite source tree.
  set G(srcdir)   [file dirname [file dirname [info script]]]




  set G(sqlite_version) "unknown"

  # Either "config", "running" or "stopped":
  set G(state) "config"

  set G(hostname) "(unknown host)"
  catch { set G(hostname) [exec hostname] } 
  set G(host) $G(hostname)
  append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)"
  append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)"
}

# Generate the text for the box at the top of the UI. The current SQLite
# version, according to fossil, along with a warning if there are 

# uncommitted changes in the checkout.










#
proc generate_fossil_info {} {
  global G
  set pwd [pwd]
  cd $G(srcdir)
  set rc [catch {
    set r1 [exec fossil info]
    set r2 [exec fossil changes]
  }]
  cd $pwd
  if {$rc} return

  foreach line [split $r1 "\n"] {
    if {[regexp {^checkout: *(.*)$} $line -> co]} {
      wapp-trim { <br> %html($co) }
    }
  }

234
235
236
237
238
239
240


















































































241
242
243
244
245
246
247
  } else {
    set line [gets $fd]
    if {[string trim $line] != ""} { puts "Trace   : $name - \"$line\"" }
  }

  do_some_stuff
}



















































































proc do_some_stuff {} {
  global G

  # Count the number of running jobs. A running job has an entry named
  # "channel" in its dictionary.
  set nRunning 0







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
  } else {
    set line [gets $fd]
    if {[string trim $line] != ""} { puts "Trace   : $name - \"$line\"" }
  }

  do_some_stuff
}

proc wapptest_slave_script {} {
  global G
  set res {
    proc readfile {filename} {
      set fd [open $filename]
      set data [read $fd]
      close $fd
      return $data
    }
  }

  if {$G(msvc)==0} { 
    append res {
      set cfg  [readfile wapptest_configure.sh]
      set rc [catch { exec {*}$cfg >& test.log } msg]
      if {$rc==0} {
        set make [readfile wapptest_make.sh]
        catch { exec {*}$make >>& test.log }
      }
    } 
  } else { 
    append res {
      set make [readfile wapptest_make.sh]
      catch { exec {*}$make >>& test.log }
    }
  }

  set res
}


# Launch a slave process to run a test.
#
proc slave_launch {
  name wtcl title dir configOpts testtarget makeOpts cflags opts
} {
  global G

  catch { file mkdir $dir } msg
  foreach f [glob -nocomplain [file join $dir *]] {
    catch { file delete -force $f }
  }

  # Write the configure command to wapptest_configure.sh. This file
  # is empty if using MSVC - MSVC does not use configure.
  #
  set fd1 [open [file join $dir wapptest_configure.sh] w]
  if {$G(msvc)==0} {
    puts $fd1 "[file join .. $G(srcdir) configure] $wtcl $configOpts"
  }
  close $fd1

  # Write the make command to wapptest_make.sh. Using nmake for MSVC and
  # make for all other systems.
  #
  set makecmd "make"
  if {$G(msvc)} { 
    set nativedir [file nativename $G(srcdir)]
    set nativedir [string map [list "\\" "\\\\"] $nativedir]
    set makecmd "nmake /f [file join $nativedir Makefile.msc] TOP=$nativedir"
  }
  set fd2 [open [file join $dir wapptest_make.sh] w]
  puts $fd2 "$makecmd $makeOpts $testtarget \"CFLAGS=$cflags\" \"OPTS=$opts\""
  close $fd2

  # Write the wapptest_run.tcl script to the test directory. To run the
  # commands in the other two files.
  #
  set fd3 [open [file join $dir wapptest_run.tcl] w]
  puts $fd3 [wapptest_slave_script]
  close $fd3

  set pwd [pwd]
  cd $dir
  set fd [open "|[info nameofexecutable] wapptest_run.tcl" r+]
  cd $pwd

  set G(test.$name.channel) $fd
  fconfigure $fd -blocking 0
  fileevent $fd readable [list slave_fileevent $name]
}

proc do_some_stuff {} {
  global G

  # Count the number of running jobs. A running job has an entry named
  # "channel" in its dictionary.
  set nRunning 0
271
272
273
274
275
276
277

278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

306
307
308
309
310
311
312
313
314
    set nLaunch [expr $G(jobs) - $nRunning]
    foreach j $G(test_array) {
      if {$nLaunch<=0} break
      set name [dict get $j config]
      if { ![info exists G(test.$name.channel)]
        && ![info exists G(test.$name.done)]
      } {

        set target [dict get $j target]
        set G(test.$name.start) [clock seconds]
        set fd [open "|[info nameofexecutable] $G(releaseTest) --slave" r+]
        set G(test.$name.channel) $fd
        fconfigure $fd -blocking 0
        fileevent $fd readable [list slave_fileevent $name]

        puts $fd [list 0 $G(msvc) 0 $G(keep)]

        set wtcl ""
        if {$G(tcl)!=""} { set wtcl "--with-tcl=$G(tcl)" }

        # If this configuration is named <name>-(Debug) or <name>-(NDebug),
        # then add or remove the SQLITE_DEBUG option from the base
        # configuration before running the test.
        if {[regexp -- {(.*)-(\(.*\))} $name -> head tail]} {
          set opts $::Configs($head)
          if {$tail=="(Debug)"} {
            append opts " -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1"
          } else {
            regsub { *-DSQLITE_MEMDEBUG[^ ]* *} $opts { } opts
            regsub { *-DSQLITE_DEBUG[^ ]* *} $opts { } opts
          }
        } else {
          set opts $::Configs($name)
        }

        set L [make_test_suite $G(msvc) $wtcl $name $target $opts]

        puts $fd $L
        flush $fd
        set G(test.$name.log) [file join [lindex $L 1] test.log]
        incr nLaunch -1
      }
    }
  }
}








>


<
<
<
<
<
<
<



















>
|
|







342
343
344
345
346
347
348
349
350
351







352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
    set nLaunch [expr $G(jobs) - $nRunning]
    foreach j $G(test_array) {
      if {$nLaunch<=0} break
      set name [dict get $j config]
      if { ![info exists G(test.$name.channel)]
        && ![info exists G(test.$name.done)]
      } {

        set target [dict get $j target]
        set G(test.$name.start) [clock seconds]







        set wtcl ""
        if {$G(tcl)!=""} { set wtcl "--with-tcl=$G(tcl)" }

        # If this configuration is named <name>-(Debug) or <name>-(NDebug),
        # then add or remove the SQLITE_DEBUG option from the base
        # configuration before running the test.
        if {[regexp -- {(.*)-(\(.*\))} $name -> head tail]} {
          set opts $::Configs($head)
          if {$tail=="(Debug)"} {
            append opts " -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1"
          } else {
            regsub { *-DSQLITE_MEMDEBUG[^ ]* *} $opts { } opts
            regsub { *-DSQLITE_DEBUG[^ ]* *} $opts { } opts
          }
        } else {
          set opts $::Configs($name)
        }

        set L [make_test_suite $G(msvc) $wtcl $name $target $opts]
        set G(test.$name.log) [file join [lindex $L 1] test.log]
        slave_launch $name $wtcl {*}$L

        set G(test.$name.log) [file join [lindex $L 1] test.log]
        incr nLaunch -1
      }
    }
  }
}