#
# pm.tcl
#
#  install_postmaster
#  pm_to_tcl
#  tcl_to_pm

#
# install_postmaster
#
# This routine creates a copy of the postmaster in tcl
#
#
proc install_postmaster {} {
    global pm

    # instantiate and load the tcl postmaster
    set pm(types) {INT INT_LIST DBL DBL_LIST STRNG STRNG_LIST FNCT ADDRS}
    set pm(gettypes) {INT INT_LIST DBL DBL_LIST STRNG STRNG_LIST}
    set pm(objects) [get_pm_obj_names]
    foreach obj $pm(objects) {
	upvar #0 $obj o
	foreach type $pm(types) {
	    set o($type) [get_pm_elem_names $obj $type]
	}
	# create functions
	foreach fn $o(FNCT) {
	    set name "$obj\($fn\)"
	    proc $name {} "begin_wait; pm EXEC $obj.$fn; end_wait"
	}

	# remove elements that we don't want to work with automatically
	if { [llength [info procs "pm_remove($obj)"] ] == 1} {
	    eval "pm_remove($obj)"
	}

    }
    

    # load up the tcl postmaster 
    pm_to_tcl
}



#
# pm_to_tcl
#
# Loads elements from postmaster into tcl
#
proc pm_to_tcl args {
    global pm

    if {[llength $args]} {
#	puts "pm_to_tcl $args"
	set objs $args
    } else {
#	puts "pm_to_tcl ALL"
	set objs $pm(objects)
    }

    foreach obj $objs {
	pm_to_tcl_obj $obj
    }
}

#
# tcl_to_pm
#
proc tcl_to_pm args {
    global pm

    if {[llength $args]} {
#	puts "tcl_to_pm $args"
	set objs $args
    } else {
#	puts "tcl_to_pm ALL"
	set objs $pm(objects)
    }
    foreach obj $objs {
	tcl_to_pm_obj $obj
    }
}

#
# add new pm objects
#
#    new_tcl_pm Obj1 Obj2 ...
#
proc new_tcl_pm args {
    global pm
    foreach obj $args {
	upvar #0 $obj o
	lappend pm(objects) $obj
	foreach type $pm(types) {
	    set o($type) [get_pm_elem_names $obj $type]
	}
	# create functions
	foreach fn $o(FNCT) {
	    set name "$obj\($fn\)"
	    proc $name {} "begin_wait; pm EXEC $obj.$fn; end_wait"
	}
    }
}

#
# remove pm objects
#
#    remove_tcl_pm Obj1 Obj2 ...
#
proc remove_tcl_pm args {
    global pm
    foreach obj $args {
	upvar #0 $obj o
	set i [lsearch -exact $pm(objects) $obj]
	if {$i >= 0} {
	    set pm(objects) [lreplace $pm(objects) $i $i]
	}
	unset o
    }
}


##########################################################
#
# utility routines for working with the pm in tcl
#
#
##########################################################

#
# get_pm_obj_names
#
# Returns a list of all objects in the postmaster
#
proc get_pm_obj_names {} {
    set i 0
    set objs {}
    while { [set obj [pm QUERY {} PM_OBJECT $i]] != ""} {
	lappend objs $obj
	incr i
    }
    return $objs
}

#
# get_pm_elem_names
#
# Returns a list of all elements of a specified type in a specified object
#
proc get_pm_elem_names {object type} {
    set i 0
    set elems {}
    while { [set elem [pm QUERY $object $type $i]] != ""} {
	lappend elems [join [lreplace [split $elem .] 0 0] .]
	incr i
    }
    return $elems
}

#
# pm_to_tcl_obj
#
# Loads elements from one postmaster object into tcl
#
proc pm_to_tcl_obj obj {
    global pm

    upvar #0 $obj o
    foreach type $pm(gettypes) {
	if [regexp {_LIST$} $type] {
	    foreach elem $o($type) {
		set o($elem) [pm QUERY $obj.$elem LIST_SIZE]
		for {set i 0} {$i < $o($elem)} {incr i} {
		    set o($elem,$i) [pm GET $obj.$elem $i]
		}
	    }
	} else {
	    foreach elem $o($type) {
		set o($elem) [pm GET $obj.$elem]
	    }
	}
    }
    # call any special routines based on objects
    if { [llength [info procs "addto($obj)"] ] == 1} {
	eval "addto($obj)"
    }
}

#
# tcl_to_pm_obj
#
# Loads elements from tcl into one postmaster object
#
proc tcl_to_pm_obj obj {
    global pm

    upvar #0 $obj o
    foreach type $pm(gettypes) {
	if [regexp {_LIST$} $type] {
	    foreach elem $o($type) {
		for {set i 0} {$i < $o($elem)} {incr i} {
		    pm PUT $obj.$elem $i $o($elem,$i)
		}
	    }
	} else {
	    foreach elem $o($type) {
		pm PUT $obj.$elem $o($elem)
	    }
	}
    }
}

#
# dump
#
# Dump contents of tcl postmaster!
#
proc dump {args} {
    global pm

    if {[llength $args]} {
	set objs $args
    } else {
	set objs $pm(objects)
	puts [format "\n%s %s" "Postmaster objects:" [join $objs]]
    }
    foreach obj $objs {
	dump_obj $obj
    }
}

proc dump_obj obj {
    global pm

    upvar #0 $obj o
    puts "\n $obj"
    foreach type $pm(types) {
	foreach elem $o($type) {
	    puts -nonewline [format "   %-18s %-14s" $elem $type]
	    if { [lsearch $pm(gettypes) $type] != -1} {
		if [regexp {_LIST$} $type] {
		    puts [array_to_listvalues $obj $elem]
		} else {
		    puts $o($elem)
		}
	    } else {
		puts ""
	    }
	}
    }
}


proc pm_remove(Mult) {} {
    pm_rem Mult DBL_LIST Ic Fc
}


proc pm_rem {obj type args} {
    upvar #0 $obj o

    foreach arg $args {
	set n [lsearch -exact $o($type) $arg]
	if {$n >= 0} {
	    set o($type) [lreplace $o($type) $n $n]
	}
    }
}