ycl

Artifact [46a8e047ee]
Login

Artifact [46a8e047ee]

Check-ins Using Download Hex

Artifact 46a8e047ee2f04d910be26c8ba39bd53622a5d07:

#! /bin/env tclsh

package require {ycl list}
namespace import [yclprefix]::list::sl
package require {ycl parse tcl}
namespace import [yclprefix]::parse::tcl::commands::commands

package require sqlite3


namespace ensemble create -map {
	exists column_exists
} -command column 


proc column_exists {db table column} {
	if {[llength $table] > 1} {
		lassign $table schema table
		set query "pragma [idquote $schema].table_info([idquote $table])"
	} else {
		set query "pragma table_info([idquote $table])"
	}

	{*}$db eval $query {
		if {$name eq $column} {
			return 1
		}
	}
	return 0
}


variable doc::fromscript {
	description {
		Use [uplevel] as necessary to evaluate this function in a context where
		the next level up holds the variables for the scripted list.
	}
}


proc explain_pretty {data {chan stdout}} {
	foreach {id parent aux desc} $data {
		puts $chan [list $id $parent $aux $desc]
	}
}


proc get {dbcmd query} {
	if {[uplevel 1 [list {*}$dbcmd exists $query]]} {
		uplevel 1 [list {*}$dbcmd onecolumn $query]
	} else {
		error [list {no results} dbcmd $dbcmd query $query]
	}
}


proc dquoteescape id {
	return \"[string map {\" \"\"} $id]\"
}


namespace eval gen {
	package require {ycl list}
	namespace import [yclprefix]::list::sl
	package require {ycl parse tcl}
	namespace import [yclprefix]::parse::tcl::commands::commands
	namespace import [yclprefix]::parse::tcl::words
	namespace path [list [namespace parent]]

	namespace eval doc {}
	namespace ensemble create
	namespace export *

}


proc gen::addcondition {clausename joiner args} {
	upvar 1 $clausename clause
	if {[llength $clausename]} {
		lappend clause $joiner
	}
	lappend clause {*}$args
	return
}


proc gen::as {db talias args} {
	dict size $args
	foreach {name alias} $args {
		$db eval {
			insert into alias values (:alias , :talias , :name)}
	}
	return
}


proc gen::colnorm {db alias} {
	{*}$db eval {select tname ,cname from alias where alias = $alias} {
		while 1 {
			$db eval {select tname ,cname  from alias where alias = $tname} {
				set tname $name
				continue
			}
			return $tname.$cname
		}
	}
	return $alias
}


proc gen::expr_ {db script}  {
	set res {}
	foreach cmd [commands $script] {
		lassign [types $cmd[set cmd {}]] cmd types
		# Currently not using the type of the command name for anything, and 
		# this keeps the indexes reasonable below.
		set types [lrange $types[set types {}] 1 end]
		set cmd [lassign $cmd[set cmd {}] cmdname]
		switch $cmdname {
			or {
				if {[llength $res]} {
					lappend res or
				}
				lappend res {*}[or $cmd]
			}
			!= - == - and - > - >= - < - <= - like {
				if {[llength $res]} {
					lappend res and
				}
				lappend res [tval [lindex $cmd 0] [lindex $types 0] db $db] $cmdname [
					tval [lindex $cmd 1] [lindex $types 1] db $db]
			}
			default {
				error [list {unknown command} $cmdname]
			}
		}
	}
	return $res
}


proc gen::guesstype val {
	if {![catch {expr {$val + 1}}]} {
		return num
	} else {
		return str
	}
}


proc gen::join_ {db table1 type table2 script} {
	set res {}
	puts [list geebab $db $table1 $type $table2 $script]
	set on {}
	foreach cmd [commands $script] {
		lassign [types $cmd[set cmd {}]] cmd types
		# Currently not using the type of the command name for anything, and 
		# this keeps the indexes reasonable below.
		set types [lrange $types[set types {}] 1 end]
		set cmd [lassign $cmd[set cmd {}] cmdname]
		switch $cmdname {
			as {
				as $db $table2 {*}$cmd
			}

			== {
				if {[llength $on]} {
					lappend on and
				}
				lappend on [colnorm $db [lindex $cmd 0]] $cmdname [
					colnorm $db [lindex $cmd 1]]
			}
			default {
				error [list {unknown command} [list $cmdname {*}$cmd]]
			}
		}
	}
	return [list $table2 on {*}$on]
}


proc gen::or {db cmd} {
	if {[llength $cmd] > 1} {
		error [list {wrong # args}]
	}
	lappend res (
		set exprlist {}
		foreach cmd1 [commands [lindex $cmd 0]] {
			if {[llength $res] > 1} {
				lappend res and
			}
			lappend res {*}[expr_ $db $cmd1]
		}
		lappend res {*}[join $exprlist and]
	lappend res )
	return $res
}


variable gen::doc::report {
	description {
		Process the report script in a tclsqlite statement 
	}
	args {
		fields {
			description {
				Tcl scripted data containing field names and aliases
			}
		}
	}
}
proc gen::report {fields args} {
	dict update args db db {}
	set report {}
	foreach cmd [commands $fields[set fields {}]] {
		set part {}
		set cmd [uplevel [list [namespace which sl] $cmd]]
		lassign $cmd name alias
		set realname [colnorm $db $name]
		lappend part [idquote $realname]
		if {[llength $cmd] > 1} {
			lappend part as $alias 
		} elseif {$realname ne $name} {
			lappend part as $name
		}
		lappend report [join $part { }]
	}
	join $report { ,} 
}


variable doc::gen {
	description {
		Generate a sql select statement from a ycl sql script .
	}
}
proc gen::select {script args} {
	dict update args db db {}
	set from {}
	set fromclause from 
	set joins {}
	set joinclause {}
	set vars {}
	set values {}
	set write {}
	set i -1
	set mode read


	try {
		if {![info exists db]} {
			set db db[info cmdcount]
			sqlite3 $db :memory:

			$db eval {
				create table alias (
					alias primary key 
					,tname
					,cname
				)

				; create table "table" (
					rowid integer primary key
					, name
					, alias
					, constraint c_unique unique (
						name ,alias
					)
				)
			}
		}

		set cmds {}
		foreach cmd [commands $script] {
			lappend cmds [uplevel 1 [list [namespace which sl] $cmd]]
		}

		# Special case where script is exactly one or two commands each consisting
		# of 1 word
		if {[llength $cmds] < 3 &&  [llength [lindex $cmds 0]] == 1} {
			set cmd [lindex $cmds 0]
			set cmd [linsert $cmd 0 table]
			set cmds [lreplace $cmds 0 0 $cmd] 
			if {[llength $cmds] == 2 && [llength [lindex $cmds 1]] == 1} {
				set cmd [lindex $cmds 1]
				set cmd [linsert $cmd 0 report]
				set cmds [lreplace $cmds 1 1 $cmd] 
			}
		}

		set query {}
		foreach cmd $cmds {
			set cmdargs [lassign $cmd[set cmd {}] cmdname]
			switch $cmdname {
				table {
					if {[dict exists $query select]} {
						return -code error [list {table provided} $cmdname \
							{when select already provided} [
								dict get $query select]]
					}
				}
				select {
					if {[dict exists $query table]} {
						return -code error [list {select provided} $cmdname \
							{when table already provided} [
								dict get $query $select]]
					}
				}
				
			}
			dict set query $cmdname $cmdargs
		}

		# Get the table name and alias
		if {[dict exists $query select]} {
			set talias [talias select $db]
			lassign [dict get $query select] table script
			lappend fromclause ( [select $table db $db] ) as $talias
			set part [uplevel [
				list [namespace which table] $talias $script db $db]]
		} elseif {[dict exists $query table]} {
			lassign [dict get $query table] table script
			set talias [talias $table $db]
			set part [uplevel [
				list [namespace which table] $talias $script db $db]]
		}

		lappend fromclause [idquote $table]

		if {$table ne $talias} {
			lappend fromclause [idquote $talias]
		}

		if {$part ne {}} {
			lappend fromclause $part
		}

		set sql select
		#process the report script
		set report [uplevel [list [
			namespace which report] [
				lindex [dict get $query report] 0] db $db table $talias]]

		if {$report eq {}} {
			lappend sql *
		} else {
			lappend sql $report
		}

		lappend sql [join $fromclause { }]
	} finally {
		rename $db {}
	}
	return [dict create vars $vars sql [join $sql { }]]
}

proc gen::strquote val {
	if {[string is double -strict $val]} {
		return $val
	} else {
		return '[string map {' ''} $val]'
	}
}

variable gen::doc::table {
	description {

		a table is a Tcl script that describes what to select from the
		specified table.


		commands

			as

				

			expressions

				Each operator listed undeer "operators" is the name of an
				expression command.


				operators

					==

					!=

					>=

					<=

					>
					
					<

					()

					like

				operands

					type commands

						a type command is a Tcl command substitution that is only
						allowed as a single word that is an operand.  It
						substitutes its argument as a typed value.  Each type
						listed under "types" is the name of a type command.

				types 

					col 

					str

					num

					bin
			
	}
}


proc gen::table {talias script args} {
	dict update args db db table table {}
	set joins {}
	set exprs {}
	set res {}
	set where {}

	set cmds [commands $script]
	while {[llength $cmds]} {
		set cmds [lassign $cmds[set cmds {}] cmd]
		puts [list command was $cmd]
		lassign [types $cmd[set cmd {}]] cmd types
		# Currently not using the type of the command name for anything, and 
		# this keeps the indexes reasonable below.
		set types [lrange $types[set types {}] 1 end]
		puts [list cmd is $cmd]
		set cmdargs [lassign $cmd cmdname]
		switch $cmdname {
			select {
				set cmdargs [lassign $cmdargs[set cmdargs {}] table1 script]
				lappend joins [list inner select $table1 $script]
			}
			table {
				set cmdargs [lassign $cmdargs[set cmdargs {}] table1 script]
				lappend joins [list inner table $table1 $script]
			}
			or {
				if {[llength where]} {
					lappend where or
				}
				lappend where {*}[or $db $cmdargs]
			}
			!= - == - and - > - >= - < - <= - like {
				if {[llength $cmd] != 3} {
					error [list {bad expression} $cmd]
				}
				if {[llength $where]} {
					lappend where and
				}
				lappend where [
					tval [lindex $cmdargs 0] [
						lindex $types 0] db $db] $cmdname [
					tval [lindex $cmdargs 1] [lindex $types 1] db $db]
			}
			inner - outer - cross - left - right {
				if {[llength $cmdargs] < 3} {
					set cmdargs [linsert $cmdargs 0 table]
				}
				lappend joins [join_ $db $talias {*}$cmdargs]
			}
			as {
				as $db $talias {*}$cmdargs
			}

			default {
				return -code error [list {unknown command} $cmdname]
			}
		}
	}

	foreach joinspec $joins {
		lappend res join {*}$joinspec
	}

	if {[llength $where]} {
		lappend res where {*}$where
	}

	return [join $res { }]
}


proc gen::talias {tablename db} {
	while 1 {
		set alias $tablename[incr i]
		$db eval {insert or ignore into "table" values(null , :tablename, :alias)}
		if {[$db total_changes]} break
	}
	return $alias
}


proc gen::tablenorm {alias db} {
	$db eval {select name from "table" where alias = $alias}  {
		return $name
	}
	return $alias
}


proc gen::tval {val type args} {
	dict update args db db {}
	switch $type {
		col {
			return [colnorm $db $val]
		}
		str - string {
			return [strquote $val]
		}
		num {
			if {![regexp {^([[:digit:]]*)(?:\.([[:digit:]]+))?(?:[eE][+-]?([[:digit:]]+))?$|^0x[a-fA-F]+$} $val]} {
				return -code error [list {not a sqlite number} $val]
			} else {
				return $val
			}
		}
		var {
			return :$val
		}
		default {
			return -code error [list {unknown type} $type]
		}
	}
}


proc gen::types cmd {
	set types {}
	foreach word [words $cmd[set cmd {}]] {
		lassign [uplevel 1 [list [namespace which vtype] $word]] type word
		set word [lindex [uplevel 1 [list [namespace which sl] $word]] 0]
		lappend cmd $word
		if {$type eq {}} {
			set type [guesstype $word]
		}
		lappend types $type
	}
	return [list $cmd $types]
}


proc gen::vtype word {
	set type {}
	if {[string index $word 0] eq {[}
		&& [string index $word end] eq {]}} {
		set script2 [string trim [string range $word 1 end-1]]
		set cmds2 [lassign [commands $script2] cmd2]
		set words2 [lassign [words $cmd2] word2]
		if {$word2 in {blob col num str var}} {
			set word [join [list [concat {*}$words2] $cmds2 \n]]
			set type $word2
		} 
	}
	return [list $type $word]
}


proc idquote id {
	variable keywords
	if {[keyword $id]} {
		set id [join [split [dquoteescape $id[set id {}]] .] {"."}]
	} else {
		set newid [dquoteescape $id]
	}
	return $id
}


namespace ensemble create -map {
	exists table_exists
} -command index 

proc index_exists {db table index} {
	set res [{*}$db exists {
		select * from sqlite_master
			where type = 'index' and name = $index and tbl_name = $table
	}]
	return $res
}


proc keyword word {
	variable keywords
	expr {[string toupper $word] in $keywords}
}


namespace ensemble create -map {
	exists table_exists
} -command table 

proc table_exists {db table} {
	set res [{*}$db exists {
		select * from sqlite_master
			where type = 'table' and name = $table
	}]
	return $res
}




variable keywords {
	ABORT
	ACTION
	ADD
	AFTER
	ALL
	ALTER
	ANALYZE
	AND
	AS
	ASC
	ATTACH
	AUTOINCREMENT
	BEFORE
	BEGIN
	BETWEEN
	BY
	CASCADE
	CASE
	CAST
	CHECK
	COLLATE
	COLUMN
	COMMIT
	CONFLICT
	CONSTRAINT
	CREATE
	CROSS
	CURRENT_DATE
	CURRENT_TIME
	CURRENT_TIMESTAMP
	DATABASE
	DEFAULT
	DEFERRABLE
	DEFERRED
	DELETE
	DESC
	DETACH
	DISTINCT
	DROP
	EACH
	ELSE
	END
	ESCAPE
	EXCEPT
	EXCLUSIVE
	EXISTS
	EXPLAIN
	FAIL
	FOR
	FOREIGN
	FROM
	FULL
	GLOB
	GROUP
	HAVING
	IF
	IGNORE
	IMMEDIATE
	IN
	INDEX
	INDEXED
	INITIALLY
	INNER
	INSERT
	INSTEAD
	INTERSECT
	INTO
	IS
	ISNULL
	JOIN
	KEY
	LEFT
	LIKE
	LIMIT
	MATCH
	NATURAL
	NO
	NOT
	NOTNULL
	NULL
	OF
	OFFSET
	ON
	OR
	ORDER
	OUTER
	PLAN
	PRAGMA
	PRIMARY
	QUERY
	RAISE
	RECURSIVE
	REFERENCES
	REGEXP
	REINDEX
	RELEASE
	RENAME
	REPLACE
	RESTRICT
	RIGHT
	ROLLBACK
	ROW
	SAVEPOINT
	SELECT
	SET
	TABLE
	TEMP
	TEMPORARY
	THEN
	TO
	TRANSACTION
	TRIGGER
	UNION
	UNIQUE
	UPDATE
	USING
	VACUUM
	VALUES
	VIEW
	VIRTUAL
	WHEN
	WHERE
	WITH
	WITHOUT
}