#
#	intrinsc.tcl -- the Tcl Command Intrinsics
#
#	Maxim Shkud, August 1994


#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_CreateCommand
# action  :	creates new Tcl command, defines class record if called for
#		the first time
# accepts :	command name, class, class name, additional arguments
# returns :
# notes   :
#***************************************************************************
proc tclInt_CreateCommand {c class className source attr_list args} {
    upvar #0 $c data
    upvar #0 $class classRec
 #  set source [lindex $args 0]

    # CREATE CLASS RECORD IF NECESSARY
    if {[info globals $class] == ""} {
        $class::CreateClassRec
        # construct attributes list, if necessary
        # this call is specific to QeTcl application, it links attribute
        # names to the class record; attribute values are then can be fetched
        # with `attribute(s)` method
        #catch {eval $class::ConstructAttrList  $c $class $source}
        set classname $class
     }
#       if [catch {ConstructAttrList $class $source $attr_list} err] {
#         echo $err
#       }

    # create command record
    tclInt_CreateCommandRec         $c $class $className $source $attr_list
    # bind a method dispatcher procedure to the new command
    tclInt_MkCommand        	   $c
    # load command options (if any)
    eval tclInt_LoadOptions        $c $class $className $args
    # perform command initialization (supported by command creator)
    $class::ConstructCommand  	   $c
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_CreateCommandRec
# action  :	creates command record
# accepts :	command name, class, class name
# returns :
# notes   :
#***************************************************************************
proc tclInt_CreateCommandRec {c class className source attr_list} {
    global defaults
    upvar #0 $c data
    upvar #0 $class classRec

    set data(class)     $class
    set data(className) $className
    set data(root)      $c
    set data(source)    $source
    set data(attrValList) $attr_list
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_LoadOptions
# action  :	loads user-defined config options if given, else default
#		values
# accepts :	command name, class, class name, arguments
# returns :
# notes   :
#***************************************************************************
proc tclInt_LoadOptions {c class className args} {
    upvar #0 $c data
    upvar #0 $class classRec
    # SET UP THE COMMAND RECORD ACCORDING TO DEFAULT VALUES
    foreach option $classRec(options) {
	set o_name    [lindex $classRec($option) 1]
	set o_class   [lindex $classRec($option) 2]
	set o_default [lindex $classRec($option) 3]
        set data($option) $o_default
    }

    # in case any arguments were given to command creation, set up the
    # command record according to command arguments
    set len  [llength $args]
    set len2 [expr {$len - 2}]
    set i 0

    # parse command arguments
    while {$i <= $len2} {
       # get next option-value pair
       set option [lindex $args $i]
       incr i
       set arg [lindex $args $i]
       incr i
       # check if the option is valid
       if {[lsearch $classRec(options) $option] != "-1"} {
          # valid option - set it's value
          set data($option) $arg
       } else {
            error "unknown option $option. Should be: [tclInt_ListOptions $c]"
	 }
    }

    # odd number of parameters?
    if {$i != $len} {
	error "Odd number of config parameters applied to $data(root)"
    }
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_MkCommand
# action  :	creates a command method dispatcher and binds it to the
#		command
# accepts :	command name
# returns :
# notes   :
#***************************************************************************
proc tclInt_MkCommand {c} {
    upvar #0 $c data
    # define command methods dispatcher routine
  proc $c {method args} {
	# the name of the data structure is the same as the procedure
	set c [lindex [info level 0] 0]
	upvar #0 $c data
	upvar #0 $data(class) classRec
	 
        # methods switch
	case $method in {
	    # config is a special method that needs special attention
	    {config configure} {
                # config without args? -- just return option-value pairs
	     	if {$args == {}} {
		       return [tclInt_QueryOptions $c]
    		}
        # set command options according to args provided
		    eval tclInt_ApplyOptions $c $args
	  }
    # delete a command
    {delete} {
         eval tclDeleteCommand $c
    }
    #------get attribute------------------------
    {attr} {
      if {[llength $args] < 1} {
        error "wrong number of parameters
       }
     set param [lindex $args 0]
     if { [lsearch $classRec($data(source)_attributes) [string toupper $param]] != "-1"} {
       if [catch {eval attribute $c [string toupper $param] } res] {
           error $res
        } else {
         return $res
        }
          error "bad method - ( $param ) ,should be:  $classRec(methods) $classRec($data(source)_attributes)"
       }
     }

    # the rest of the methods, provided by command creator, come here
    default {
    # Do the following:
		# 1. Execute the method as if it is a method of the class.
		# 2. If error happens in the execution of 1, check if
		#    the method is supported by the class
		# 3. If yes, then simply output the error message from 1.
		# 4. If no, print the set of methods available from class
		#    command.
	    if [catch {eval $data(class)::[string tolower $method] $c $args} res] {
    	   if {[lsearch $classRec(methods) [string tolower $method]] != "-1"} {
             error $res
		     } else {
             if { [lsearch $classRec($data(source)_attributes) [string toupper $method]] != "-1"} {
               if [catch {eval attribute $c [string toupper $method] } res] {
                   error $res
               }
             } else {
                   error "bad method - ( $method ) ,should be:  $classRec(methods) $classRec($data(source)_attributes)"
             }
	      }
	      # a valid method of the command executed OK, return result
	    }
	    return $res
   	}
  }
}
}
#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_ListOptions
# action  :	lists command options
# accepts :	command name
# returns :	sorted list of command options
# notes   :
#***************************************************************************
proc tclInt_ListOptions {c} {
    upvar #0 $c data
    upvar #0 $data(class) classRec

    return [lsort "$classRec(options)"]
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_QueryOptions
# action  :	queries command options
# accepts :	command name
# returns :	sorted options list
# notes   :
#***************************************************************************
proc tclInt_QueryOptions {c} {
    upvar #0 $c data
    upvar #0 $data(class) classRec

    set options {}

    foreach option $classRec(options) {
       lappend options [lreplace $classRec($option) 3 3 $data($option)]
    }

    return [lsort $options]
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_QueryOption
# action  :	queries specified command option
# accepts :	command name, option name
# returns :	option-value pair
# notes   :
#***************************************************************************
proc tclInt_QueryOption {c option} {
    upvar #0 $c data
    upvar #0 $data(class) classRec

    if {[lsearch $classRec(options) $option] != -1} {
       return [lreplace $classRec($option) 3 3 $data($option)]
    } else {
      error "unknown option $option. Should be: [tclInt_ListOptions $c]"
      }
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclInt_ApplyOptions
# action  :	sets command options to the values given by args
# accepts :	command name, args
# returns :
# notes   :
#***************************************************************************
proc tclInt_ApplyOptions {c args} {
    upvar #0 $c data
    upvar #0 $data(class) classRec

    set len  [llength $args]
    set len2 [expr {$len - 2}]
    set i    0

    # option without value? -- return it's value
    if {$len == 1} {
	return [eval tclInt_QueryOption $c $args]
    }
    # parse args
    while {$i <= $len2} {
       # get next option-value pair
       set option [lindex $args $i]
       incr i
       set arg [lindex $args $i]
       incr i
       # check if it is a value option
       if {[lsearch $classRec(options) $option] != "-1"} {
          # yes -- set the option to the given value
          $data(class)::config$option $c $arg
          set data($option) $arg
       } else {
          error "unknown option $option. Should be: [tclInt_ListOptions $c]"
         }
    }
    # value missing?
    if {$i != $len} {
	error "value for \"$option\" missing"
    }
}

#************************** Procedure Header *******************************
#***************************************************************************
# name    :	tclDeleteCommand
# action  :	deletes specified command
# accepts :	command name to delete
# returns :
# notes   :
#***************************************************************************
proc tclDeleteCommand {c} {
    if {[info commands $c] != {}} {
	rename $c {}
    }
}
#************************* Class Method Header *****************************
proc attribute {c args } {
    upvar  #0 $c data
    upvar  #0 $data(class) class
   # search for a specified attribute
   if {[set attrIndex [lsearch $class($data(source)_attributes) $args]] == -1} {
      error "bad attribute; should be:  $class($data(source)_attributes)"
   }
   return [lindex $data(attrValList) $attrIndex]
}
proc update_attribute {c attr_name value } {
    upvar  #0 $c data
    upvar  #0 $data(class) class
   # search for a specified attribute
   set attr_name [string toupper $attr_name]
   if {[set attrIndex [lsearch $class($data(source)_attributes) $attr_name]] != -1} {
	  set data(attrValList) [lreplace $data(attrValList) $attrIndex $attrIndex $value]
   }
}

#********************************************************
proc ConstructAttrList {class source attr_list} {
   # upvar #0 $c comData
   upvar #0 $class classData
   upvar #0 defaults tableData

   if { [info globals classData(${source}_attributes)] == ""} {

        # 2. get columns names
        # if [catch {qecols $cursor} err_msg] {
        # error $err_msg
        #}
       # 3. set the attributes
       # set classData(${source}_attributes) $tableData(colnames)
         set classData(${source}_attributes) $attr_list
     }

}
# ******************************************************
# name list_table
# calls constructor for each element in list 'raw_list'
# the first parameter in args is the name of constructor
# *******************************************************

proc list_table {raw_list args} {
   if { [llength $args] > 0} {
      set prefix [lindex $args 0]
   }
   set constr [lindex $args 1]
   set source [lindex $args 2]
   set return_list ""
   foreach new_elem $raw_list {
     set object $prefix[lindex $new_elem 0]
     if { [info globals $object] == ""} {
       $constr $object $source $new_elem
     } else {
        global $object
	set ${object}(attrValList) $new_elem
     }
     lappend return_list $object
   }
   return $return_list
 }



# ******************************************
proc nullvalue args {
 global defaults
 if { [llength $args]==1 } {
  set defaults(nullvalue) [lindex $args 0]
 }
  return $defaults(nullvalue)
 }

# **********************************************
# is not used now
# ***********************************************
proc usenullvalue args {
 global defaults
 if { [llength $args]==1 } {
  set defaults(usenullvalue) [lindex $args 0]
 }
  return $defaults(usenullvalue)
 }

# ************************************************
# name  falsevalue
# called without parameter returns the value used
# for FALSE or sets the first parameter as a value
# for FALSE
# **************************************************
proc falsevalue args {
 global defaults
 if { [llength $args]==1 } {
  set defaults(false) [lindex $args 0]
 }
  return $defaults(false)
 }

# ************************************************
# name  truevalue
# called without parameter returns the value used
# for TRUE or sets the first parameter as a value
# for TRUE
# **************************************************

proc truevalue args {
 global defaults
 if { [llength $args]==1 } {
  set defaults(true) [lindex $args 0]
 }
  return $defaults(true)
 }
# *****************************************************
# name emptydatevalue
# called without parameter returns the value used
# for empty date or sets the first parameter as a value
# for empty date
# **************************************************
proc emptydatevalue args {
 global defaults
 if { [llength $args]==1 } {
  set defaults(emptydate) [lindex $args 0]
 }
  return $defaults(emptydate)
 }


proc qecolnames {} {
     global defaults
     return $defaults(colnames)
}

