Artifact 3feaa0ad1a4472b1a35bf4575b5ad4e2cbbd9370:
- File
packages/eav/lib/sqlite.tcl
— part of check-in
[694cd14e71]
at
2020-03-03 22:29:49
on branch trunk
— ycl chan
ycl dir
updates to reflect changes to object system
ycl eav make [gen] duplicates choose the entity with the lowest number as the "original" (user: pooryorick size: 91397)
#! /bin/env tclsh package require {ycl db sqlite util} package require sqlite3 namespace import [yclprefix]::db::sqlite::util::lossless package require {ycl ns} proc eav {name args} { if {![string match ::* $name]} { set name [string trimright [uplevel 1 {namespace current}] :]::$name } try [string map [list \ :arg: [lossless :arg] \ :array: [lossless :array] \ :attribute: [lossless :attribute] \ :count: [lossless :count] \ :eid: [lossless :eid] \ :entity: [lossless :entity] \ :entity2: [lossless :entity2] \ :id: [lossless :id] \ :index: [lossless :index] \ :record: [lossless :record] \ :systemattribute: [lossless :systemattribute] \ :value: [lossless :value] \ ] { variable sql_eav_array_value_exists { select 1 from @array@ where id == :index: } variable sql_eav_array_exists { select 1 from arrays where record = :id: } variable sql_eav_array_select_by_id { select v from @array@ where id == :index: } variable sql_eav_array_select_by_record { select v from @array@ where id == :index: } variable sql_eav_array_id { select array from arrays where record == :eid: } variable sql_eav_array_insert { insert into @array@ values (:index: ,:value:) } variable sql_eav_array_update { update @array@ set v = :value: where rowid == :index: } variable sql_eav_arrays_delete { delete from arrays where record == :record: } variable sql_eav_arrays_delete_by_e { delete from arrays where record in ( select id from eav where e == :entity: ) } variable sql_eav_arrays_delete_by_ea { delete from arrays where record in ( select id from eav where e == :entity: and a == :arg: ) } variable sql_eav_arrays_insert { insert into arrays values(NULL ,:id: , :array:) } variable sql_eav_arrays_select { select array from arrays where record == :record: } variable sql_eav_arrays_select_by_ea { select array from arrays where record in ( select id from eav where e == :entity: and a == :arg: ) order by id desc } variable sql_eav_arrays_select_by_e { select array from arrays where record in ( select id from eav where e == :entity: ) order by id desc } variable sql_eav_clone_insert { insert into eav select NULL ,:entity2: ,a ,v from eav where e = :entity: } variable sql_eav_delete_by_e { delete from eav where e == :entity: } variable sql_eav_delete_by_ea { delete from eav where e == :entity: and a == :arg: } variable sql_eav_insert { insert into eav values (NULL ,:entity: , :attribute: ,:value:) } variable sql_eav_setvalue { update eav set v = :value: where id == :id: } variable sql_eav_incr_update { update eav set v = v + :count: where e == :entity: and a = :attribute: } variable sql_eav_incr_insert { insert into eav values (NULL ,:entity: , :attribute: ,:count:) } variable sql_eav_select_by_e { select a ,v from eav where e == :entity: order by id } variable sql_eav_select_by_ea { select id from eav where e == :entity: and a == :attribute: order by id } variable sql_eav_select_eav { select id from eav where e == :entity: and a == :attribute: and v == :value: order by id } variable sql_eav_sysguard { select 1 from eav where e == :entity: and a == :systemattribute: } variable sql_eav_select_av_by_e_sysguard " select a ,v from eav where e == :entity: and not exists ($sql_eav_sysguard) order by id " variable sql_eav_select_v_by_ea { select v from eav where e == :entity: and a == :attribute: order by id } variable sql_eav_select_v_by_ea_sysguard " select v from eav where e == :entity: and a == :attribute: and not exists ($sql_eav_sysguard) order by id " variable sql_eav_select_id_by_ea { select id from eav where e == :entity: and a == :attribute: order by id } }] namespace eval $name { namespace import [yclprefix]::db::sqlite::util::gen::strquote namespace import [yclprefix]::db::sqlite::util::lossless namespace eval doc {} namespace path [list [uplevel 1 {::namespace current}]] namespace upvar [uplevel 1 {::namespace current}] \ sql_eav_array_value_exists sql_eav_array_value_exists \ sql_eav_array_exists sql_eav_array_exists \ sql_eav_array_id sql_eav_array_id \ sql_eav_array_insert sql_eav_array_insert \ sql_eav_array_select_by_id sql_eav_array_select_by_id \ sql_eav_array_update sql_eav_array_update \ sql_eav_arrays_delete sql_eav_arrays_delete \ sql_eav_arrays_delete_by_e sql_eav_arrays_delete_by_e \ sql_eav_arrays_delete_by_ea sql_eav_arrays_delete_by_ea \ sql_eav_arrays_insert sql_eav_arrays_insert \ sql_eav_arrays_select sql_eav_arrays_select \ sql_eav_arrays_select_by_e sql_eav_arrays_select_by_e \ sql_eav_arrays_select_by_ea sql_eav_arrays_select_by_ea \ sql_eav_clone_insert sql_eav_clone_insert \ sql_eav_delete_by_e sql_eav_delete_by_e \ sql_eav_delete_by_ea sql_eav_delete_by_ea \ sql_eav_insert sql_eav_insert \ sql_eav_incr_update sql_eav_incr_update \ sql_eav_incr_insert sql_eav_incr_insert \ sql_eav_select_by_ea sql_eav_select_by_ea \ sql_eav_select_eav sql_eav_select_eav \ sql_eav_select_by_e sql_eav_select_by_e \ sql_eav_select_av_by_e_sysguard sql_eav_select_av_by_e_sysguard \ sql_eav_select_id_by_ea sql_eav_select_id_by_ea \ sql_eav_select_v_by_ea sql_eav_select_v_by_ea \ sql_eav_select_v_by_ea_sysguard sql_eav_select_v_by_ea_sysguard \ sql_eav_setvalue sql_eav_setvalue \ sql_eav_sysguard sql_eav_sysguard namespace ensemble create -map { and and array array_ clone clone db db ddestroy ddestroy dexists dexists dget dget dinsert dinsert dset dset dunset dunset ensure ensure entities entities except except exists exists find find findm findm flatten flatten gen gen get get id id incr incr_ init init insert insert intersect intersect let let or or set set_ redpill redpill report report revision revision the the trace trace_ union union unset unset_ } variable doc::and { description { Like [or] but composes an intersection query instead of a union query } } proc and {report args} { set t1name [namespace current]::[info cmdcount]_and_t1name transform .new $t1name try { gen $t1name {*}[join $args] set report [report $report $t1name] uplevel 1 [list [namespace which findm] $report $t1name] } finally { unset $t1name } } variable doc::array_ { description { The value of an record may be a reference to an array . Multiple records may reference the same array . An array is automatically deleted when there are no more references to it . } } namespace eval array_ { namespace export * namespace ensemble create namespace ensemble configure [namespace current] -map { eval eval_ exists exists id id link link set set_ size size sweep sweep unlink unlink unset unset_ } namespace eval doc {} namespace import [namespace parent]::checkargs namespace import [yclprefix]::db::sqlite::util::idquote namespace import [yclprefix]::db::sqlite::util::lossless namespace upvar [uplevel 1 {::namespace current}] \ sql_eav_array_value_exists sql_eav_array_value_exists \ sql_eav_array_exists sql_eav_array_exists \ sql_eav_array_id sql_eav_array_id \ sql_eav_array_insert sql_eav_array_insert \ sql_eav_array_select_by_id sql_eav_array_select_by_id \ sql_eav_array_update sql_eav_array_update \ sql_eav_arrays_delete sql_eav_arrays_delete \ sql_eav_arrays_insert sql_eav_arrays_insert \ sql_eav_arrays_select sql_eav_arrays_select variable doc::eval_ {} { usage { eval ARRAYS VARNAMES SCRIPT } description { Iterate over a set of arrays by rowid, evaluating a script for each row, which is comprised of the values in the arrays at the current rowid. ARRAYS is a dictionary where each key is an entity, and each value is a list of attributes, each of which is an array. If a value is "*" (asterisk), all the attributes of that entity that are array values are included. If a key is a list containing more than one item, the first item is the entity, and the second item is string to prepend to the name attribute to form the variable name. SCRIPT is evaluated as a Tcl script once for each row where a value exists for that rowid in one of the columns, and for each column, a variable having the same name as the column is assigned in the current level. The empty string is assigned to the corresponding variable for each column in the row that does not have a value at the current rowid. VARNAMES is a list of names, in this order: (optional) The name of a variable in which to store the rowid (optional) The name of an array variable to populate instead of creating individual variables in the calling level. } } proc eval_ {arrays varnames script} { db transaction { if {[llength $varnames] == 1} { lassign $varnames idxname } elseif {[llength $varnames] == 2} { lassign $varnames idxname varname } else { error [list {wrong # args}] } set i -1 set tables {} dict for {entity attributes} $arrays { set prefix {} if {[string is list $entity] && [llength $entity] > 1} { lassign $entity entity prefix } if {[llength $attributes] == 1 && [lindex $attributes 0] eq {*}} { set attributes [dict keys [ [namespace parent] set $entity]] } [namespace parent] find $attributes entity == $entity \ eval found { set idx [lsearch -exact $attributes $found(a)] set attributes [ lreplace $attributes[set attributes {}] $idx $idx] lappend names "array_$found(v).v as [ idquote $prefix$found(a)]" lappend tables array_$found(v) } if {[llength $attributes]} { error [list {arrays not found for entity} \ $entity $attributes] } } set with "with rows as ( [join [lmap table $tables { lindex "select rowid from $table"}] { union }] ) " set from [list from rows] foreach newtable $tables { lappend from left join $newtable on \ rows.rowid == $newtable.rowid } set query "$with select rows.rowid as $idxname" if {[info exists names]} { append query ", [join $names ,]" } append query " [join $from { }] order by rows.rowid" if {[info exists varname]} { set res [uplevel 1 [ list [namespace current]::db transaction [ list [namespace current]::db eval \ $query $varname $script]]] } else { set res [uplevel 1 [ list [namespace current]::db transaction [ list [namespace current]::db eval $query $script]]] } } } variable doc::exists { description { Indicates whether a value exists at a given index in an array , or if $index is not provided, whether the attribute is the name of an existing array. } } proc exists {entity attribute args} { variable sql_eav_array_value_exists variable sql_eav_array_exists db transaction { if {[llength $args]} { lassign $args index set array [id $entity $attribute] db exists [string map [list @array@ array_$array] \ $sql_eav_array_value_exists] } else { [namespace parent] find $attribute entity == $entity \ like $attribute % eval {} { break } if {[info exists id]} { return [db exists $sql_eav_array_exists] } return 0 } } } variable doc::id { description { Given an entity and an attribute, returns the id of the corresponding array } } proc id {entity attribute} { variable sql_eav_array_id db transaction { set eid [[namespace parent] id $entity $attribute] db eval $sql_eav_array_id {} if {![info exists array]} { error [list {not an array} $entity $attribute] } } return $array } variable doc::link { description { Link an array into another attribute . The source attribute provides the array reference , but beyond that there is no relationship between the original attribute and the attribute that becomes linked to the array . } } proc link {entity1 attribute1 entity2 attribute2} { variable sql_eav_arrays_insert db transaction { if {![exists $entity1 $attribute1]} { error [list {no such array} entity $entity1 \ attribute $attribute1] } set array [id $entity1 $attribute1] if {[exists $entity2 $attribute2]} { if {[id $entity2 $attribute2] eq $array} { # Already linked return } [namespace parent] unset $entity2 $attribute2 } [namespace parent] set $entity2 $attribute2 $array set id [[namespace parent] id $entity2 $attribute2] # {to do} add something to the test suite for this db eval $sql_eav_arrays_insert } } variable doc::removeindex { description { remove the index from an array } } proc removeindex {entity attribute} { set array [id $entity $attribute] db transaction "drop index if exists idx_${array}_v on array_${array}" } variable doc::set_ { description { Create a new array , or retrieve the values in an array . If the array doesn't already exist , the array is is created . If only $entity and $attribute are provided , the entire array is returned as a list . If only $entity , $attribute , and $index are provided , the value in the array at $index is returned . If $values is provided , the items in $values are inserted into the array starting at $index If more than thee arguments are provided, the last argument is a list of values to insert into the array $index can be any of the forms documented for Tcl string indices . If the array doesn't already exist , and the index is one of the "end" forms, it must evaluate to a positive integer . If the arrary is modified, the entity is returned. Otherise, the value at the indicated index is returned. } synopsis { array set entity attribute array set entity attribute index array set entity attribute index ?type $type? ?$values? } args { type { description { The type affinity of the data in the array . } validate { $type in {blob integer numeric real text} } } values { description { A list of values to place in the array } } } } proc set_ {entity attribute args} { variable sql_eav_array_select_by_id variable sql_eav_array_insert variable sql_eav_array_update variable sql_eav_arrays_insert db transaction { if {![llength $args]} { set array [id $entity $attribute] return [db eval "select v from array_$array order by id"] } # Operate on the last matching record if {$entity > -Inf} { if {[[namespace parent] exists $entity $attribute]} { if {[exists $entity $attribute]} { set array [id $entity $attribute] } } } set args [lassign $args[set args {}] index] if {![string is entier $index]} { set terms [scan $index {end%[+-]%lld%s} sign addend junk] if {$terms == 2} { set origindex $index set index end if {$sign eq {-}} { if {[exists $entity $attribute]} { if {[size $entity $attribute]} { set index [db eval "select max(id) from array_$array"] } else { set index 0 } } set index [expr {$index - $addend}] } else { if {[exists $entity $attribute]} { if {[size $entity $attribute]} { set index [db eval "select max(id) from array_$array"] } else { if {$addend == 0} { # index never ends up being greater # than -1 in this case, i.e. isn't past # the "end" of the non-existant array error [list {bad index} $origindex] } set index -1 } } else { if {$addend == 0} { # index never ends up being greater # than -1 in this case, i.e. isn't past # the "end" of the non-existant array error [list {bad index} $origindex] } set index -1 } set index [expr {$index + $addend}] } } elseif {$index eq {end}} { if {[exists $entity $attribute]} { if {[size $entity $attribute]} { set index [db eval "select max(id) from array_$array"] } else { error [list {does not exist in array} \ index $index] } } else { error [list {does not exist in array} \ index $index] } } else { #This handles index expressions set index [expr $index] if {![string is entier $index]} { error [list {bad index} $index] } } } if {![llength $args]} { if {![string is entier $array]} { error [list {not an array} \ entity $entity attribute $attribute] } set query [string map [list @array@ array_$array] \ $sql_eav_array_select_by_id] if {![db exists $query]} { error [ list {does not exist in array} index $index] } return [db eval $query] } if {[llength $args] % 2} { set values [lindex $args end] set args [lrange $args[set args {}] 0 end-1] } set args [dict merge {type {}} $args] dict update args type type {} dict unset args type if {[llength [dict keys $args]]} { error [list {unknown arguments} [ dict keys $args]] } if {![info exists array]} { if {[db exists {select 1 from arrays}]} { set array [db eval { select max(array) + 1 from arrays }] } else { set array 0 } db eval "create table array_$array ( id integer primary key ,v $type) ; create index idx_array_v_$array on array_$array (v) " set entity [ [namespace parent] set $entity $attribute $array] # Operate on the last matching record set id [[namespace parent] id $entity $attribute] db eval $sql_eav_arrays_insert } foreach value $values { db eval [string map [ list @array@ array_$array] $sql_eav_array_update] if {![db changes]} { db eval [string map [list @array@ array_$array] \ $sql_eav_array_insert] } incr index } return $entity } } variable doc::size { description { Returns the number of elements in the array } } proc size {entity attribute} { db transaction { set array [id $entity $attribute] db eval "select count(*) from array_$array" } } proc sweep args { db transaction { foreach arg $args { if {[db exists { select 1 from arrays where array == :arg}]} continue db eval "drop table if exists array_$arg" } } } variable doc::unlink { description { Unlinks an eav record and an array . If no more links to the array remain , it is deleted . } } proc unlink record { variable sql_eav_arrays_select variable sql_eav_arrays_delete db transaction { set array [db eval $sql_eav_arrays_select] if {[llength $array]} { # {to do} add something to the test suite for this db eval $sql_eav_arrays_delete if {[info exists array]} { sweep $array } } } } variable doc::unset_ { description { unset elements in an array, held by $entity and $attribute, where additional arguments are 1 or 2-item lists indicating a range of id's, inclusive. If there is only one item in the list, it indicates a specific id. } } proc unset_ {entity attribute args} { db transaction { set array [id $entity $attribute] set sql {} foreach arg $args { if {[llength $arg] == 1} { set first [lindex $arg 0] set last $first } elseif {[llength $arg] == 2} { lassign $arg first last } else { error [list {bad index specification} $arg] } if {![string is entier $array]} { error [list {bad array identifier} $array] } if {![string is entier $first]} { error [list {bad index} $first] } if {![string is entier $last]} { error [list {bad index} $last] } set first[incr i] $first set last$i $last lappend sql "delete from array_$array where id >= [lossless :first$i] and id <= [lossless :last$i]" } db eval [join $sql {;}] } } } proc clone entity { variable sql_eav_clone_insert db transaction { set entity2 [nextentity] db eval $sql_eav_clone_insert return $entity2 } } variable doc::combine { description { A convenience wrapper over findm. Each argument is a list of arguments that are fed to [gen] to produce a query, after which they are all fed to [findm]. } } proc combine {op transformvar args} { upvar $transformvar transform queriestotables lasttables transform $args combine2 $op lasttables transform } proc combine2 {op lasttablesvar transformvar} { upvar $transformvar transform set counts [dict get $transform counts] set finaltables [dict get $transform tables] upvar $lasttablesvar lasttables set op [dict get { except except intersect intersect union union } $op] set firsttable [lindex $lasttables 0] if {[llength $lasttables] > 1} { lappend combine $op [lindex $lasttables 1] foreach name [lrange $lasttables 2 end] { lappend combine $op $name } } set others $combine lassign $counts i j set mytablename eav[incr i] set query [dict create name $mytablename tables [ dict create $firsttable {}] combine $others] gen_query_finished transform i finaltables eav lasttable \ mytablename query 1 transform set transform tables $finaltables transform set transform counts [list $i $j {*}[lrange $counts 2 end]] return } variable doc::combine_do { description { Uses combine to compose a union query of [gen] queries and execute it via [findm]. } } proc combine_do {op report args} { set t1name [namespace current]::[info cmdcount]_combine_t1name transform .new $t1name try { combine $op $t1name {*}$args set report [report $report $t1name] uplevel 1 [list [ namespace which findm] $report $t1name] } finally { unset $t1name } } proc dotraces {op entity attribute index value} {db transaction { variable system variable active_traces if {$system > 0} return variable systemattribute incr system try { set traces [union * [ list == type trace == op $op == entity {} == attribute {} \ exists $systemattribute] [ list == type trace == op $op == entity {} == attribute $attribute \ exists $systemattribute] [ list == type trace == op $op == entity $entity == attribute {} \ exists $systemattribute] [ list == type trace == op $op == entity $entity \ == attribute $attribute exists $systemattribute]] } on error {cres copts} { incr system -1 return -options $copts $cres } foreach {id e a v p l} $traces[set traces {}] { dict lappend traces $e $a $v } try { foreach trace [dict values $traces] { {*}[dict get $trace cmdprefix] [ namespace current] $op $entity $attribute $index $value } } finally { incr system -1 } }} variable doc::dget { description { like [get] , but $path is processed as described for [dset] . } } proc dget {entity path args} {db transaction { if {![llength $args] && [llength $path]} { lappend args [lindex $path end] set path [lrange $path[set path {}] 0 end-1] } while {[llength $path]} { set path [lassign $path[set path {}] arg] if {[array_ exists $entity $arg]} { set path [lassign $path[set path {}] index] if {[array_ exists $entity $arg $index]} { set entity $index } else { error [ list {no such index in array} $index] } } else { set entity [set_ $entity $arg] } } get $entity {*}$args }} variable doc::ddestroy { description { Like [unset entity] , but follows $path to the entity to unset . And also unsets the attribute in $path that referenced the entity (the penultimate item in $path) } } proc ddestroy {entity args} {db transaction { set entity [dget $entity [lrange $args 0 end-1] [lindex $args end]] dunset $entity [lrange $args 0 end-1] [lindex $args end] unset_ $entity }} variable doc::dexists { description { Like [exists], but $path is processed as described for [dset] } } proc dexists {entity path args} {db transaction { try { dget $entity $path {*}$args } on error {cres copts} { switch [lindex $cres 0] { {no such index in array} - {no such attribute} - {no such attributes} { return 0 } default { return -options $copts $cres } } } return 1 }} variable doc::dinsert { summary { Deep [insert] } description { Like [insert] but follows $path to the target entity the first item in $path is the starting entity, and each subsequent item is an attribute whose value is the next entity } } proc dinsert {entity path args} { dset2 $entity insert $path {*}$args } variable doc::dset { summary { Deep [set] } description { like [set] but follows $path to the target entity the first item in $path is the starting entity each subsequent item is an attribute whose value is the identifier of the next entity } } proc dset {entity path args} { dset2 $entity set_ $path {*}$args } proc dset2 {entity op path args} {db transaction { set index 0 foreach arg $path { if {![exists $entity $arg]} break set entity [set_ $entity $arg] incr index } if {$index < [llength $path]} { if {![llength $args]} { error [list {unknown attribute} [lindex $path $index]] } foreach arg [lrange $path $index end-1] nextarg [ list {*}[lrange $path $index+1 end]] { set newentity [set_ {} $nextarg {}] set_ $entity $arg $newentity set entity $newentity } set args [lassign $args[set args {}] attribute val] set newentity [set_ {} $attribute $val] set_ $entity [lindex $path end] $newentity set entity $newentity if {[llength $args]} { $op $entity {*}$args } return $entity } else { $op $entity {*}$args } }} variable doc::dunset { description { like [unset], but $path is processed as described for [dset] } } proc dunset {entity path args} {db transaction { if {![llength $args] && [llength $path]} { lappend args [lindex $path end] set path [lrange $path[set path {}] 0 end-1] } if {[llength $path]} { # Use [dset] here, not [dget] . lappend newpath $entity set entity [dset $entity [lrange $path 0 end-1] [lindex $path end]] } unset_ $entity {*}$args }} variable doc::ensure { description { If no entity exists with the specified attributes and values , a new one is created . } value { The last entity having attribute $attribute and value $value . } } proc ensure args {db transaction { set args2 {} foreach {attribute value} $args { lappend args2 == $attribute $value } set entities [find {} {*}$args2] if {![llength $entities]} { lappend entities [set_ {} {*}$args] } return [lindex $entities end] }} variable doc::entities { description { Returns the number of entities in the database } } proc entities {} {db transaction { db eval {select count(*) from (select distinct e from eav)} }} if 0 { to do [except] should either be moved to a generic sql utility package or should be reimplemented to operate on [find] specifications rather than [gen] specificaionts i.e. [except] should be performed on the output of the report query the "except" operator to [gen] already provides most (all?) of the functionality that this [except] routine provides } variable doc::except { description { Uses combine to compose a except query of [gen] queries and execute it via [findm]. } } proc except {report args} { uplevel 1 [list [ namespace which combine_do] except $report {*}$args] } variable doc::exists { description { Efficiently determine whether an entity exists , or whether an attribute for a certain etity exists . For more flexibility , see [find] . } } proc exists {entity args} {db transaction { if {[llength $args]} { lassign $args attribute return [db exists { select 1 from eav where e == :entity and a == :attribute}] } else { return [db exists { select 1 from eav where e == :entity }] } }} proc field_sql {resvar datavar fieldvar} { upvar $resvar res upvar $datavar data upvar $fieldvar field set res {} switch [llength $field] { 1 { lappend res [lindex $field 0] } 0 { error {not enough arguments} } 2 { lappend res "[lindex $field 1] as [ lindex $field 0]" } default { gen_query sql2 data [lindex $field 1] lappend res "( {*}$sql2 ) as [ lindex $field 0]" } } return } proc fields_sql {sqlvar fieldsvar datavar} { upvar $sqlvar sql $fieldsvar fields $datavar data if {[info exists fields]} { foreach field $fields { field_sql sqlfield data field lappend sqlfields {*}$sqlfield } } else { lappend sqlfields * } if {![llength $sqlfields]} { error [list {no fields}] } lappend sql {*}[join $sqlfields { , }] return } variable doc::find { description { A wrapper over [gen] and [findm]. Selects entities based on some critera , and report the requested attributes . If a matching entity is missing some attribute specified in $report, that attribute will be missing in the results. See also, [or] . } args { args { report { description { names of attributes to include in the result a name may be an asterisk (*) indicates all attributes the empty string indicates the identifier for the entity itself } } args { search criteria a seqence of operations each operation is composed of an operator defines its own semantics for some number subsequent arguments If there is only one arg it is the name of an attribute operators behaviours description behaviours are not necessarily mutually-exclusive list of behaviours compositor the operator uses new data to transform the structure developer the operator transforms a structure into some abitrary structure expander the operator transforms a structure by adding pieces onto it trimmer the operator transforms a structure by removing pieces of it list {== > < - !=} { description { The next argument is the name of an attribute , and the argument after that is the value of the attribute . } } ascend { description { given an entity follows an attribute of that entity recursively example child == name Bob for entities having the name Bob follows any attributes named child where the value corresponds to the attribute named child of another entity } } descend { description { given an entity find things that have that entity as a given attribute recursively Selects matching records from a hierarchy of entities . The next argument is the name of an attribute to descend on . The argument after that is an operator indicating how the descent attribute in a candidate node must match the key argument in the parent node . The argument after that is the name of the key attribute in the parent node , which is matched using the same operator as for the key attribute in a candidate node . The argument after that is the value descent attribute in a root must match . For example parent == name Bob indicates that an entity having a "parent" attribute of Bob is a root node in the hierarchy , and that the "parent" attribute of a child entity == the value of the "name" attribute in its parent . This operator changes the default sort order of the results to "depth". To set it to "breadth" or the normal "rowid" , use the "order" operator . } } entity { description { Selects certain entities. The next argument is an operator, and the subsequent operand is a natural number. } } eval { description { The next argument is a variable name to pass to [db eval] of sqlite, and the argument after that is a script. The variables from the database are "id", "e", "a", and "v". } } exists { description { The next argument is the name of an attribute. Only entities that have a record for the indicated attribute are selected. } } id { description { Selects certain records. The next argument is an operator, and the subsequent operand is a natural number. } } is { description { The next argument expresses some quality of the attribute , and the argument after that is the name of an attribute . } entity { The next argument identifies the entity. } qualities { missing { The entity does not have such an attribute . } } } like { description { The next argument is the name of an attribute , and the argument after that is a pattern to match . } } matching { description { constrain results to those entities whose values for the given set of attributes are not unique in the eav . } } order { description { A list of operators specifying the sort order of the results . By default , results are in the order of insertion . operators depth { description { If a "descend" operator is present , results are in hierarchical order, depth-first. } } breadth { description { If a "descend" operator is present , results are in hierarchical order, breadth-first. } } attribute { description { The next item in the list is the attribute to sort on. If the item after that is "asc" or "desc", it indicates whether the sort is ascending or descending . } } } } } } } } proc find {report args} { set t1name [namespace current]::[info cmdcount]_find_t1name if {[llength $args] == 1} { set args [list entity == $report[ set report [lindex $args 0]; list]] } transform .new $t1name try { lassign [uplevel 1 [ list [namespace current]::gen $t1name {*}$args]] set report [report $report $t1name] uplevel 1 [list [namespace which findm] $report $t1name] } finally { unset $t1name } } variable doc::findm { description { accepts one or more queries as produced by [gen] stitches them together to form a union query with the semantics of SQL's "union" as opposed to "union all" operation If multiple "script" operators are given, only the last one is effective. } args { args { description { The first item is a query like the second to last items in the list returned by [find]. The second item is a SQL compoound select operator such as "union", "union all", "intersect", or "except". } } } } proc findm {report transformvar} {db transaction { upvar $transformvar transform set tables [dict get $transform tables] findm_prepare data sql $report $tables dict with data {} if {[info exists script]} { set res2 {} set res [db eval $sql] if {[info exists recordvar]} { upvar $recordvar recordvarvar db eval $sql recordvarvar [list uplevel 1 $script] } else { db eval $sql recordvarvar " foreach {key val} \[array get recordvarvar] { uplevel 1 \[list set \$key \$val] } uplevel 1 [list $script] " } } else { set res2 [db eval $sql] if {[dict exists $transform flat] && [dict get $transform flat]} { flatten res2 } } return $res2 }} proc findm_filter_matching {attname tablename} { list $tablename.e in ( \ select filter.e from $tablename as filter \ where \ filter.a = {*}[lossless :$attname] \ and filter.v == ( \ select v from $tablename as filter2 \ where \ filter2.e = $tablename.e \ and filter2.a = {*}[lossless :$attname] \ ) \ order by filter.e limit -1 offset 1 \ ) } proc findm_prepare {datavar queryvar report queries} { upvar $datavar finaldata $queryvar query set selects {} set finaldata {} gen_tables_sql queries sql finaldata if 0 { foreach {tablename select} $select[set select {}] { dict with data {} if 0 { previously complete select statements were passed to this routine when the strategy changed to passing table specifications to compose with clause from this bit became obsolete # Skirt the issue of SQLite constraints on things like ORDER BY # rules in compound select statements by encapsulating each # statement as its own subquery lappend selects "select * from ($select) as eav" } lappend selects "$tablename as ( $select )" } } append query with { } recursive { } [join $sql { , }] gen_query finalreport finaldata $report append query { } $finalreport return } proc flatten varname { upvar $varname var set res {} foreach {id e a v p l} $var[set var {}] { dict update var $e entity { lappend entity $a $v } } return } proc function args { namespace eval :: $args } variable doc::gen { description { Generate a SQL query and a dictionary containing the data it references . } args { counts { description { The next numbers available for forming unique data variable names . Use {0 0} for the first call to [gen], and whatever [gen] produces for subsequent calls. } } report { description { Same as for [find] . } } args { description { Same as for [find] . } } } value { A list containing three items counts Pass to to other [gen] commands to avoid name collisions . query The generated Query . data A dictionary containing data referenced by the query . To import the data into the current level , pass it to [dict with] . } } proc gen {transformvar args} { variable system variable systemattribute # To do: With a little bookkeeping, it should be possible to # massage this code into allowing the caller to specify attributes # to sort on , and in ascending or descending order . upvar 1 $transformvar transform set counts [dict get $transform counts] set computed 0 set limit -1 set missing {} set offset {} set breadthdepth desc lassign $counts i j if {$i > 0} { set eavtable oldeav$i } else { set eavtable eav } set exceptspecs {} set filters {} set orders {} set sort asc set subqueries {} set union {} set with {} set oldeav oldeav[incr i] set tables [dict get $transform tables] set tableroot eav if {[llength $counts] > 2} { set tablename [lindex $counts 2] } else { set tablename $tableroot } set mytablename $tableroot[incr i] set query [dict create name $mytablename tables [ dict create $tablename {}] fields {} terms {} data {}] if {$tablename eq $tableroot} { # make the original table a table with a level and a parent query_defaultfields query $tableroot if {!$system} { set attname [gen_query_data_add query $systemattribute] set term [list $tableroot.e not in ( \ select e from $tableroot \ where \ a == {*}[lossless :$attname] \ and \ v == {*}[lossless :$attname]) \ ] gen_query_term_add query term } gen_query_finished transform i tables $tableroot tablename \ mytablename query 1 } set origtablename $tablename set queryfinished 1 set chain 1 while {[llength $args]} { set args [lassign $args[set args {}] arg] set chain 1 set entjoin == if {$computed == 1} { incr computed } elseif {$computed ==2} { set computed 0 } set query1 {} set term {} set join1 {} set entity 0 set queryfinished 1 set union1 {} if 0 { to do add $ tablename subtitution to more operations } switch $arg { | { set computed 1 set queryfinished 0 } == - > - >= - < - <= - != - like { set args [takeargs $args[set args {}] attribute pattern] set attname [gen_query_data_add query $attribute] if {$pattern eq {$}} { set args [takeargs $args[set args {}] tablename2] set query1 [list $tablename.e in ( \ select e from $tablename t2 where \ t2.a = {*}[lossless :$attname] \ and t2.v $arg \ ( select * from $tablename2 ) \ ) \ ] } else { set query1 [list $tablename.e in ( \ select $tablename.e from $tablename \ where $tablename.a = {*}[ lossless :$attname] and $tablename.v $arg] set pattname [gen_query_data_add query $pattern] lappend query1 {*}[lossless :$pattname] lappend query1 ) } gen_query_term_add query query1 gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 } as { set args [takeargs $args[set args {}] arg] #lassign $arg as$i func attribute$i lassign $arg as func attribute set attname [gen_query_data_add query $attribute] set asname [gen_query_data_add query $as] set term1 [list a != {*}[lossless :$asname]] gen_query_term_add query term1 set table1 $mytablename gen_query_finished transform i tables $tableroot \ tablename mytablename query 0 set term1 [list a = {*}[lossless :$attname]] gen_query_term_add query term1 switch $func { max { set vexpr [list \ ( select ${func}(t2.v) \ from $tablename as t2 \ where a = {*}[lossless :$attname] \ ) ] } abs - hex - length - lower - max - trim - upper { set vexpr [list ${func}($tablename.v)] } default { error [list {unknown function} $func] } } newfields newfields [ dict get [lindex $tables end] fields] gen_as_newfields newfields $as $vexpr dict set query fields $newfields set union1 [list select * from $table1] dict lappend query unions $union1 } ascend { set args [takeargs $args[set args {}] ascend] set ascend [uplevel 1 [namespace which list] $ascend] set ascend [takeargs $ascend[ set ascend {}] follow op pattern] set followname [gen_query_data_add query $follow] if {$op eq {entity}} { #dict set query distinct 1 set op $pattern set ascend [takeargs $ascend[set ascend {}] pattern] set patternname [gen_query_data_add query $pattern] dict set query spec { e parent level path } dict set query fields [list \ $tablename.v [list p [list ( \ select v from $tablename as t1 \ where t1.e = $tablename.v \ and a = {*}[lossless :$followname] \ )]] 0 {{printf(' %s ' ,e)}} \ ] set term1 [list $tablename.e = {*}[ lossless :$patternname]] gen_query_term_add query term1 set term1 [list a = {*}[lossless :$followname]] gen_query_term_add query term1 if 0 { to do add breadthdepth control here } set union1 [list \ select $tablename.v ,( \ select v from $tablename as t1 \ where t1.e = $tablename.v \ and a = {*}[lossless :$followname] \ ) ,$mytablename.level+1 \ , printf(' %s %s ' ,$mytablename.path ,v) \ from $tablename join $mytablename using(e) \ where $tablename.a = {*}[lossless :$followname] \ and instr($mytablename.path ,printf(' %s ' ,$tablename.v)) == 0 \ ] dict lappend query unions $union1 dict lappend query order [list 3] #dict lappend query order [list 3 {*}$breadthdepth] gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 dict set query fields [list \ $tablename.e $tablename.parent \ $tablename.level \ [list rownum [list row_number() over ()]] \ $tablename.path \ ] gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 set jterm [list $origtablename.e = $tablename.e] lappend jterms $jterm dict set join1 terms $jterms dict set query tables $tablename join [list $origtablename $join1] dict set query fields [list \ $origtablename.id $origtablename.e \ $origtablename.a $origtablename.v \ $tablename.parent $tablename.level \ [list rownum [list ( \ select min (t2.rownum) \ from $tablename as t2 \ where $tablename.e = t2.e \ ) ]] \ $tablename.path \ ] transform add transform order [ list $mytablename rownum] #gen_query_finished transform i tables $tableroot \ # tablename mytablename query 0 if 0 { # the old version lappend join1 ( with recursive \ r$i\(e ,parent ,level ,path) as ( \ select v ,( \ select v from $oldeav as eav1 \ where eav1.e = $oldeav.v \ and a = {*}[lossless :follow$i] \ ) ,0 ,printf(' %s ' ,e) \ from $oldeav where e = {*}[lossless :$patternname] \ and a = {*}[lossless :follow$i] \ union \ select $oldeav.v ,( \ select v from $oldeav as eav1 \ where eav1.e = $oldeav.v \ and a = {*}[lossless :follow$i] \ ) ,r$i.level+1 \ , printf(' %s %s ' ,r$i.path ,v) \ from $oldeav join r$i using(e) \ where $oldeav.a = {*}[lossless :follow$i] \ and instr(r$i.path ,printf(' %s ' ,$oldeav.v)) == 0 \ order by 2 \ ) \ select r$i.e, parent, level from r$i \ order by r$i.level \ ) as eav$i on $oldeav.e == eav$i.e } } else { set attribute $pattern set attname [gen_query_data_add query $attribute] set ascend [takeargs $ascend[set ascend {}] pattern] set patternname [gen_query_data_add query $pattern] dict set query spec { e name parent level path } dict set query fields [list \ $tablename.e $tablename.v [list p [list ( \ select e from $tablename as t1 where \ a = {*}[lossless :$attname] and \ t1.v = ( \ select v from $tablename as t2 \ where e = $tablename.e \ and a = {*}[lossless :$followname] \ ) \ ) \ ]] 0 {{printf(' %s ' ,e)}} \ ] set term1 [list $tablename.a = {*}[ lossless :$attname]] gen_query_term_add query term1 set term1 [list \ $tablename.v = ( \ select v from $tablename \ where a = {*}[lossless :$followname] \ and e in ( \ select e from $tablename \ where a = {*}[lossless :$attname] \ and v = {*}[lossless :$patternname] \ ) \ ) \ ] gen_query_term_add query term1 set union1 [list \ select $tablename.e ,$tablename.v ,( \ select e from $tablename as eav1 where \ e != $tablename.e \ and a = {*}[lossless :$attname] \ and v = ( \ select v from $tablename as eav2 \ where e = $tablename.e \ and a = {*}[ lossless :$followname] \ ) \ ) ,$mytablename.level+1 \ , printf(' %s %s ' ,$mytablename.path ,v) \ from $tablename ,$mytablename \ where \ $tablename.e = $mytablename.parent \ and a = {*}[lossless :$attname] \ and instr( \ $mytablename.path \ ,printf(' %s ' ,$tablename.v) \ ) == 0 order by 4 \ ] dict lappend query unions $union1 gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 dict set query fields [list \ $tablename.e $tablename.parent \ $tablename.level \ [list rownum [list row_number() over ()]] \ $tablename.path \ ] gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 dict set query tables $origtablename {} dict set query fields [list \ $origtablename.id $origtablename.e \ $origtablename.a $origtablename.v \ $tablename.parent $tablename.level \ [list rownum [list ( \ select min (t2.rownum) \ from $tablename as t2 \ where $tablename.e = t2.e \ ) ]] \ $tablename.path \ ] set term1 [list \ $origtablename.e = $tablename.e ] gen_query_term_add query term1 transform add transform order [ list $mytablename rownum] } } att { set args [takeargs $args[set args {}] attribute] dict set query fields v if {$attribute eq {$}} { set args [takeargs $args[ set args {}] tablename2 attribute] set attname [gen_query_data_add query $attribute] dict set query tables [dict create $tablename2 {}] set term1 [list $tablename2.a = :$attname] gen_query_term_add query term1 set chain 0 set queryfinished 0 } else { error [list what are we doing in this branch?] set attname [gen_query_data_add query $attribute] set term1 [list $tablename.a = :$attname] gen_query_term_add query query1 } } descend { # Until such time as SQLite detects cycles, the # limits in the queries below guard against cycles # Update: Now using printf and path to detect cycles #set dlimit 1000 set dlimit -1 set args [takeargs $args[set args {}] descend] if {$descend eq {limit}} { set args [takeargs $args[set args {}] dlimit descend] } set descend [uplevel 1 list $descend] if {[llength $descend] == 4} { lassign $descend \ follow op attribute pattern set followname [gen_query_data_add query $follow] } elseif {[llength $descend] == 3} { lassign $descend \ op attribute pattern } else { error [list {wrong # args}] } # In the queries below, the initial values for both # level and parent must be 0 so that they match the # output of non-recursive selects when they are used # in complex queries, i.e. those involving "except" . # If tempted to add additional sorting, beware of # breaking hierarchically-ordered results . set patternname [gen_query_data_add query $pattern] dict set query distinct 1 # rownum is a dummy here # the next query provides the rownum of this traversal dict set query spec { id e a v parent level rownum path } dict set query fields [list \ $tablename.id $tablename.e $tablename.a \ $tablename.v 0 0 0 \ {{printf(' %s ' ,e)}} \ ] if {$op eq {entity}} { set realop $attribute if {$realop ni {!= ==}} { error [ list {operator should be ==} not $realop] } } else { set realop $op } if {[info exists followname]} { dict lappend query terms [list \ $tablename.e in ( \ select e from $tablename \ where \ a = {*}[lossless :$followname] \ and v $realop {*}[lossless :$patternname] \ ) ] } else { dict lappend query terms [list \ $tablename.e in ( \ select e from $tablename \ where \ v $realop {*}[lossless :$patternname] \ ) ] } set union1 [list \ select distinct $tablename.id ,$tablename.e ,$tablename.a \ ,$tablename.v ,$mytablename.e ,$mytablename.level+1 \ ,0 ,printf(' %s %s ' ,$mytablename.path ,$tablename.e) \ from $tablename , $mytablename where \ ] if {$op eq {entity}} { if {[info exists followname]} { lappend union1 \ $tablename.e in ( \ select e from $tablename as t2 where \ t2.a = {*}[lossless :$followname] \ and t2.v $realop $mytablename.e \ ) } else { lappend union1 \ $tablename.e in ( \ select e from $tablename as t2 where \ t2.v $realop $mytablename.e \ ) } } else { set attributename [gen_query_data_add query $attribute] lappend union1 \ $mytablename.a = {*}[lossless :$attributename] \ and exists ( \ select * from $tablename as t2 \ where t2.e == $tablename.e \ and t2.a = {*}[lossless :$followname] \ and t2.v $realop $mytablename.v \ ) } lappend union1 and instr($mytablename.path , \ printf(' %s ' ,$tablename.e) ) == 0 dict lappend query unions $union1 dict lappend query order [list 6 {*}$breadthdepth] dict set query limit $dlimit gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 dict set query fields [list \ $tablename.id $tablename.e $tablename.a $tablename.v \ $tablename.parent $tablename.level \ [list rownum [list row_number() over ()]] \ $tablename.path \ ] gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 dict set query fields [list \ $tablename.id $tablename.e $tablename.a $tablename.v \ $tablename.parent $tablename.level \ [list rownum [list ( \ select min (t2.rownum) \ from $tablename as t2 \ where $tablename.e = t2.e \ ) ]] \ $tablename.path \ ] transform add transform order [ list $mytablename rownum] if 0 { to do can this call to gen_query_finished be deleted? } gen_query_finished transform i tables $tableroot \ tablename mytablename query 0 } duplicated { set args [takeargs $args[set args {}] attribute] set attname [gen_query_data_add query $attribute] set query1 [findm_filter_matching $attname $tablename] gen_query_term_add query query1 gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 } entity { set args [takeargs $args[set args {}] attribute pattern] set pattname [gen_query_data_add query $pattern] switch $attribute { == - > - >= - < - <= - != - like { lappend query1 $tablename.e $attribute {*}[ lossless :$pattname] gen_query_term_add query query1 } default { error [list {unknown operator} $attribute] } } } eval { set args [takeargs $args[set args {}] recordvar script] dict set query data script $script if {$recordvar ne {}} { dict set query data recordvar $recordvar } } except { set args [takeargs $args[set args {}] exceptspec] set tname [namespace current]::[ info cmdcount]_gen_except transform .new $tname try { transform set $tname counts [list $i $j {*}[ lrange $counts 2 end]] gen $tname {*}$exceptspec set newtables [dict get [set $tname] tables] transform set $transform tables $newtables set newcounts [dict get [set $tname] counts] lassign $newcounts i j transform set $transform counts [list $i $j {*}[ lrange $counts 2 end]] set report [report * $tname] } finally { unset $tname } findm_prepare newdata newsql $report $newtables dict set query data [dict merge [ dict get $query data] $newdata] set rtable [lindex $newtables end-1] set query1 [list $tablename.e not in ( \ select e from ( {*}$newsql ) \ ) ] gen_query_term_add query query1 } exists { set args [takeargs $args[set args {}] attribute] set attname [gen_query_data_add query $attribute] set query1 [list $tablename.e in ( \ select e from $tablename \ where a == {*}[lossless :$attname] \ )] gen_query_term_add query query1 } id { set args [takeargs $args[set args {}] attribute pattern] set pattname [gen_query_data_add query $pattern] switch $attribute { == - > - >= - < - <= - != - like { set term1 [list $tablename.id $attribute {*}[ lossless :$pattname]] gen_query_term_add query term1 } default { error [list {unknown operator} $attribute] } } } in { set args [lassign $args[set args {}] attribute pattern] set attname [gen_query_data_add query $attribute] foreach inpattern $pattern { set pattname [gen_query_data_add query $inpattern] lappend query1 [list $tablename.e in ( \ select e from $tablename as t2 \ where t2.a == {*}[lossless :$attname] \ and t2.v == {*}[lossless :$pattname] ) ] } set query1 ([join $query1 { or }]) gen_query_term_add query query1 } is { set args [lassign $args[set args {}] attribute$i pattern$i] switch [set attribute$i] { missing { lappend missing :pattern$i } default { error [list {unknown pattern for "is"} [ set attribute$i]] } } } limit { set args [lassign $args[set args {}] limit] if {[dict exists $query offset]} { gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 } dict set query limit $limit set queryfinished 0 } offset { set args [takeargs $args[set args {}] offset] if {[dict exists $query offset]} { gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 } dict set query offset $offset set queryfinished 0 } order { set args [takeargs $args[set args {}] neworder] if 0 { to do isn't this routine mixing up two different "order" controls? } switch $neworder { depth { set breadthdepth desc } breadth { set breadthdepth {} } default { dict lappend transform userorder [ list $tablename {*}$neworder] } } } sort { set args [takeargs $args[set args {}] neworder] switch [lindex $neworder end] { asc - desc { transform add transform userorder [ list $tablename {*}$neworder] } default { error [list {unknown order} $neworder] } } } walk { set args [takeargs $args[set args {}] follow] set followname [gen_query_data_add query $follow] dict set query spec { id e a v parent level } dict set query fields [list $tablename.id \ $tablename.e $tablename.a $tablename.v \ $tablename.parent [list level 0]] set term1 [list $tablename.e in ( \ select t2.v from $tablename as t2 \ where t2.e in ( \ select t3.e from $tablename as t3 \ where t3.e = {*}[lossless :$followname] \ ) \ ) \ ] gen_query_term_add query term1 #dict lappend query order [list $tablename.e] [ # list $tablename.id] set union1 [list all \ select distinct $tablename.id ,$tablename.e \ ,$tablename.a ,$tablename.v ,$mytablename.e \ ,$mytablename.level + 1 \ from $tablename ,$mytablename \ where $tablename.e = $mytablename.v \ order by $tablename.e ,$tablename.id] dict lappend query unions $union1 gen_query_finished transform i tables $tableroot \ tablename mytablename query 1 if 0 { to do add cycle detection } dict set query fields [list \ $tablename.id $tablename.e $tablename.a $tablename.v \ $tablename.parent $tablename.level \ [list rownum [list row_number() over ()]] \ ] transform add transform order [ list $mytablename rownum] } default { error [list {unknown operator} $arg] } } if {$query1 ne {}} { lappend join inner join $oldeav as eav$i on \ $oldeav.e $entjoin eav$i.e and {*}$query1 } if {$join1 ne {}} { lappend join join {*}$join1 } if {$union1 ne {}} { lappend union $union1 } incr i if {$queryfinished} { gen_query_finished transform i tables $tableroot \ tablename mytablename query $chain } } if {!$queryfinished} { gen_query_finished transform i tables $tableroot tablename \ mytablename query $chain } if 0 { to do make sure $join is properly processed } transform set transform counts [ list $i $j {*}[lrange counts 2 end]] transform set transform tables $tables return } proc gen_as_newfields {newfieldsvar as vexpr} { upvar $newfieldsvar newfields foreach newfield $newfields[set newfields {}] { switch [lindex $newfield 0] { a { lappend newfields [list a [strquote $as]] } id { lappend newfields [list id 0] } v { if 0 { to do eliminate this join somehow } lappend newfields [list v [join $vexpr]] } default { lappend newfields $newfield } } } } proc gen_as_newfields2 {newfieldsvar as vexpr} { upvar $newfieldsvar newfields foreach newfield $newfields[set newfields {}] { switch [lindex $newfield 0] { a { lappend newfields [list a [strquote $as]] } id { lappend newfields [list id 0] } v { if 0 { to do eliminate this join somehow } lappend newfields [list v [join $vexpr]] } default { lappend newfields $newfield } } } } proc gen_orderspec {queryvar tablename orders} { upvar $queryvar query foreach order1 $orders { if {[llength $order1] < 2} { error [list [list order should have at least \ a table name and a column name]] } if {[llength $order1] > 3} { error [list {too many words in order}] } lassign $order1 otable ocolumn odir if {![dict exists tables $otable]} { dict set query tables $otable {} } set term1 [list $tablename.id = $otable.id] gen_query_term_add query term1 set spec $otable.$ocolumn dict lappend query order [list $spec {*}$odir] } return } proc gen_query {sqlvar datavar qinfo} { upvar $sqlvar sql $datavar data set sql {} set sqlfields {} dict update qinfo combine combine distinct distinct \ fields fields limit limit name name offset offset \ order order spec spec tables tables terms terms \ unions unions with with {} if {[info exists name]} { lappend sql $name if {[info exists spec]} { lappend sql ( {*}[join $spec { , }] ) } lappend sql as ( } if {[info exists with]} { lappend sql {*}$with } lappend sql select if {[info exists distinct] && $distinct} { lappend sql distinct } fields_sql sql fields data lappend sql from set sqltables [list] foreach {tablename tinfo} $tables { set sqltable {} if {[dict exists $tinfo being]} { set being [dict get $tinfo being] switch [llength $being] { 1 { lappend sqltable [lindex $being 0] } 0 { error [list {empty alias}] } default { lappend sqltable ( {*}$being ) } } lappend sqltable as $tablename } else { lappend sqltable $tablename } if {[dict exists $tinfo join]} { foreach {joinname jinfo} [dict get $tinfo join] { if {[dict exists $jinfo being]} { set alias $joinname set joinname [dict get $jinfo being] } lappend sqltable join switch [llength $joinname] { 0 { error [list {empty join}] } 1 { lappend sqltable [lindex $joinname 0] } default { gen_query sql2 data $joinname lappend sqltable ( {*}$sql2 ) } } if {[dict exists $jinfo being]} { lappend sqltable as $alias } lappend sqltable on set jterms [dict get $jinfo terms] lappend sqltable {*}[join $jterms { and }] } } if {[llength $sqltable]} { lappend sqltables $sqltable } } lappend sql {*}[join $sqltables { , }] if 0 { limit applies to entities not to individual attributes } if {[info exists offset]} { if {![info exists limit]} { set limit -1 } set offset [linsert $offset[set offset {}] 0 offset] } else { set offset {} } if {[info exists limit]} { lappend terms [list $tablename.e in ( \ select distinct e from $tablename limit {*}$limit \ {*}$offset \ )] } if {[info exists terms] && [llength $terms]} { lappend sql where ( lappend sql {*}[join $terms { ) and ( }] lappend sql ) } if {[info exists unions]} { foreach union $unions { lappend sql union {*}$union } } if {[info exists order]} { lappend orders {*}[join [lmap order1 $order { join $order1 { } }] { , }] } if {[info exists orders]} { lappend sql order by {*}$orders } if {[info exists combine]} { foreach {op table} $combine { lappend sql $op select * from $table } } if {[info exists name]} { lappend sql ) } if {[dict exists $qinfo data]} { set data [dict merge $data[set data {}] [ dict get $qinfo data]] } return } proc gen_query_finished { transformvar countervar tablesvar tableroot tablenamevar mytablenamevar queryvar chain } { upvar $countervar counter $mytablenamevar mytablename \ $tablenamevar tablename $tablesvar tables \ $queryvar query $transformvar transform if {[dict size $query]} { if {[dict exists $query fields]} { set fields [dict get $query fields] } if {![info exists fields] || ![llength $fields]} { set qtables [dict get $query tables] set tablename [lindex [lindex [dict keys $qtables] end] 0] #set fields [list $tablename.*] set fields [list id e a v parent level path] dict set query fields $fields } lappend tables $mytablename $query if {$chain} { set tablename $mytablename transform table last transform $tablename } set mytablename $tableroot[incr counter] if 0 { to do don't create a new query here and then rewrite the loop in [gen] to be a little less awkward } set prev $query set query [dict create name $mytablename tables [ dict create $tablename {}] fields {} terms {} data {}] newfields newfields [dict get $prev fields] dict set query fields $newfields } return } proc gen_query_data_add {queryvar value} { variable counter upvar $queryvar query set name d_${value}_[incr counter] # the counter ensures this transformation doesn't corrupt the input # data set regsub -all {[^[:alnum:]_]} $name[set name {}] {} name dict set query data $name $value return $name } proc gen_query_join_add {queryvar tablename joinname jinfo} { upvar $queryvar query set tinfo [dict get $query tables $tablename] dict lappend tinfo join $joinname $jinfo dict set query tables $tablename $tinfo return } proc gen_query_term_add {queryvar componentvar} { upvar $queryvar query $componentvar component dict lappend query terms $component set component {} return } proc gen_tables_sql {tablesvar sqlvar datavar} { upvar $tablesvar tables $sqlvar sql $datavar data set sql [list] foreach {queryname qinfo} $tables { gen_query query data $qinfo lappend sql $query } return } variable doc::get { description { Retrieve certain attributes of an entity , as a list, in the same order as specified . If there are multiple records for an attribute only the last is returned . } } proc get {entity args} {db transaction { if {[llength $args]} { set res {} foreach {id atts} [find $args entity == $entity] { foreach {a v} $atts { set idx [lsearch $args $a] set args [lreplace $args[set args {}] $idx $idx] dict set res $a $v } } if {[llength $args]} { error [list {no such attributes} $args] } return [dict values $res] } else { set res [dict values [set_ $entity]] } return $res }} proc incr_ {entity attribute args} {db transaction { variable sql_eav_incr_update variable sql_eav_incr_insert if {[llength $args]} { set count [lindex $args 0] } else { set count 1 } db eval $sql_eav_incr_update if {![db changes]} { db eval $sql_eav_incr_insert } set res [set_ $entity $attribute] return $res }} variable doc::init { description { } args { fname { description { The name of the database file . If not provided , the database will be in-memory . } } dbinit { description { An initialization routine for the database } } systemattribute { description { Entities with a record where the attribute is $systemattribute are reserved for internal use by the system, and can not be accessed by clients using the commands that constitute the API to system . id (rowid) is guaranteed to be lower for records inserted earlier . } } enable_traces { description { A boolean value that indicates whether traces should be enabled . } } } } proc init args { variable system 0 variable active_traces {} variable systemattribute variable enable_traces dict update args dbinit dbinit fname fname systemattribute systemattribute {} foreach arg [dict keys $args] { if {$arg ni {dbinit fname systemattribute}} { error [list {unknown argument} $arg] } } if {![info exists fname]} { set fname :memory: } if {![info exists systemattribute]} { set systemattribute \x10 } if {![info exists enable_traces]} { set enable_traces 1 } sqlite3 [namespace current]::db $fname db function eav [namespace current]::function namespace export db namespace eval array_ { namespace import [namespace parent]::db } namespace export {} if {[info exists dbinit]} { db eval $dbinit } db transaction { # autoincrement ensures a monotonic rowid , even in the face of # record delteion . eav semantics depend on this monotonic # rowid . db eval { PRAGMA cache_size=-50000 ; create table if not exists eav ( id integer primary key autoincrement , e integer , a text , v ) ; create index if not exists idx_eav_att on eav (a) ; create index if not exists idx_eav_att_val on eav (a ,v) ; drop index if exists idx_eav_ent ; drop index if exists idx_eav_ent_att ; create index if not exists idx_eav_eav on eav (e ,a ,v) ; create index if not exists idx_eav_ent_val on eav (e ,v) ; create index if not exists idx_eav_val on eav (v) ; create table if not exists arrays ( id integer primary key autoincrement , record numeric , array numeric , unique (record , array) ) ; create index if not exists idx_arrays_record on arrays (record) ; create index if not exists idx_arrays_array on arrays (array) } set state [redpill { ensure $systemattribute $systemattribute type eav }] } } variable doc::id { description { Return a unique identifier for the record in the eav table for the given attribute of the given entity, or, -1 if there is no such attribute. If both and attribute and a value are specified, only an attribute having the specified value matches. } } proc id {entity args} {db transaction { variable sql_eav_select_by_ea variable sql_eav_select_eav if {[llength $args] == 2} { lassign $args attribute value # {to do} {write a test that fails if this isn't ordered by id} db eval $sql_eav_select_eav { # $id gets set # Find the last matching $id } if {[info exists id]} { return $id } error [list {no id found}] } elseif {[llength $args] == 1} { lassign $args attribute db eval $sql_eav_select_by_ea { # $id gets set # Find the last matching $id } if {[info exists id]} { return $id } error [list {no id found}] } error [list {wrong # args}] }} proc insert {entity attribute value} {db transaction { db eval { insert into eav values (NULL ,:entity ,:attribute ,:value) } set_ $entity $attribute }} variable doc::intersect { description { Uses combine to compose a union query of [gen] queries and execute it via [findm]. } } proc intersect {report args} { uplevel 1 [list [ namespace which combine_do] intersect $report {*}$args] } proc let {transformvar name args} { upvar $transformvar transform if {[dict exists $transform tables $name]} { error [list {already exists} $name] } if {[dict exists $transform lasttable]} { set current [transform table last transform] } gen transform {*}$args if {[info exists current]} { transform table last transform current } else { if {[dict exists $transform lasttable]} { dict unset transform lasttable } } set tables [dict get $transform tables] set lastname [lindex [dict keys $tables] end] if {[dict exists $transform tables $name]} { dict unset $transform $tables $lasname error [list {already exists} $name] } set lasttable [dict get $transform tables $lastname] dict set lasttable name $name dict set transform tables $name $lasttable return } proc nextentity {} {db transaction { # Make sure the cached representation is numeric . Otherwise , # sqlite can end up storing the value as a non-numeric value , # which could cause things like if {[db exists {select 1 from eav}]} { set entity [ db onecolumn {select max(e) + 1 from eav}] } else { set entity [expr 1] } return $entity }} proc newfields {resvar fields} { upvar $resvar res set res {} foreach field $fields { set field [lindex [ split [lindex $field[set field {}] 0] .] end] lappend res [lindex $field 0] } return } variable doc::queriestotables { description { transform a list of eav queries into a dictionary of sql queries } } proc queriestotables {lasttablesvar transformvar exprs} { upvar $lasttablesvar lasttables $transformvar transform set counts [dict get $transform counts] set finaltables [dict get $transform tables] while {[llength $exprs]} { set exprs [lassign $exprs[set exprs {}] arg] set t1name [namespace current]::[info cmdcount]_queriestotables_t1name transform .new $t1name transform set $t1name counts $counts try { gen $t1name {*}$arg set counts [dict get [set $t1name] counts] set tables [dict get [set $t1name] tables] } finally { unset $t1name } lappend finaltables {*}$tables lappend lasttables [lindex $tables end-1] } transform set transform tables $finaltables transform set transform counts $counts return } proc query_defaultfields {queryvar from} { upvar $queryvar query dict set query fields [ list id e a v {parent 0} {level 0} {path ''} ] } proc redpill script { variable system incr system try { uplevel 1 $script } finally { incr system -1 } } proc report {report transformvar} { upvar 1 $transformvar transform set tables [dict get $transform tables] #set tablename [lindex $tables end-1] set tablename [dict get $transform lasttable] if 0 { # useful for testing set finaldata {} gen_tables_sql tables sql2 finaldata dict with finaldata {} set sql2 "with recursive [join $sql2 { , }]" set t2 [lindex $tables end-3] append sql2 \n append sql2 [list select * from $t2] db eval $sql2 r { # debugging statements } } dict set query tables [dict create $tablename {}] switch $report { * - {} { dict set query flat 0 dict set query fields [list $tablename.id $tablename.e \ $tablename.a $tablename.v \ $tablename.parent $tablename.level] switch $report { {} { if 0 { to do look into what it would take to get rid of distinct here } dict set query distinct 1 dict set query fields [list $tablename.e] } } } default { dict set transform flat 1 dict set query fields [ list $tablename.id $tablename.e $tablename.a \ $tablename.v $tablename.parent $tablename.level] if {[llength $report]} { set orjoins {} foreach item $report { set valname [gen_query_data_add query $item] lappend orjoins [list $tablename.a = {*}[ lossless :$valname]] } set query1 [join $orjoins { or }] gen_query_term_add query query1 } } } if 0 { recursive queries create a traversal order rownum preserves this order $tablename.id provides a critical feature of the system records added later occur later in the results i.e. if an entity as two values for an attribute the most recent value occurs in the results last } if {[dict exists $transform userorder]} { gen_orderspec query $tablename [ dict get $transform userorder] } set orders [dict get $transform order] if {[llength $orders]} { #if {[dict exists tables eav]} { # set query2name eav[incr i] # set query2 [dict create $name $query2name tables eav] # set term1 [list $eav.id = $tablename.id] # gen_query_term_add query2 term1 # query_defaultfields query2 eav # dict set tables $query2name $query2 #} gen_orderspec query $tablename $orders } #dict lappend query order [list $tablename.rownum asc] #dict lappend query order [list $tablename.level asc] dict lappend query order [list $tablename.e asc] dict lappend query order [list $tablename.id asc] return $query } variable doc::revision { desciption { Execute a command with revision set to $revision . } } proc revision {tmprevision args} { variable revision set prevrevision $revision catch [list uplevel 1 [namespace current] {*}$args] cres copts set revision $prevrevision return -options $copts $cres } variable doc::set_ { synopsis { set entity set entity attribute set entity attribute value ... } description { Assign or retrieve attributes and values for an entity . If an indicated attribute already exists , the new value is assigned to all existing records for that attribute . Otherwise , a new attribute record is created with that value . } value { The value of the last record for $entity where attribute is $attribute , or if no specific attribute is requested , a dictionary of attributes and values for the entity . } } proc set_ {entity args} {db transaction { variable enable_traces variable sql_eav_insert variable sql_eav_setvalue variable system variable systemattribute variable sql_eav_select_by_e variable sql_eav_select_av_by_e_sysguard variable sql_eav_select_id_by_ea variable sql_eav_sysguard variable sql_eav_select_v_by_ea variable sql_eav_select_v_by_ea_sysguard if {[llength $args] == 0} { set where [list e == :entity] if {$system > 0} { # {to do} add something to the test suite for this return [db eval $sql_eav_select_by_e] } else { # Order by id to ensure that the returned list is ordered # according to insertion sequence set res [db eval $sql_eav_select_av_by_e_sysguard] if {![llength $res]} { error [list {no such entity} $entity] } return $res } } elseif {[llength $args] == 1} { set attribute [lindex $args 0] } elseif {[llength $args] % 2} { error {wrong # args} } else { if {![string is entier -strict $entity]} { set entity [nextentity] } if {$system < 1 && [db exists $sql_eav_sysguard]} { error [ list {unauthorized attempt to modify a system entity}] } foreach {attribute value} $args { if {$system < 1 && $attribute == $systemattribute} { error [list \ {unauthorized attempt to create a system entity}] } dotraces write $entity $attribute {} $value # Operate on the last matching record set id {} db eval $sql_eav_select_id_by_ea record { set id $record(id) } if {![string is entier -strict $id]} { db eval $sql_eav_insert } else { db eval $sql_eav_setvalue # Even if the new value is the same as the old value # the fact that [set_] was called rather than array set # indicates that the new value is not a reference to an # array . array_ unlink $id } } return $entity } if {$system > 0} { set res [db eval $sql_eav_select_v_by_ea] } else { set res [db eval $sql_eav_select_v_by_ea_sysguard] } if {![llength $res]} { if {![exists $entity]} { error [list {no such entity} $entity] } error [list {no such attribute} $attribute] } return [lindex $res end] }} proc takeargs {values args} { if {[llength $values] < [llength $args]} { error {wrong # args} } uplevel 1 [list lassign $values {*}$args] } variable doc::the { description { like [find] but returns an error if there is more than one matching entity } } proc the {names args} { set res [dict create] set res [find $names {*}$args] if {![llength $names]} { if {[llength $res] > 1} { error [list {more than one entity found}] } return [lindex $res 0] } if {[llength $names] == 1 & [lindex $names 0] eq {*}} { flatten res } if {[dict size $res] == 1} { set res2 [lindex [dict values $res] 0] if {[llength $names] == 1} { switch [lindex $names 0] { * { return $res2 } } return [lindex [dict values $res2] 0] } elseif {[llength $names] == 0} { switch $names { {} { return [lindex [dict keys $res] 0] } default { error [list {blank space instead of attributes}] } } } return $res2 } elseif {[dict size $res] == 0} { error [list {entity not found}] } else { error [list {more than one entity found}] } error [list {this error is impossible}] } variable doc::trace_ { description { Register a trace . } args { op { description { The operator to set the trace on values write unset } } entity { description { The id of the entity to call the trace for . The empty string indicates any entity . } } attribute { description { The attribute to call the trace for . The empty string indicatesany attribute . } } cmdprefix { description { A list of words comprising the first part of a command to call when the trace is triggered . If cmdprefix is empty , the specified trace is removed . } } } } proc trace_ {op entity attribute cmdprefix} {db transaction { variable system variable systemattribute variable types if {$op ni {write unset}} { return code error [list {unknown operation} $op] } redpill { if {[llength $cmdprefix]} { ensure $systemattribute 1 type trace op $op \ entity $entity attribute $attribute cmdprefix $cmdprefix } else { set trace [find {} == type trace == op $op \ == entity $entity \ == attribute $attribute exists $systemattribute] unset_ $trace } } }} variable doc::union { description { Uses combine to compose a union query of [gen] queries and execute it via [findm]. } } proc union {report args} { uplevel 1 [list [ namespace which combine_do] union $report {*}$args] } proc unset_ {entity args} {db transaction { variable sql_eav_arrays_delete_by_e variable sql_eav_arrays_delete_by_ea variable sql_eav_arrays_select_by_e variable sql_eav_arrays_select_by_ea variable sql_eav_delete_by_e variable sql_eav_delete_by_ea if {[llength $args]} { foreach arg $args { dotraces unset $entity $arg {} {} # Seems reasonable to order descending to delete arrays in # reverse order of creation . set arrays [db eval $sql_eav_arrays_select_by_ea] db eval $sql_eav_arrays_delete_by_ea db eval $sql_eav_delete_by_ea if {[llength $arrays]} { array_ sweep {*}$arrays } } } else { dotraces unset $entity {} {} {} db transaction { set arrays [db eval $sql_eav_arrays_select_by_e] db eval $sql_eav_arrays_delete_by_e db eval $sql_eav_delete_by_e if {[llength $arrays]} { array_ sweep {*}$arrays } } } }} } $name init {*}$args return $name } namespace eval transform { namespace export * namespace ensemble create namespace eval . { namespace export * proc .new datavar { upvar 1 $datavar data set data [dict create counts {0 0} order {} tables {} \ tableroot eav] return } proc add {datavar key val} { upvar $datavar data switch $key { order - userorder { if {[dict exists $data $key] && $val in [dict get $data $key]} { error [list {already exists} $val] } dict lappend data $key $val } default { error [list {bad key} $key] } } } proc merge {t1var t2var} { upvar $t1var t1 $t2var t2 if {[dict exists $t2 counts]} { dict set t1 counts [dict get $t2 counts] } if {[dict exists $t2 order]} { dict lappend t1 order {*}[dict get $t2 order] } if {[dict exists $t2 tables]} { dict lappend t1 tables {*}[dict get $t2 tables] } dict set t1 lasttable [dict get $t2 lasttable] return } namespace ensemble create -command table -map { add table_add last table_last unique table_unique } proc table_add {transformvar key val} { upvar $transformvar transform set counts [dict get $transform counts] set tables [dict get $transform tables] if {[dict exists $tables $key]} { error [list {table exists} $key] } dict set tables $key $val dict set transform tables $tables return } proc table_last {transformvar args} { upvar $transformvar transform switch [llength $args] { 0 {} 1 { dict set transform lasttable [lindex $args 0] } default { error [list {wrong # args}] } } dict get $transform lasttable } proc table_unique {transformvar resvar} { upvar $transformvar transform upvar $resvar res set counts [dict get $transform counts] lassign $counts i incr i lset counts 0 $i set tableroot [dict get $transform tableroot] set res $tableroot$i return } proc set_ {datavar key args} { upvar 1 $datavar data switch $key { counts - tables { switch [llength $args] { 1 { dict set data $key [lindex $args 0] } 0 {} default { error [list {wrong # args}] } } dict get $data $key } default { error [list {bad key} $key] } } } } namespace import .::.new namespace import .::add namespace import .::merge namespace import .::table namespace import .::set_ rename [namespace current]::set_ set }