Added assert and Scheduler, and started adding proper test frameworks

[tcl-tlc.git] / scripts / datasource.itcl

# vim: ft=tcl foldmarker=<<<,>>>

#       item_schema example:    <<<
#               variable item_schema            {
#                       "Schema"                {schema}
#                       "Table"                 {table combobox \
#                                               -choices {sql_features sql_languages sql_packages} \
#                                               -initial_choice sql_languages
#                       }
#                       "Owner"                 {owner}
#                       "Has Indexes"   {indexed checkbutton}
#                       "Has Rules"             {ruled checkbutton}
#                       "Has Triggers"  {hastriggers checkbutton}
#               }
# >>>

class tlc::Datasource {
        inherit tlc::Handlers

        constructor {args} {}
        destructor {}

        public {
                variable criteria               {}
                variable criteria_values        ""
                variable quote                  1
                variable id_column              0       ;# column to use as the ID column
                variable criteria_map   {}
                variable defaults               {}
                variable item_schema    {}
                
                method get_item_schema {}
                method set_criteria_map {mapping}
                method get_criteria     {}
                method set_criteria {arraylist}
                method get_criteria_values {}
                method set_criteria_values {arraylist}
                method set_field_defs {arraylist}
                method get_field_defs {}
                method set_defaults {rowarray}
                method get_defaults {}
                
                method get_list {criteria {headersvar {}}}
                method get_labelled_list {criteria {headersvar {}}}
                method get_id_column {}
                method add_item {row {col_list ""}}
                method update_item {oldrow newrow {old_col_list ""} {new_col_list ""}}
                method remove_item {row {col_list ""}}
                method extract_id {row}
                method get_full_row {id}
                method can_do {action args}

                method lookup {key match {mode -exact}}
                method slice {column args}
        }

        protected {
                variable can_do
                variable acriteria
                variable acriteria_values
                variable last_headers           {}
                
                method replace_criteria {str {criteria_arraylist {}} 
                                                                        {recursion_level 0}}
                method resolve_row {row col_list}
                method criteria_changed {}
        }
}


body tlc::Datasource::constructor {args} { #<<<1
        array set can_do        {}

        eval configure $args
}


body tlc::Datasource::destructor {} { #<<<1
        invoke_handlers destroyed
}


body tlc::Datasource::replace_criteria {str {criteria_arraylist {}} {recursion_level 0}} { #<<<1
# TODO: figure out a "proper" way to allow substitutions, and still allow
#                       1) %var% strign literals that match to pass through
#                       2) a barrier against infinite recursion

        set ret $str
        if {$criteria_arraylist=={}} {
                set driving_force $criteria_values
        } else {
                set driving_force $criteria_arraylist
        }
        set map_directives {}
        array set valmappings $criteria_map
        foreach {idx val} $driving_force {
                if {[info exists valmappings($idx)]} {
                        array set tmp $valmappings($idx)
                        if {[info exists tmp($val)]} {
                                lappend map_directives "%${idx}%" "$tmp($val)"
                        } else {
                                lappend  map_directives "%${idx}%" "$val"
                        }
                } else {
                        lappend map_directives "%${idx}%" "$val"
                }
        }
        set ret [string map "$map_directives" "$str"]
        # now, check for recursive re-inclusion of criteria within criteria only
        foreach {idx val} $criteria_values {
                if {[string first "%$idx%" $ret]>-1} {
                        if {$recursion_level<5} {
                                set ret [replace_criteria $ret $driving_force 
                                                        [incr recursion_level]]
                        }
                        break
                }
        }
        return $ret
}


body tlc::Datasource::get_criteria {} { #<<<1
        # this basically gives the form defination give from the intersection of
        # the Criteria value and the names of the field_defs array-var

        return $criteria
}


body tlc::Datasource::get_criteria_values {} { #<<<1
        return $criteria_values
}


body tlc::Datasource::set_criteria {arraylist} { #<<<1
        # sets the criteria (and acriteria) from an array-style list.  the list
        # element style is: {criteria_label} {criteria_varname {form style}}

        set criteria $arraylist
}


body tlc::Datasource::set_criteria_values {arraylist} { #<<<1
        # sets the replacement values for the criteria tokenlist from an
        # array-style list the list element style is:
        #       {criteria_varname} {variable_value}

        set criteria_values $arraylist
}


body tlc::Datasource::set_field_defs {arraylist} { #<<<1
        set field_defs $arraylist
}

body tlc::Datasource::get_field_defs {} { #<<<1
        return $field_defs
}

body tlc::Datasource::resolve_row {row col_list} { #<<<1
        # resolves a list of values (row) and a column name list (col_list) into an
        # array-style list
        # inputs: row (raw data list); col_list: column names for items in row
        # returns: array-style list of the style: {col_name} {col_value}

        foreach col $col_list val $row {
                lappend ret $col $val
        }

        return $ret
}


body tlc::Datasource::get_labelled_list {criteria {headersvar {}}} { #<<<1
        # does the same as a get_list, but each row contains interleaved
        # header-names with each field; makes the loading of an array or a treeview
        # structure a lot easier for the client

        if {$headersvar != {}} {
                upvar $headersvar headers
        }
        set rawlist             [get_list $criteria headers]
        set llist               ""
        foreach rawrow $rawlist {
                set lrow        ""
                foreach rawcol $rawrow head $headers {
                        lappend lrow $head $rawcol
                }
                lappend llist $lrow
        }

#       puts "\n\nDatasource::get_labelled_list: returning: ($llist)"
        return $llist
}


body tlc::Datasource::get_list {criteria {headersvar {}}} { #<<<1
}


body tlc::Datasource::get_id_column {} { #<<<1
        return [list $id_column [lindex $last_headers $id_column]]
}


body tlc::Datasource::add_item {row {col_list {}}} { #<<<1
}


body tlc::Datasource::update_item {oldrow newrow {old_col_list ""} {new_col_list ""}} { #<<<1
}


body tlc::Datasource::remove_item {row {col_list ""}} { #<<<1
}


body tlc::Datasource::extract_id {row} { #<<<1
        return [lindex $row $id_column]
}


body tlc::Datasource::criteria_changed {} { #<<<1
}


body tlc::Datasource::set_criteria_map {mapping} { #<<<1
        set criteria_map $mapping
}


body tlc::Datasource::get_item_schema {} { #<<<1
        return $item_schema
}

body tlc::Datasource::set_defaults {rowarray} { #<<<1
        set defaults $rowarray
}

body tlc::Datasource::get_defaults {} { #<<<1
        return $defaults
}

body tlc::Datasource::get_full_row {id} { #<<<1
# purpose: to return all fields defined in the filed definitions for the id specified -- to be used
#       by a client who will be doing an update later
# returns: array-style list of {col} {val} {col} {val} ...
#       this is to be implemented by the client
}

body tlc::Datasource::can_do {action args} { #<<<1
        if {[llength $args] == 0} {
                return [expr {[info exists can_do($action)] && $can_do($action)}]
        } elseif {[llength $args] == 1} {
                set can_do($action)     [expr {[lindex $args 0]}]
        } else {
                error "Wrong # of args: must be action ?newvalue?"
        }
}


body tlc::Datasource::lookup {key match {mode -exact}} { #<<<1
        switch -- $mode {
                -exact -
                -glob -
                -regexp {}

                default {
                        error "Invalid match mode: \"$mode\", must be one of -exact, -glob or -regexp" "" [list bad_match_mode $mode]
                }
        }

        set rows        [get_list {} headers]

        set idx         [lsearch $headers $key]
        if {$idx == -1} {
                error "Invalid key: \"$key\", must be one of \"[join $headers {", "}]\""
        }

        if {[package vsatisfies $::tcl_version 8.5]} {
                set matches     [lsearch -all -inline $mode -index $idx $rows $match]
        } else {
                set matches     {}
                foreach row $rows {
                        switch $mode -- [lindex $row $idx] $match {
                                lappend matches $row
                        } default {
                                continue
                        }
                }
        }

        set build       {}
        foreach row $matches {
                set a   {}
                foreach h $headers v $row {
                        lappend a       $h $v
                }
                lappend build   $a
        }

        return $build
}


body tlc::Datasource::slice {column args} { #<<<1
        # slice returns all instances of a column in the datasource, sorted
        # to taste

        set raw [get_list {} headers]

        # Check that the specified column is valid <<<
        if {[lsearch $headers $column] == -1} {
                error "Invalid slice column \"$column\", should be one of ([join $headers {, }])" "" \
                                [list invalid_column $column]
        }
        # Check that the specified column is valid >>>

        # Parse options <<<
        set sortcolumn  $column
        set sortmode    "dictionary"
        set sortdir             increasing

        set remaining   $args
        while {[llength $remaining] > 0} {
                set option              [lindex $remaining 0]
                set remaining   [lrange $remaining 1 end]

                if {[string index $option 0] != "-"} {
                        error "Expecting an option, got \"$option\"" "" [list syntax_error]
                }

                switch -- $option {
                        -orderby - -sort { #<<<
                                set sortcolumn  [lindex $remaining 0]
                                set remaining   [lrange $remaining 1 end]

                                if {[lsearch $headers $sortcolumn] == -1} {
                                        error "Specified sort column ($sortcolumn) doesn't exist.  Should be one of ([join $headers {, }])" "" \
                                                        [list invalid_sortcolumn $sortcolumn $headers]
                                }

                                if {[string index [lindex $remaining 0] 0] != "-"} {
                                        set sortdir             [lindex $remaining 0]
                                        set remaining   [lrange $remaining 1 end]

                                        switch -- $sortdir {
                                                asc - ascending - increasing {
                                                        set sortdir             increasing
                                                }

                                                desc - descending - decreasing {
                                                        set sortdir             decreasing
                                                }

                                                default {
                                                        error "Invalid sortdir specified: ($sortdir)" "" \
                                                                        [list invalid_sortdir $sortdir]
                                                }
                                        }
                                }
                                #>>>
                        }

                        -sortmode { #<<<
                                set sortmode    [lindex $remaining 0]
                                set remaining   [lrange $sortmode 1 end]

                                switch -- $sortmode {
                                        ascii - dictionary - integer - real {}

                                        default {
                                                error "Invalid sortmode: \"$sortmode\"" "" \
                                                                [list invalid_sortmode $sortmode]
                                        }
                                }
                                #>>>
                        }

                        default {
                                error "Invalid option \"$option\"" "" \
                                                [list invalid_option $option]
                        }
                }
        }
        # Parse options >>>

        set sort_col_idx        [lsearch $headers $sortcolumn]
        set slice_col_idx       [lsearch $headers $column]

        set build       {}
        foreach row [lsort -$sortmode -$sortdir -index $sort_col_idx $raw] {
                lappend build   [lindex $row $slice_col_idx]
        }

        return $build
}