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 "%.2f"
  75   set res [execsql $sql]
  76   set res2 [list]
  77   foreach r $res {
  78     if {$r != ""} { set r [format $F $r] }
  79     lappend res2 $r
  80   }
  81
  82   puts $::fd "do_test $tn {"
  83   puts $::fd "  set myres {}"
  84   puts $::fd "  foreach r \[db eval {[string trim $sql]}\] {"
  85   puts $::fd "    lappend myres \[format $F \[set r\]\]"
  86   puts $::fd "  }"
  87   puts $::fd "  set myres"
  88   puts $::fd "} {$res2}"
  89   puts $::fd ""
  90 }
  91
  92 proc start_test {name date} {
  93   set dir [file dirname $::argv0]
  94   set output [file join $dir $name.test]
  95   set ::fd [open $output w]
  96 puts $::fd [string trimleft "
  97 # $date
  98 #
  99 # The author disclaims copyright to this source code.  In place of
 100 # a legal notice, here is a blessing:
 101 #
 102 #    May you do good and not evil.
 103 #    May you find forgiveness for yourself and forgive others.
 104 #    May you share freely, never taking more than you give.
 105 #
 106 #***********************************************************************
 107 # This file implements regression tests for SQLite library.
 108 #
 109
 110 ####################################################
 111 # DO NOT EDIT! THIS FILE IS AUTOMATICALLY GENERATED!
 112 ####################################################
 113 "]
 114   puts $::fd {set testdir [file dirname $argv0]}
 115   puts $::fd {source $testdir/tester.tcl}
 116   puts $::fd "set testprefix $name"
 117   puts $::fd ""
 118 }
 119
 120 proc -- {args} {
 121   puts $::fd "# $args"
 122 }
 123
 124 proc ========== {args} {
 125   puts $::fd "#[string repeat = 74]"
 126   puts $::fd ""
 127 }
 128
 129 proc finish_test {} {
 130   puts $::fd finish_test
 131   close $::fd
 132 }
 133
 134 proc ifcapable {arg} {
 135    puts $::fd "ifcapable $arg { finish_test ; return }"
 136 }
 137