test/pg_common.tcl

   1 # 2018 May 19
   2 #
   3 # The author disclaims copyright to this source code.  In place of
   4 # a legal notice, here is a blessing:
   5 #
   6 #    May you do good and not evil.
   7 #    May you find forgiveness for yourself and forgive others.
   8 #    May you share freely, never taking more than you give.
   9 #
  10 #***********************************************************************
  11 #
  12
  13 package require sqlite3
  14 package require Pgtcl
  15
  16 set db [pg_connect -conninfo "dbname=postgres user=postgres password=postgres"]
  17 sqlite3 sqlite ""
  18
  19 proc execsql {sql} {
  20
  21   set lSql [list]
  22   set frag ""
  23   while {[string length $sql]>0} {
  24     set i [string first ";" $sql]
  25     if {$i>=0} {
  26       append frag [string range $sql 0 $i]
  27       set sql [string range $sql $i+1 end]
  28       if {[sqlite complete $frag]} {
  29         lappend lSql $frag
  30         set frag ""
  31       }
  32     } else {
  33       set frag $sql
  34       set sql ""
  35     }
  36   }
  37   if {$frag != ""} {
  38     lappend lSql $frag
  39   }
  40   #puts $lSql
  41
  42   set ret ""
  43   foreach stmt $lSql {
  44     set res [pg_exec $::db $stmt]
  45     set err [pg_result $res -error]
  46     if {$err!=""} { error $err }
  47     for {set i 0} {$i < [pg_result $res -numTuples]} {incr i} {
  48       if {$i==0} {
  49         set ret [pg_result $res -getTuple 0]
  50       } else {
  51         append ret "   [pg_result $res -getTuple $i]"
  52       }
  53       # lappend ret {*}[pg_result $res -getTuple $i]
  54     }
  55     pg_result $res -clear
  56   }
  57
  58   set ret
  59 }
  60
  61 proc execsql_test {tn sql} {
  62   set res [execsql $sql]
  63   set sql [string map {string_agg group_concat} $sql]
  64   puts $::fd "do_execsql_test $tn {"
  65   puts $::fd "  [string trim $sql]"
  66   puts $::fd "} {$res}"
  67   puts $::fd ""
  68 }
  69
  70 # Same as [execsql_test], except coerce all results to floating point values
  71 # with two decimal points.
  72 #
  73 proc execsql_float_test {tn sql} {
  74   set F "%.4f"
  75   set T 0.0001
  76   set res [execsql $sql]
  77   set res2 [list]
  78   foreach r $res {
  79     if {$r != ""} { set r [format $F $r] }
  80     lappend res2 $r
  81   }
  82
  83   set sql [string trim $sql]
  84 puts $::fd [subst -nocommands {
  85 do_test $tn {
  86   set myres {}
  87   foreach r [db eval {$sql}] {
  88     lappend myres [format $F [set r]]
  89   }
  90   set res2 {$res2}
  91   foreach r [set myres] r2 [set res2] {
  92     if {[set r]<([set r2]-$T) || [set r]>([set r2]+$T)} {
  93       error "list element [set i] does not match: got=[set r] expected=[set r2]"
  94     }
  95   }
  96   set {} {}
  97 } {}
  98 }]
  99 }
 100
 101 proc start_test {name date} {
 102   set dir [file dirname $::argv0]
 103   set output [file join $dir $name.test]
 104   set ::fd [open $output w]
 105 puts $::fd [string trimleft "
 106 # $date
 107 #
 108 # The author disclaims copyright to this source code.  In place of
 109 # a legal notice, here is a blessing:
 110 #
 111 #    May you do good and not evil.
 112 #    May you find forgiveness for yourself and forgive others.
 113 #    May you share freely, never taking more than you give.
 114 #
 115 #***********************************************************************
 116 # This file implements regression tests for SQLite library.
 117 #
 118
 119 ####################################################
 120 # DO NOT EDIT! THIS FILE IS AUTOMATICALLY GENERATED!
 121 ####################################################
 122 "]
 123   puts $::fd {set testdir [file dirname $argv0]}
 124   puts $::fd {source $testdir/tester.tcl}
 125   puts $::fd "set testprefix $name"
 126   puts $::fd ""
 127 }
 128
 129 proc -- {args} {
 130   puts $::fd "# $args"
 131 }
 132
 133 proc ========== {args} {
 134   puts $::fd "#[string repeat = 74]"
 135   puts $::fd ""
 136 }
 137
 138 proc finish_test {} {
 139   puts $::fd finish_test
 140   close $::fd
 141 }
 142
 143 proc ifcapable {arg} {
 144    puts $::fd "ifcapable $arg { finish_test ; return }"
 145 }
 146