# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package uobj 0.3
# Meta as::author      {Emmanuel Frecon}
# Meta as::build::date 2015-03-24
# Meta as::license     BSD
# Meta as::origin      http://sourceforge.net/projects/til
# Meta description     This module contains procedures to build
# Meta description     pseudo-objects on top of the standard namespace
# Meta description     system, without any other object orientation than
# Meta description     creation through dash prefix options and regular
# Meta description     arrays.
# Meta platform        tcl
# Meta require         {Tcl 8.4}
# Meta require         logger
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.4
package require logger

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide uobj 0.3

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# uobj.tcl -- Micro-Object system
#
#	This module contains procedures to build pseudo-objects on top
#	of the standard namespace system, without any other object
#	orientation than creation through dash prefix options and
#	regular arrays.
#
# Copyright (c) 2004-2006 by the Swedish Institute of Computer Science.
#
# See the file 'license.terms' for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require Tcl 8.4
package require logger

namespace eval ::uobj {
    variable UOBJ
    if { ! [info exists UOBJ] } {
	array set UOBJ {
            comments         "\#!;"
	    loglevel         warn
	}
	variable log [::logger::init [string trimleft [namespace current] ::]]
	variable libdir [file dirname [file normalize [info script]]]
	${log}::setlevel $UOBJ(loglevel)
    }
    namespace export loglevel
}


# ::uobj::loglevel -- Set/Get current log level.
#
#	Set and/or get the current log level for this library.
#
# Arguments:
#	loglvl	New loglevel
#
# Results:
#	Return the current log level
#
# Side Effects:
#	None.
proc ::uobj::loglevel { { loglvl "" } } {
    variable UOBJ
    variable log

    if { $loglvl != "" } {
	if { [catch "${log}::setlevel $loglvl"] == 0 } {
	    set UOBJ(loglevel) $loglvl
	}
    }

    return $UOBJ(loglevel)
}


# ::uobj::logsupport -- Creates appropriate loglevel procedure
#
#	This procedure installs the necessary procedure and variables
#	to enhance a module with logger support.  The procedure
#	installed will be called loglevel and will either set or
#	return the loglevel whether it is called with an argument or
#	not.  The module is supposed to have a global array for state
#	storage and will also be donated with a global array for
#	storing the logger context.
#
# Arguments:
#	nmspace	Namespace of module to enhance with logger support
#	lvlstr	Name of global array in external module that contains context
#	dftlvl	Default log level for module, if not already set
#	logstr	Name of global variable in external module for logger context
#	lvlidx	Index in global array for current level storage
#
# Results:
#	None
#
# Side Effects:
#	Will create procedures and variables in external namespace!
proc ::uobj::install_log { nmspace lvlstr {dftlvl "warn"} {logstr "log"} {lvlidx "loglevel"}} {
    variable UOBJ
    variable log

    # Trim the namespace name in case
    set nmspace [string trimleft $nmspace ::]
    ${log}::info "Adding logger support to $nmspace (defaulting to '$dftlvl')"

    # Create the logger context and store it in the variable "logstr"
    # in the external namespace module
    if { ! [info exists ::${nmspace}::${logstr}] } {
	set ::${nmspace}::${logstr} [::logger::init $nmspace]
	${log}::debug "Started logger as [set ::${nmspace}::${logstr}]"
    }
    
    # Create the index in the global array of the external namespace
    # module and initialise its associated logger module.
    if { ! [info exists ::${nmspace}::${lvlstr}($lvlidx)] } {
	set ::${nmspace}::${lvlstr}($lvlidx) $dftlvl
	set l [set ::${nmspace}::${logstr}]
	${l}::setlevel $dftlvl
	${log}::debug \
	    "Created current level storage as ::${nmspace}::${lvlstr}($lvlidx)"
    }

    # Now create loglevel procedure in external module.
    eval [string map [list @nmspace@ $nmspace \
			  @lvlstore@ $lvlstr \
			  @logstore@ $logstr \
			  @lvlidx@ $lvlidx] {
	proc ::@nmspace@::loglevel { {loglvl ""} } {
	    variable @lvlstore@
	    variable @logstore@

	    if { $loglvl ne "" } {
		if { [catch {${@logstore@}::setlevel $loglvl}] == 0 } {
		    set @lvlstore@(@lvlidx@) $loglvl
		}
	    }

	    return $@lvlstore@(@lvlidx@)
	}
    }]
}


# ::uobj::install_defaults -- Create module defaults get/set
#
#	This procedure installs a procedure called "defaults" in the
#	namespace passed as an argument.  The procedure bridges the
#	configuration facilities below and offer to get and/or set
#	options for the whole module
#
# Arguments:
#	nmspace	Namespace of module to enhance with defaults support
#	dftstr	Name of global array in external module that contains context
#
# Results:
#	(see config below)
#
# Side Effects:
#	None.
proc ::uobj::install_defaults { nmspace dftstr } {
    variable UOBJ
    variable log

    # Trim the namespace name in case
    set nmspace [string trimleft $nmspace ::]
    ${log}::info "Adding support for defaults options to $nmspace"

    eval [string map [list @nmspace@ $nmspace @dftstr@ $dftstr] {
	proc ::@nmspace@::defaults { args } {
	    variable @dftstr@

	    return [eval ::uobj::config @dftstr@ "-*" $args]
	}
    }]
}


# ::uobj::config -- Options get/set configurator
#
#	This procedure is a helper to get or set options in an
#	"object", i.e. a regular Tcl array.  The options concerned are
#	all those that will match the list of patterns passed (which
#	often will be "-*", i.e. all indices in the array starting
#	with a dash).  Called with no arguments, the configurator will
#	return a list containing all the options and their value
#	(ready for an array set command).  Called with one single
#	argument and if this argument is an option, the helper will
#	return the value of that option only if it is one.  Otherwise,
#	the arguments is considered to be a list of pairs (array set
#	style) of options and values, which will be set into the
#	incoming object.
#
# Arguments:
#	obj_p	"Pointer" to object (i.e. regular Tcl array)
#	pattns	List of patterns describing the options in the array
#	args	None, one or list of pairs, as explained above
#
# Results:
#	List of options with their value, current value for an option
#	or nothing depending on the action that was taken.
#
# Side Effects:
#	Will sometimes modify the array which name is passed as a
#	parameter.
proc ::uobj::config { obj_p pattns args } {
    variable UOBJ
    variable log

    # Get to the array.
    upvar $obj_p Object

    # See to have all matching options concerned by the operation in
    # "alloptions"
    set alloptions [list]
    foreach ptn $pattns {
	set alloptions [concat $alloptions [array names Object $ptn]]
    }
    set alloptions [lsort -unique $alloptions]

    # Now get or set options, depending on args
    set result ""
    if { [llength $args] == 0 } {          ;# Return all results
	foreach name $alloptions {
	    lappend result $name $Object($name)
	}
    } else {
	foreach {opt value} $args {        ;# Get one or set some
	    if { [lsearch $alloptions $opt] == -1 } {
		return -code error \
		    "Unknown option $opt, must be: [join $alloptions ", " ]"
	    }
	    if { [llength $args] == 1 } {  ;# Get one config value
		set result $Object($opt)
		break
	    }
	    set Object($opt) $value        ;# Set the config value
	}
    }

    return $result
}


# ::uobj::inherit -- Inherit options/values between arrays
#
#	This procedure copies all options (and their respective
#	values) from the parent array into the child array.  The
#	options that are copied are the ones that matches all the list
#	of patterns that is passed as a parameter.
#
# Arguments:
#	parent_p	"pointer" to parent array
#	child_p 	"pointer" to child array
#	patterns	List of patterns for options to be copied
#	restrict	List of patterns for options not to be copied
#
# Results:
#	None
#
# Side Effects:
#	None.
proc ::uobj::inherit { parent_p child_p {patterns "-*"} {restrict ""}} {
    variable UOBJ
    variable log

    upvar $parent_p parent
    upvar $child_p child

    foreach ptn $patterns {
	foreach opt [array names parent $ptn] {
	    set copy 1
	    foreach r $restrict {
		if { [string match $r $opt] } {
		    set copy 0
		}
	    }
	    if { $copy } {
		set child($opt) $parent($opt)
	    }
	}
    }
}


# ::uobj::readconfig -- Read and apply configuration parameters.
#
#	This procedure reads configuration parameters from a file
#	containing, apart from comments, lines of key value settings.
#	The keys are understood to be divided by a "." separator where
#	the left part is the name of (any module) and the right part
#	the name of a dash option, without the leading dash.  If the
#	module implements a "defaults" command and support the option,
#	the value from the file will automatically be given to the
#	default setting.  This allows to set defaults settings for a
#	number of modules in a go.
#
# Arguments:
#	fname	Full path to file
#
# Results:
#	Returns a list of pairs module option for all options that
#	were effectively set to a value.
#
# Side Effects:
#	None.
proc ::uobj::readconfig { fname } {
    variable UOBJ
    variable log
    
    set dfts [list]
    ${log}::info "Reading configuration file from '$fname'"
    if { [catch {open $fname} fd] } {
	${log}::warn "Could not read configuration from '$fname': $fd"
    } else {
	while { ! [eof $fd] } {
	    set line [string trim [gets $fd]]
	    if { $line ne "" } {
		set firstchar [string index $line 0]
		if { [string first $firstchar "\#!;"] < 0 } {
		    set key [lindex $line 0]
		    set val [lindex $line 1]
		    set k [split $key "."]
		    set module [lindex $k 0]
		    set opt "-[lindex $k 1]"
		    if { [string range $module 0 1] ne "::" } {
			set nmspace "::$module"
		    } else {
			set nmspace "$module"
		    }
		    if { [namespace exists $nmspace] } {
			if { [info commands ${nmspace}::defaults] ne "" } {
			    if { [catch {${nmspace}::defaults $opt \
					     $val} err] } {
				${log}::warn \
				    "ERROR: could not set ${key} to $val: $err"
			    } else {
				lappend dfts ${module} ${opt}
			    }
			} else {
			    ${log}::warn "ERROR: no defaults for $module"
			}
		    } else {
			${log}::warn "ERROR, no namespace $module"
		    }
		}
	    }
	}
	close $fd
    }

    return $dfts
}


# ::uobj::snapshot -- Module options snapshot
#
#	This procedure will create a snapshot of a program's module's
#	default options, typically in order to be able to restore
#	these at a later point.  The procedure will store all dash led
#	options for all known namespaces which are a direct child of
#	the main namespace.  Only those modules that respond to the
#	defaults command will be concerned by the snapshot,
#	i.e. module that are using the services of this very library.
#
# Arguments:
#	None
#
# Results:
#	The procedure return a serialised array with the snapshot of
#	all the options and their values.
#
# Side Effects:
#	None.
proc ::uobj::snapshot {} {
    variable UOBJ
    variable log

    ${log}::info "Creating program defaults module snapshot"
    array set snapshot {}
    foreach nm [namespace children ::] {
	if { [info commands ${nm}::defaults] ne "" } {
	    ${log}::debug "Gathering defaults for namespace $nm"
	    if { [catch {${nm}::defaults} res] } {
		${log}::warn "ERROR: Could not get defaults for $nm: $res"
	    } else {
		set snapshot($nm) $res
	    }
	}
    }

    return [array get snapshot]
}


# ::uobj::restore -- Restore module options from a snapshot
#
#	This procedure will restore a program's module options from a
#	snapshot that has been created with the ::uobj::snapshot
#	procedure.
#
# Arguments:
#	snap	Serialised array, as returned by the snapshot procedure.
#
# Results:
#	None.
#
# Side Effects:
#	Will actively restore default options to the ones stored in
#	the snapshot, values prior to the call will be lost.
proc ::uobj::restore { snap } {
    variable UOBJ
    variable log

    ${log}::info "Restoring program defaults module from snapshot"
    array set snapshot $snap
    foreach nmspace [array names snapshot] {
	foreach {opt val} $snapshot($nmspace) {
	    if { [info commands ${nmspace}::defaults] ne "" } {
		if { [catch {${nmspace}::defaults $opt $val} err] } {
		    ${log}::warn "ERROR: could not set ${key} to $val: $err"
		}
	    } else {
		${log}::warn "ERROR: no defaults for $module"
	    }
	}
    }
}


# ::uobj::serialize -- Serialize array to file
#
#	This procedure serializes the content of an "object" to a
#	file.  It provides a mechanism to select which part of the
#	array should be written to the file.  All array elements that
#	matches one of the patterns will be written down to the file
#	if they do not match any of the restricting patterns.
#
# Arguments:
#	ary_p	"pointer" to the array
#	fd_or_n Either an opened file descriptor or the path to a file
#	        that will be overwritten with content.
#	pterns	List of patterns for elements to be copied
#	rstrict	List of patterns for options not to be copied
#
# Results:
#	Return the list of indices that were written,  an error on errors
#
# Side Effects:
#	Will overwrite the file if a file name is specified as second
#	argument
proc ::uobj::serialize { ary_p fd_or_n {pterns "-*"} {rstrict ""} } {
    variable UOBJ
    variable log

    # Guess if second argument is an opened file descriptor or a file
    # name.  If it is a file name, open it.  Always make sure fd is a
    # file descriptor to which we will write.
    if { [catch {fconfigure $fd_or_n}] } {
	${log}::info "Opening $fd_or_n for serialization"
	if { [catch {open $fd_or_n w} fd] } {
	    ${log}::warn "Could not open $fd_or_n for writing: $fd"
	    return -code error "Could not open $fd_or_n for writing: $fd"
	}
    } else {
	set fd $fd_or_n
    }

    # Dump to <fd> all the indices matching the allowance and
    # restriction patterns.  Dump their value aside.  Account for
    # which indices are dumped.
    set dumped [list]
    upvar $ary_p OBJECT
    foreach ptn $pterns {
	foreach idx [array names OBJECT $ptn] {
	    set dump 1
	    foreach r $rstrict {
		if { [string match $r $idx] } {
		    set dump 0
		}
	    }
	    if { $dump } {
		puts $fd "$idx $OBJECT($idx)"
		lappend dumped $idx
	    }
	}
    }

    # Close the file if the second parameter was a file name.
    if { $fd ne $fd_or_n } {
	close $fd
    }

    return $dumped
}


# ::uobj::deserialize -- DeSerialize array from file
#
#	This procedure desserializes the content of an "object" from a
#	file.  It provides a mechanism to select which part of the
#	array should be read from the file.  All array elements that
#	matches one of the patterns will be written down to the array
#	if they do not match any of the restricting patterns.
#
# Arguments:
#	ary_p	"pointer" to the array
#	fd_or_n Either an opened file descriptor or the path to a file
#	        that will be overwritten with content.
#	pterns	List of patterns for elements to be copied
#	rstrict	List of patterns for options not to be copied
#
# Results:
#	Return the list of indices that were written to the array, an
#	error on errors
#
# Side Effects:
#	None
proc ::uobj::deserialize { ary_p fd_or_n {pterns "-*"} {rstrict ""} } {
    variable UOBJ
    variable log

    # Guess if second argument is an opened file descriptor or a file
    # name.  If it is a file name, open it.  Always make sure fd is a
    # file descriptor to which we will write.
    if { [catch {fconfigure $fd_or_n}] } {
	${log}::info "Opening $fd_or_n for serialization"
	if { [catch {open $fd_or_n} fd] } {
	    ${log}::warn "Could not open $fd_or_n for writing: $fd"
	    return -code error "Could not open $fd_or_n for writing: $fd"
	}
    } else {
	set fd $fd_or_n
    }

    # Read from <fd> all the indices matching the allowance and
    # restriction patterns.  Account for which indices are read.
    set dumped [list]
    upvar $ary_p OBJECT
    while { ! [eof $fd] } {
	set line [string trim [gets $fd]]
	if { $line eq "" } {
	    if { $fd eq $fd_or_n } {
		${log}::info "Spontaneously stopping to read on empty line"
		break
	    }
	} else {
	    set firstchar [string index $line 0]
	    # Skip all lines that are commented.
	    if { [string first $firstchar $UOBJ(comments)] < 0 } {
		foreach {idx val} $line {}
		set dump 1
		foreach ptn $pterns {
		    if { [string match $ptn $idx] } {
			foreach r $rstrict {
			    if { [string match $r $idx] } {
				set dump 0
			    }
			}
		    }
		}

		if { $dump } {
		    set OBJECT($idx) $val
		    lappend dumped $idx
		}
	    }
	}
    }
		
    # Close the file if the second parameter was a file name.
    if { $fd ne $fd_or_n } {
	close $fd
    }

    return $dumped
}

package provide uobj 0.3