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