Added custom field type support to Form

[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}
        }

        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?"
        }
}