2018-05-30 20:44:58 +00:00
# 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 " d b n a m e = p o s t g r e s u s e r = p o s t g r e s p a s s w o r d = p o s t g r e s " ]
sqlite3 sqlite " "
proc execsql { sql } {
2020-04-27 20:55:33 +00:00
set sql [ string map { { WITHOUT ROWID} { } } $sql ]
2018-05-30 20:44:58 +00:00
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 " "
2019-03-16 20:29:54 +00:00
set nChar 0
2018-05-30 20:44:58 +00:00
foreach stmt $lSql {
set res [ pg_exec $::db $stmt ]
set err [ pg_result $res - error]
if { $err != " " } { error $err }
2019-03-16 20:29:54 +00:00
2018-05-30 20:44:58 +00:00
for { set i 0 } { $i < [ pg_result $res - numTuples] } { incr i} {
2019-03-16 20:29:54 +00:00
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
2018-05-30 20:44:58 +00:00
} else {
2019-03-16 20:29:54 +00:00
if { $nChar > 0 } {
append ret " "
incr nChar 3
}
2018-05-30 20:44:58 +00:00
}
2019-03-16 20:29:54 +00:00
incr nChar $nNew
append ret $t
2018-05-30 20:44:58 +00:00
}
pg_result $res - clear
}
set ret
}
proc execsql_test { tn sql} {
set res [ execsql $sql ]
2018-06-08 11:45:28 +00:00
set sql [ string map { string_agg group_concat} $sql ]
2019-08-19 19:59:50 +00:00
# set sql [string map [list {NULLS FIRST} {}] $sql]
# set sql [string map [list {NULLS LAST} {}] $sql]
2018-05-30 20:44:58 +00:00
puts $::fd " d o _ e x e c s q l _ t e s t $ t n { "
puts $::fd " [ s t r i n g t r i m $ s q l ] "
puts $::fd " } { $ r e s } "
puts $::fd " "
}
2019-03-04 21:07:11 +00:00
proc errorsql_test { tn sql} {
set rc [ catch { execsql $sql } msg]
if { $rc == 0 } {
error " e r r o r s q l _ t e s t S Q L d i d n o t c a u s e a n e r r o r ! "
}
2019-03-09 20:49:17 +00:00
set msg [ lindex [ split [ string trim $msg ] " \n " ] 0 ]
puts $::fd " # P G s a y s $ m s g "
2019-03-04 21:07:11 +00:00
set sql [ string map { string_agg group_concat} $sql ]
puts $::fd " d o _ t e s t $ t n { c a t c h { e x e c s q l { "
puts $::fd " [ s t r i n g t r i m $ s q l ] "
puts $::fd " } } } 1 "
puts $::fd " "
}
2018-06-04 08:22:09 +00:00
# Same as [execsql_test], except coerce all results to floating point values
# with two decimal points.
#
proc execsql_float_test { tn sql} {
2018-07-10 18:50:01 +00:00
set F " % . 4 f "
set T 0.0001
2018-06-04 08:22:09 +00:00
set res [ execsql $sql ]
set res2 [ list ]
2018-06-14 20:52:08 +00:00
foreach r $res {
if { $r != " " } { set r [ format $F $r ] }
lappend res2 $r
}
2018-06-04 08:22:09 +00:00
2018-07-10 18:50:01 +00:00
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 }
2019-03-08 20:02:52 +00:00
set i 0
2018-07-10 18:50:01 +00:00
foreach r [ set myres] r2 [ set res2] {
if { [ set r] < ( [ set r2] - $T ) || [ set r] > ( [ set r2] + $T ) } {
error " l i s t e l e m e n t [ s e t i ] d o e s n o t m a t c h : g o t = [ s e t r ] e x p e c t e d = [ s e t r 2 ] "
}
2019-03-08 20:02:52 +00:00
incr i
2018-07-10 18:50:01 +00:00
}
set { } { }
} { }
} ]
2018-06-04 08:22:09 +00:00
}
2018-05-30 20:44:58 +00:00
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 " s e t t e s t p r e f i x $ n a m e "
puts $::fd " "
}
proc - - { args } {
puts $::fd " # $ a r g s "
}
proc == == == == == { args } {
puts $::fd " # [ s t r i n g r e p e a t = 7 4 ] "
puts $::fd " "
}
proc finish_test { } {
puts $::fd finish_test
close $::fd
}
2018-06-22 20:51:35 +00:00
proc ifcapable { arg } {
puts $::fd " i f c a p a b l e $ a r g { f i n i s h _ t e s t ; r e t u r n } "
}