summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tcl8/8.6/tdbc/sqlite3-1.1.3.tm
blob: 1794f07409389a689b280ac80a405ecc877cd1a8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
# tdbcsqlite3.tcl --
#
#    SQLite3 database driver for TDBC
#
# Copyright (c) 2008 by Kevin B. Kenny.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
#
#------------------------------------------------------------------------------

package require tdbc
package require sqlite3

package provide tdbc::sqlite3 1.1.3

namespace eval tdbc::sqlite3 {
    namespace export connection
}

#------------------------------------------------------------------------------
#
# tdbc::sqlite3::connection --
#
#	Class representing a SQLite3 database connection
#
#------------------------------------------------------------------------------

::oo::class create ::tdbc::sqlite3::connection {

    superclass ::tdbc::connection

    variable timeout

    # The constructor accepts a database name and opens the database.

    constructor {databaseName args} {
	set timeout 0
	if {[llength $args] % 2 != 0} {
	    set cmd [lrange [info level 0] 0 end-[llength $args]]
	    return -code error \
		-errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \
		"wrong # args, should be \"$cmd ?-option value?...\""
	}
	next
	sqlite3 [namespace current]::db $databaseName
	if {[llength $args] > 0} {
	    my configure {*}$args
	}
	db nullvalue \ufffd
    }

    # The 'statementCreate' method forwards to the constructor of the
    # statement class

    forward statementCreate ::tdbc::sqlite3::statement create

    # The 'configure' method queries and sets options to the database

    method configure args {
	if {[llength $args] == 0} {

	    # Query all configuration options

	    set result {-encoding utf-8}
	    lappend result -isolation
	    if {[db onecolumn {PRAGMA read_uncommitted}]} {
		lappend result readuncommitted
	    } else {
		lappend result serializable
	    }
	    lappend result -readonly 0
	    lappend result -timeout $timeout
	    return $result

	} elseif {[llength $args] == 1} {

	    # Query a single option

	    set option [lindex $args 0]
	    switch -exact -- $option {
		-e - -en - -enc - -enco - -encod - -encodi - -encodin -
		-encoding {
		    return utf-8
		}
		-i - -is - -iso - -isol - -isola - -isolat - -isolati -
		-isolatio - -isolation {
		    if {[db onecolumn {PRAGMA read_uncommitted}]} {
			return readuncommitted
		    } else {
			return serializable
		    }
		}
		-r - -re - -rea - -read - -reado - -readon - -readonl -
		-readonly {
		    return 0
		}
		-t - -ti - -tim - -time - -timeo - -timeou - -timeout {
		    return $timeout
		}
		default {
		    return -code error \
			-errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
					BADOPTION $option] \
			"bad option \"$option\": must be\
                         -encoding, -isolation, -readonly or -timeout"

		}
	    }

	} elseif {[llength $args] % 2 != 0} {

	    # Syntax error

	    set cmd [lrange [info level 0] 0 end-[llength $args]]
	    return -code error \
		-errorcode [list TDBC GENERAL_ERROR HY000 \
				SQLITE3 WRONGNUMARGS] \
		"wrong # args, should be \" $cmd ?-option value?...\""
	}

	# Set one or more options

	foreach {option value} $args {
	    switch -exact -- $option {
		-e - -en - -enc - -enco - -encod - -encodi - -encodin -
		-encoding {
		    if {$value ne {utf-8}} {
			return -code error \
			    -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
					    SQLITE3 ENCODING] \
			    "-encoding not supported. SQLite3 is always \
                             Unicode."
		    }
		}
		-i - -is - -iso - -isol - -isola - -isolat - -isolati -
		-isolatio - -isolation {
		    switch -exact -- $value {
			readu - readun - readunc - readunco - readuncom -
			readuncomm - readuncommi - readuncommit -
			readuncommitt - readuncommitte - readuncommitted {
			    db eval {PRAGMA read_uncommitted = 1}
			}
			readc - readco - readcom - readcomm - readcommi -
			readcommit - readcommitt - readcommitte -
			readcommitted -
			rep - repe - repea - repeat - repeata - repeatab -
			repeatabl - repeatable - repeatabler - repeatablere -
			repeatablerea - repeatablread -
			s - se - ser - seri - seria - serial - seriali -
			serializ - serializa - serializab - serializabl -
			serializable -
			reado - readon - readonl - readonly {
			    db eval {PRAGMA read_uncommitted = 0}
			}
			default {
			    return -code error \
				-errorcode [list TDBC GENERAL_ERROR HY000 \
						SQLITE3 BADISOLATION $value] \
				"bad isolation level \"$value\":\
                                should be readuncommitted, readcommitted,\
                                repeatableread, serializable, or readonly"
			}
		    }
		}
		-r - -re - -rea - -read - -reado - -readon - -readonl -
		-readonly {
		    if {$value} {
			return -code error \
			    -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
					    SQLITE3 READONLY] \
			    "SQLite3's Tcl API does not support read-only\
                             access"
		    }
		}
		-t - -ti - -tim - -time - -timeo - -timeou - -timeout {
		    if {![string is integer $value]} {
			return -code error \
			    -errorcode [list TDBC DATA_EXCEPTION 22018 \
					    SQLITE3 $value] \
			    "expected integer but got \"$value\""
		    }
		    db timeout $value
		    set timeout $value
		}
		default {
		    return -code error \
			-errorcode [list TDBC GENERAL_ERROR HY000 \
					SQLITE3 BADOPTION $value] \
			"bad option \"$option\": must be\
                         -encoding, -isolation, -readonly or -timeout"

		}
	    }
	}
	return
    }

    # The 'tables' method introspects on the tables in the database.

    method tables {{pattern %}} {
	set retval {}
	my foreach row {
	    SELECT * from sqlite_master
	    WHERE type IN ('table', 'view')
	    AND name LIKE :pattern
	} {
	    dict set row name [string tolower [dict get $row name]]
	    dict set retval [dict get $row name] $row
	}
	return $retval
    }

    # The 'columns' method introspects on columns of a table.

    method columns {table {pattern %}} {
	regsub -all ' $table '' table
	set retval {}
	set pattern [string map [list \
				     * {[*]} \
				     ? {[?]} \
				     \[ \\\[ \
				     \] \\\[ \
				     _ ? \
				     % *] [string tolower $pattern]]
	my foreach origrow "PRAGMA table_info('$table')" {
	    set row {}
	    dict for {key value} $origrow {
		dict set row [string tolower $key] $value
	    }
	    dict set row name [string tolower [dict get $row name]]
	    if {![string match $pattern [dict get $row name]]} {
		continue
	    }
	    switch -regexp -matchvar info [dict get $row type] {
		{^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} {
		    dict set row type [string tolower [lindex $info 1]]
		    dict set row precision [lindex $info 2]
		    dict set row scale [lindex $info 3]
		}
		{^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} {
		    dict set row type [string tolower [lindex $info 1]]
		    dict set row precision [lindex $info 2]
		    dict set row scale 0
		}
		default {
		    dict set row type [string tolower [dict get $row type]]
		    dict set row precision 0
		    dict set row scale 0
		}
	    }
	    dict set row nullable [expr {![dict get $row notnull]}]
	    dict set retval [dict get $row name] $row
	}
	return $retval
    }

    # The 'primarykeys' method enumerates the primary keys on a table.

    method primarykeys {table} {
	set result {}
	my foreach row "PRAGMA table_info($table)" {
	    if {[dict get $row pk]} {
		lappend result [dict create ordinalPosition \
				    [expr {[dict get $row cid]+1}] \
				    columnName \
				    [dict get $row name]]
	    }
	}
	return $result
    }

    # The 'foreignkeys' method enumerates the foreign keys that are
    # declared in a table or that refer to a given table.

    method foreignkeys {args} {

	variable ::tdbc::generalError

	# Check arguments

	set argdict {}
	if {[llength $args] % 2 != 0} {
	    set errorcode $generalError
	    lappend errorcode wrongNumArgs
	    return -code error -errorcode $errorcode \
		"wrong # args: should be [lrange [info level 0] 0 1]\
                 ?-option value?..."
	}
	foreach {key value} $args {
	    if {$key ni {-primary -foreign}} {
		set errorcode $generalError
		lappend errorcode badOption
		return -code error -errorcode $errorcode \
		    "bad option \"$key\", must be -primary or -foreign"
	    }
	    set key [string range $key 1 end]
	    if {[dict exists $argdict $key]} {
		set errorcode $generalError
		lappend errorcode dupOption
		return -code error -errorcode $errorcode \
		    "duplicate option \"$key\" supplied"
	    }
	    dict set argdict $key $value
	}

	# If we know the table with the foreign key, search just its
	# foreign keys. Otherwise, iterate over all the tables in the
	# database.

	if {[dict exists $argdict foreign]} {
	    return [my ForeignKeysForTable [dict get $argdict foreign] \
			$argdict]
	} else {
	    set result {}
	    foreach foreignTable [dict keys [my tables]] {
		lappend result {*}[my ForeignKeysForTable \
				       $foreignTable $argdict]
	    }
	    return $result
	}

    }

    # The private ForeignKeysForTable method enumerates the foreign keys
    # in a specific table.
    #
    # Parameters:
    #
    #	foreignTable - Name of the table containing foreign keys.
    #   argdict - Dictionary that may or may not contain a key,
    #             'primary', whose value is the name of a table that
    #             must hold the primary key corresponding to the foreign
    #             key. If the 'primary' key is absent, all tables are
    #             candidates.
    # Results:
    #
    # 	Returns the list of foreign keys that meed the specified
    # 	conditions, as a list of dictionaries, each containing the
    # 	keys, foreignConstraintName, foreignTable, foreignColumn,
    # 	primaryTable, primaryColumn, and ordinalPosition.  Note that the
    #   foreign constraint name is constructed arbitrarily, since SQLite3
    #   does not report this information.

    method ForeignKeysForTable {foreignTable argdict} {

	set result {}
	set n 0

	# Go through the foreign keys in the given table, looking for
	# ones that refer to the primary table (if one is given), or
	# for any primary keys if none is given.
	my foreach row "PRAGMA foreign_key_list($foreignTable)" {
	    if {(![dict exists $argdict primary])
		|| ([string tolower [dict get $row table]]
		    eq [dict get $argdict primary])} {

		# Construct a dictionary for each key, translating
		# SQLite names to TDBC ones and converting sequence
		# numbers to 1-based indexing.

		set rrow [dict create foreignTable $foreignTable \
			      foreignConstraintName \
			      ?$foreignTable?[dict get $row id]]
		if {[dict exists $row seq]} {
		    dict set rrow ordinalPosition \
			[expr {1 + [dict get $row seq]}]
		}
		foreach {to from} {
		    foreignColumn from
		    primaryTable table
		    primaryColumn to
		    deleteAction on_delete
		    updateAction on_update
		} {
		    if {[dict exists $row $from]} {
			dict set rrow $to [dict get $row $from]
		    }
		}

		# Add the newly-constucted dictionary to the result list

		lappend result $rrow
	    }
	}

	return $result
    }

    # The 'preparecall' method prepares a call to a stored procedure.
    # SQLite3 does not have stored procedures, since it's an in-process
    # server.

    method preparecall {call} {
	return -code error \
	    -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
			    SQLITE3 PREPARECALL] \
	    {SQLite3 does not support stored procedures}
    }

    # The 'begintransaction' method launches a database transaction

    method begintransaction {} {
	db eval {BEGIN TRANSACTION}
    }

    # The 'commit' method commits a database transaction

    method commit {} {
	db eval {COMMIT}
    }

    # The 'rollback' method abandons a database transaction

    method rollback {} {
	db eval {ROLLBACK}
    }

    # The 'transaction' method executes a script as a single transaction.
    # We override the 'transaction' method of the base class, since SQLite3
    # has a faster implementation of the same thing. (The base class's generic
    # method should also work.)
    # (Don't overload the base class method, because 'break', 'continue'
    # and 'return' in the transaction body don't work!)

    #method transaction {script} {
    #	uplevel 1 [list {*}[namespace code db] transaction $script]
    #}

    method prepare {sqlCode} {
	set result [next $sqlCode]
	return $result
    }

    method getDBhandle {} {
	return [namespace which db]
    }
}

#------------------------------------------------------------------------------
#
# tdbc::sqlite3::statement --
#
#	Class representing a statement to execute against a SQLite3 database
#
#------------------------------------------------------------------------------

::oo::class create ::tdbc::sqlite3::statement {

    superclass ::tdbc::statement

    variable Params db sql

    # The constructor accepts the handle to the connection and the SQL
    # code for the statement to prepare.  All that it does is to parse the
    # statement and store it.  The parse is used to support the
    # 'params' and 'paramtype' methods.

    constructor {connection sqlcode} {
	next
	set Params {}
	set db [$connection getDBhandle]
	set sql $sqlcode
	foreach token [::tdbc::tokenize $sqlcode] {
	    if {[string index $token 0] in {$ : @}} {
		dict set Params [string range $token 1 end] \
		    {type Tcl_Obj precision 0 scale 0 nullable 1 direction in}
	    }
	}
    }

    # The 'resultSetCreate' method relays to the result set constructor

    forward resultSetCreate ::tdbc::sqlite3::resultset create

    # The 'params' method returns descriptions of the parameters accepted
    # by the statement

    method params {} {
	return $Params
    }

    # The 'paramtype' method need do nothing; Sqlite3 uses manifest typing.

    method paramtype args {;}

    method getDBhandle {} {
	return $db
    }

    method getSql {} {
	return $sql
    }

}

#-------------------------------------------------------------------------------
#
# tdbc::sqlite3::resultset --
#
#	Class that represents a SQLlite result set in Tcl
#
#-------------------------------------------------------------------------------

::oo::class create ::tdbc::sqlite3::resultset {

    superclass ::tdbc::resultset

    # The variables of this class all have peculiar names. The reason is
    # that the RunQuery method needs to execute with an activation record
    # that has no local variables whose names could conflict with names
    # in the SQL query. We start the variable names with hyphens because
    # they can't be bind variables.

    variable -set {*}{
	-columns -db -needcolumns -resultArray
	-results -sql -Cursor -RowCount -END
    }

    constructor {statement args} {
	next
	set -db [$statement getDBhandle]
	set -sql [$statement getSql]
	set -columns {}
	set -results {}
	${-db} trace [namespace code {my RecordStatement}]
	if {[llength $args] == 0} {

	    # Variable substitutions are evaluated in caller's context

	    uplevel 1 [list ${-db} eval ${-sql} \
			   [namespace which -variable -resultArray] \
			   [namespace code {my RecordResult}]]

	} elseif {[llength $args] == 1} {

	    # Variable substitutions are in the dictionary at [lindex $args 0].

	    set -paramDict [lindex $args 0]

	    # At this point, the activation record must contain no variables
	    # that might be bound within the query.  All variables at this point
	    # begin with hyphens so that they are syntactically incorrect
	    # as bound variables in SQL.

	    unset args
	    unset statement

	    dict with -paramDict {
		${-db} eval ${-sql} -resultArray {
		    my RecordResult
		}
	    }

	} else {

	    ${-db} trace {}

	    # Too many args

	    return -code error \
		-errorcode [list TDBC GENERAL_ERROR HY000 \
				SQLITE3 WRONGNUMARGS] \
		"wrong # args: should be\
                 [lrange [info level 0] 0 1] statement ?dictionary?"

	}
	${-db} trace {}
	set -Cursor 0
	if {${-Cursor} < [llength ${-results}]
	    && [lindex ${-results} ${-Cursor}] eq {statement}} {
	    incr -Cursor 2
	}
	if {${-Cursor} < [llength ${-results}]
	    && [lindex ${-results} ${-Cursor}] eq {columns}} {
	    incr -Cursor
	    set -columns [lindex ${-results} ${-Cursor}]
	    incr -Cursor
	}
	set -RowCount [${-db} changes]
    }

    # Record the start of a SQL statement

    method RecordStatement {stmt} {
	set -needcolumns 1
	lappend -results statement {}
    }

    # Record one row of results from a query by appending it as a dictionary
    # to the 'results' list.  As a side effect, set 'columns' to a list
    # comprising the names of the columns of the result.

    method RecordResult {} {
	set columns ${-resultArray(*)}
	if {[info exists -needcolumns]} {
	    lappend -results columns $columns
	    unset -needcolumns
	}
	set dict {}
	foreach key $columns {
	    if {[set -resultArray($key)] ne "\ufffd"} {
		dict set dict $key [set -resultArray($key)]
	    }
	}
	lappend -results row $dict
    }

    # Advance to the next result set

    method nextresults {} {
	set have 0
	while {${-Cursor} < [llength ${-results}]} {
	    if {[lindex ${-results} ${-Cursor}] eq {statement}} {
		set have 1
		incr -Cursor 2
		break
	    }
	    incr -Cursor 2
	}
	if {!$have} {
	    set -END {}
	}
	if {${-Cursor} >= [llength ${-results}]} {
	    set -columns {}
	} elseif {[lindex ${-results} ${-Cursor}] eq {columns}} {
	    incr -Cursor
	    set -columns [lindex ${-results} ${-Cursor}]
	    incr -Cursor
	} else {
	    set -columns {}
	}
	return $have
    }

    method getDBhandle {} {
	return ${-db}
    }

    # Return a list of the columns

    method columns {} {
	if {[info exists -END]} {
	    return -code error \
		-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
		"Function sequence error: result set is exhausted."
	}
	return ${-columns}
    }

    # Return the next row of the result set as a list

    method nextlist var {

	upvar 1 $var row

	if {[info exists -END]} {
	    return -code error \
		-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
		"Function sequence error: result set is exhausted."
	}
	if {${-Cursor} >= [llength ${-results}]
	    || [lindex ${-results} ${-Cursor}] ne {row}} {
	    return 0
	} else {
	    set row {}
	    incr -Cursor
	    set d [lindex ${-results} ${-Cursor}]
	    incr -Cursor
	    foreach key ${-columns} {
		if {[dict exists $d $key]} {
		    lappend row [dict get $d $key]
		} else {
		    lappend row {}
		}
	    }
	}
	return 1
    }

    # Return the next row of the result set as a dict

    method nextdict var {

	upvar 1 $var row

	if {[info exists -END]} {
	    return -code error \
		-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
		"Function sequence error: result set is exhausted."
	}
	if {${-Cursor} >= [llength ${-results}]
	    || [lindex ${-results} ${-Cursor}] ne {row}} {
	    return 0
	} else {
	    incr -Cursor
	    set row [lindex ${-results} ${-Cursor}]
	    incr -Cursor
	}
	return 1
    }

    # Return the number of rows affected by a statement

    method rowcount {} {
	if {[info exists -END]} {
	    return -code error \
		-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
		"Function sequence error: result set is exhausted."
	}
	return ${-RowCount}
    }

}