######################################################################
#
# Package: cost250
# File: polycost.tcl
# Project: COST-250 Speaker Recognition Reference System
# Author: H. Melin, KTH/CTT, 16/02/1998
#
# Description:
# Database specific settings for Polycost.
#
#
# ---------------------------------------------------------------
#
# History:
# 21/06/1999 - part of COST250 Speaker Recognition Reference System, release 1.0
# 24/02/1999 - part of development release 0.2
# 24/02/1999 H. Melin - filename method is now checking if file exists.
# It also tries with several upper and lower case
# combinations of the tag and file name extension.
# 23/02/1999 - part of development release 0.1
#
######################################################################
package provide cost250 1.0
namespace eval Database {
# Export public commands
namespace export new
# In this array all instance variables are stored
variable registry
# This array store default values for instance variables
variable registryDefault
# This list contains the names of all the instance variables
variable instanceVariables
########################################################################
#
# Instance variables
# ==================
#
# The registry array shall be indexed with $instance.$variable
# where $variable is one of the below. The registryDefault array
# is indexed with only the string $variable.
#
# ------ Database location
#
# Directories:
#
# dataDir base directory for sample files
#
# Filename extensions:
#
# alwExt extension for A-law format sample files
#
# ------ Runtime:
#
# Other:
#
# trace
# isInit set to 1 when method init is called.
#
# Keep a list of all available instance variables
set instanceVariables [list dataDir alwExt trace isInit]
# Define default values for instance variables
set registryDefault(dataDir) "data/polycost"
set registryDefault(alwExt) ".ALW"
set registryDefault(trace) 0
set registryDefault(isInit) 0
#############################################################
#
# new: create a new database instance.
#
proc new { basedir } {
variable registry
variable registryDefault
variable instanceVariables
# Create a unique instance name for this database
set instanceBase "db"
set ns [uplevel 1 namespace current]
if {"::" != $ns} {
append ns "::"
}
set i 1
while {1 == 1} {
set instance [format "%s%s%02d" $ns $instanceBase $i]
if {"" == [info commands $instance]} {
# We found an unused instance name
break
}
incr i
}
# Create instance variables by copying default values
foreach variable $instanceVariables {
set registry($instance.$variable) $registryDefault($variable)
}
# Check if $basedir exists
if {![file exists $basedir] || ![file isdirectory $basedir]} {
error "ERROR: now such directory: $basedir"
}
# Set values of instance variables given as argument
set registry($instance.dataDir) $basedir
# Create a command called $instance
proc $instance { method args } "Database::methods $instance \$method \$args"
return $instance
}
###########################################################
#
# methods: method call dispatcher
#
proc methods {name method argList} {
variable registry
switch $method {
destroy -
set -
init -
print -
getdir -
filename {
if {[catch "method_$method $name $argList" result]} {
regsub -- "method_$method" $result "$name $method" result
return -code error $result
} else {
return $result
}
}
default {
return -code error "ERROR: \"$name $method\" is not defined"
}
}
}
## ------------ here comes method implementations --------------- ##
###########################################################
#
# Method destroy: free resources allocated for the given instance.
# and delete the object itself.
#
proc method_destroy { instance } {
variable registry
variable instanceVariables
# Delete instance variables
# ...
# Delete the object/command itself
rename $instance ""
}
###########################################################
#
# Method set: set the value of an instance variable.
# This method may only be called before the init method
# is called.
#
proc method_set { instance varName value } {
variable registry
variable instanceVariables
# check that method init has not been called
if {$registry($instance.isInit)} {
error "method_set: already initialized: 'set' only allowed before 'init'"
}
# see if there is a variable with that name
if {[lsearch -exact $instanceVariables $varName] < 0} {
error "method_set: no such variable to set: $varName"
}
# ok, set value
set registry($instance.$varName) $value
}
###########################################################
#
# Method print: print the contents of the object
#
proc method_print { instance {channel stdout} } {
variable registry
variable registryDefault
variable instanceVariables
puts $channel "$instance:"
foreach variable $instanceVariables {
set value $registry($instance.$variable)
set default $registryDefault($variable)
puts -nonewline $channel [format " %-17s : %s" $variable $value]
if {$value != $default && $default != "" && $variable != "isInit"} {
puts -nonewline $channel " (default: $default)"
}
puts $channel ""
}
puts $channel ""
}
###########################################################
#
# Method init: initialize database object.
#
# Between creation with 'new' and calling this method, user
# may call 'set' to change values of instance variables.
#
proc method_init { instance } {
variable registry
# init may only be called once
if {$registry($instance.isInit)} {
error "method_init: already initialized"
}
# Remember that init has been called
set registry($instance.isInit) 1
}
###########################################################
#
# Method getdir: return the database base directory
#
proc method_getdir { instance } {
variable registry
return $registry($instance.dataDir)
}
###########################################################
#
# Method filename: return the full name of the file
# corresponding to the given tag.
#
proc method_filename { instance tag } {
variable registry
set base $registry($instance.dataDir)
set a "$tag$registry($instance.alwExt)"
set filename [file join $base $a]
set original $filename
if {! [file exists $filename]} {
# Try with only lower case letters
set filename [file join $base [string tolower $a]]
if {! [file exists $filename]} {
# Try with only upper case letters
set filename [file join $base [string toupper $a]]
if {! [file exists $filename]} {
# Puhh!
# Let's try with upper case tag and lower case extension
set filename [file join $base "[string toupper $tag][string tolower $registry($instance.alwExt)]"]
if {! [file exists $filename]} {
# Ok, final attempt: lower case tag and upper case extension
set filename [file join $base "[string tolower $tag][string toupper $registry($instance.alwExt)]"]
if {! [file exists $filename]} {
# Surrender...
error "method_filename: no such file: $original"
}
}
}
}
}
return $filename
}
}
# -------------- end of polycost.tcl ------------------------- #