gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/pg_common.tcl (about) 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