release v1.4.0-beta1v1.4.0-beta1

1 files changed, 173 insertions, 0 deletions

diff --git a/testdata/tcl/pg_common.tcl b/testdata/tcl/pg_common.tcl
new file mode 100644
index 0000000..b3f35cd
--- /dev/null
+++ b/testdata/tcl/pg_common.tcl
@@ -0,0 +1,173 @@
+# 2018 May 19
+#
+# The author disclaims copyright to this source code.  In place of
+# a legal notice, here is a blessing:
+#
+#    May you do good and not evil.
+#    May you find forgiveness for yourself and forgive others.
+#    May you share freely, never taking more than you give.
+#
+#***********************************************************************
+#
+
+package require sqlite3
+package require Pgtcl
+
+set db [pg_connect -conninfo "dbname=postgres user=postgres password=postgres"]
+sqlite3 sqlite ""
+
+proc execsql {sql} {
+
+  set lSql [list]
+  set frag ""
+  while {[string length $sql]>0} {
+    set i [string first ";" $sql]
+    if {$i>=0} {
+      append frag [string range $sql 0 $i]
+      set sql [string range $sql $i+1 end]
+      if {[sqlite complete $frag]} {
+        lappend lSql $frag
+        set frag ""
+      }
+    } else {
+      set frag $sql
+      set sql ""
+    }
+  }
+  if {$frag != ""} {
+    lappend lSql $frag
+  }
+  #puts $lSql
+
+  set ret ""
+  set nChar 0
+  foreach stmt $lSql {
+    set res [pg_exec $::db $stmt]
+    set err [pg_result $res -error]
+    if {$err!=""} { error $err }
+
+    for {set i 0} {$i < [pg_result $res -numTuples]} {incr i} {
+      set t [pg_result $res -getTuple $i]
+      set nNew [string length $t]
+      if {$nChar>0 && ($nChar+$nNew+3)>75} {
+        append ret "\n  "
+        set nChar 0
+      } else {
+        if {$nChar>0} {
+          append ret "   "
+          incr nChar 3
+        }
+      }
+      incr nChar $nNew
+      append ret $t
+    }
+    pg_result $res -clear
+  }
+
+  set ret
+}
+
+proc execsql_test {tn sql} {
+  set res [execsql $sql]
+  set sql [string map {string_agg group_concat} $sql]
+  # set sql [string map [list {NULLS FIRST} {}] $sql]
+  # set sql [string map [list {NULLS LAST} {}] $sql]
+  puts $::fd "do_execsql_test $tn {"
+  puts $::fd "  [string trim $sql]"
+  puts $::fd "} {$res}"
+  puts $::fd ""
+}
+
+proc errorsql_test {tn sql} {
+  set rc [catch {execsql $sql} msg]
+  if {$rc==0} {
+    error "errorsql_test SQL did not cause an error!"
+  }
+  set msg [lindex [split [string trim $msg] "\n"] 0]
+  puts $::fd "# PG says $msg"
+  set sql [string map {string_agg group_concat} $sql]
+  puts $::fd "do_test $tn { catch { execsql {"
+  puts $::fd "  [string trim $sql]"
+  puts $::fd "} } } 1"
+  puts $::fd ""
+}
+
+# Same as [execsql_test], except coerce all results to floating point values
+# with two decimal points.
+#
+proc execsql_float_test {tn sql} {
+  set F "%.4f"
+  set T 0.0001
+  set res [execsql $sql]
+  set res2 [list]
+  foreach r $res { 
+    if {$r != ""} { set r [format $F $r] }
+    lappend res2 $r
+  }
+
+  set sql [string trim $sql]
+puts $::fd [subst -nocommands {
+do_test $tn {
+  set myres {}
+  foreach r [db eval {$sql}] {
+    lappend myres [format $F [set r]]
+  }
+  set res2 {$res2}
+  set i 0
+  foreach r [set myres] r2 [set res2] {
+    if {[set r]<([set r2]-$T) || [set r]>([set r2]+$T)} {
+      error "list element [set i] does not match: got=[set r] expected=[set r2]"
+    }
+    incr i
+  }
+  set {} {}
+} {}
+}]
+}
+
+proc start_test {name date} {
+  set dir [file dirname $::argv0]
+  set output [file join $dir $name.test]
+  set ::fd [open $output w]
+puts $::fd [string trimleft "
+# $date
+#
+# The author disclaims copyright to this source code.  In place of
+# a legal notice, here is a blessing:
+#
+#    May you do good and not evil.
+#    May you find forgiveness for yourself and forgive others.
+#    May you share freely, never taking more than you give.
+#
+#***********************************************************************
+# This file implements regression tests for SQLite library.
+#
+
+####################################################
+# DO NOT EDIT! THIS FILE IS AUTOMATICALLY GENERATED!
+####################################################
+"]
+  puts $::fd {set testdir [file dirname $argv0]}
+  puts $::fd {source $testdir/tester.tcl}
+  puts $::fd "set testprefix $name"
+  puts $::fd ""
+}
+
+proc -- {args} {
+  puts $::fd "# $args"
+}
+
+proc ========== {args} {
+  puts $::fd "#[string repeat = 74]"
+  puts $::fd ""
+}
+
+proc finish_test {} {
+  puts $::fd finish_test
+  close $::fd
+}
+
+proc ifcapable {arg} {
+   puts $::fd "ifcapable $arg { finish_test ; return }"
+}
+