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 sql [string map {{WITHOUT ROWID} {}} $sql]
  22
  23   set lSql [list]
  24   set frag ""
  25   while {[string length $sql]>0} {
  26     set i [string first ";" $sql]
  27     if {$i>=0} {
  28       append frag [string range $sql 0 $i]
  29       set sql [string range $sql $i+1 end]
  30       if {[sqlite complete $frag]} {
  31         lappend lSql $frag
  32         set frag ""
  33       }
  34     } else {
  35       set frag $sql
  36       set sql ""
  37     }
  38   }
  39   if {$frag != ""} {
  40     lappend lSql $frag
  41   }
  42   #puts $lSql
  43
  44   set ret ""
  45   set nChar 0
  46   foreach stmt $lSql {
  47     set res [pg_exec $::db $stmt]
  48     set err [pg_result $res -error]
  49     if {$err!=""} { error $err }
  50
  51     for {set i 0} {$i < [pg_result $res -numTuples]} {incr i} {
  52       set t [pg_result $res -getTuple $i]
  53       set nNew [string length $t]
  54       if {$nChar>0 && ($nChar+$nNew+3)>75} {
  55         append ret "\n  "
  56         set nChar 0
  57       } else {
  58         if {$nChar>0} {
  59           append ret "   "
  60           incr nChar 3
  61         }
  62       }
  63       incr nChar $nNew
  64       append ret $t
  65     }
  66     pg_result $res -clear
  67   }
  68
  69   set ret
  70 }
  71
  72 proc execsql_test {tn sql} {
  73   set res [execsql $sql]
  74   set sql [string map {string_agg group_concat} $sql]
  75   # set sql [string map [list {NULLS FIRST} {}] $sql]
  76   # set sql [string map [list {NULLS LAST} {}] $sql]
  77   puts $::fd "do_execsql_test $tn {"
  78   puts $::fd "  [string trim $sql]"
  79   puts $::fd "} {$res}"
  80   puts $::fd ""
  81 }
  82
  83 proc errorsql_test {tn sql} {
  84   set rc [catch {execsql $sql} msg]
  85   if {$rc==0} {
  86     error "errorsql_test SQL did not cause an error!"
  87   }
  88   set msg [lindex [split [string trim $msg] "\n"] 0]
  89   puts $::fd "# PG says $msg"
  90   set sql [string map {string_agg group_concat} $sql]
  91   puts $::fd "do_test $tn { catch { execsql {"
  92   puts $::fd "  [string trim $sql]"
  93   puts $::fd "} } } 1"
  94   puts $::fd ""
  95 }
  96
  97 # Same as [execsql_test], except coerce all results to floating point values
  98 # with two decimal points.
  99 #
 100 proc execsql_float_test {tn sql} {
 101   set F "%.4f"
 102   set T 0.0001
 103   set res [execsql $sql]
 104   set res2 [list]
 105   foreach r $res {
 106     if {$r != ""} { set r [format $F $r] }
 107     lappend res2 $r
 108   }
 109
 110   set sql [string trim $sql]
 111 puts $::fd [subst -nocommands {
 112 do_test $tn {
 113   set myres {}
 114   foreach r [db eval {$sql}] {
 115     lappend myres [format $F [set r]]
 116   }
 117   set res2 {$res2}
 118   set i 0
 119   foreach r [set myres] r2 [set res2] {
 120     if {[set r]<([set r2]-$T) || [set r]>([set r2]+$T)} {
 121       error "list element [set i] does not match: got=[set r] expected=[set r2]"
 122     }
 123     incr i
 124   }
 125   set {} {}
 126 } {}
 127 }]
 128 }
 129
 130 proc start_test {name date} {
 131   set dir [file dirname $::argv0]
 132   set output [file join $dir $name.test]
 133   set ::fd [open $output w]
 134 puts $::fd [string trimleft "
 135 # $date
 136 #
 137 # The author disclaims copyright to this source code.  In place of
 138 # a legal notice, here is a blessing:
 139 #
 140 #    May you do good and not evil.
 141 #    May you find forgiveness for yourself and forgive others.
 142 #    May you share freely, never taking more than you give.
 143 #
 144 #***********************************************************************
 145 # This file implements regression tests for SQLite library.
 146 #
 147
 148 ####################################################
 149 # DO NOT EDIT! THIS FILE IS AUTOMATICALLY GENERATED!
 150 ####################################################
 151 "]
 152   puts $::fd {set testdir [file dirname $argv0]}
 153   puts $::fd {source $testdir/tester.tcl}
 154   puts $::fd "set testprefix $name"
 155   puts $::fd ""
 156 }
 157
 158 proc -- {args} {
 159   puts $::fd "# $args"
 160 }
 161
 162 proc ========== {args} {
 163   puts $::fd "#[string repeat = 74]"
 164   puts $::fd ""
 165 }
 166
 167 proc finish_test {} {
 168   puts $::fd finish_test
 169   close $::fd
 170 }
 171
 172 proc ifcapable {arg} {
 173    puts $::fd "ifcapable $arg { finish_test ; return }"
 174 }
 175