Tcl Library Source Code

2002-01-18  Andreas Kupries  <[email protected]>
	
	* Bumped version to 1.2, new release. Summary of changes here. See
	  the individual Changelogs to see the detailed changes in each
	  module.

	  New modules: calendar, crc, doctools, irc, smtpd, and stooop.

# rswitch.tcl - 
#	Originally written: 	2001 Nov 2
#	Original author:	Don Porter <[email protected]>
#
#	This software was developed at the National Institute of Standards
#	and Technology by employees of the Federal Government in the course
#	of their official duties. Pursuant to title 17 Section 105 of the
#	United States Code this software is not subject to copyright
#	protection and is in the public domain. 
#
#       The [rswitch] command of the package "control".
#	Inspired by TIP 70.  Amended to the syntax:
#
# 		rswitch $formatString {
#		    $sub1 $body1
#		    ...
#		    $subN $bodyN
#		}
#
#	See documentation in control.n
# -------------------------------------------------------------------------
#
# RCS: @(#) $Id: rswitch.tcl,v 1.3 2001/11/07 21:59:24 dgp Exp $

namespace eval ::control {

    namespace export rswitch

    proc rswitch {formatString actionList} {
	if {[catch {llength $actionList} actionListLength]} {
	    return -code error $actionListLength
	}
	if {$actionListLength % 2} {
	    return -code error "extra substitution with no body"
	}
	# Check for final "default" arm
	set hasDefault [string equal default [lindex $actionList end-1]]
	if {$hasDefault} {
	    set defaultBody [lindex $actionList end]
	    set actionList [lrange $actionList 0 end-2]
	}
	set evalBody 0
	foreach {sub body} $actionList {
	    if {!$evalBody} {
		if {[catch {linsert $sub 0 ::format $formatString} cmd]} {
		    return -code error -errorinfo "$cmd\n    (\"$sub\"\
		        arm substitution)" -errorcode $::errorCode $cmd
		}
		if {[catch {eval $cmd} expression]} {
		    return -code error -errorcode $::errorCode -errorinfo \
			    "$expression\n    (\"$sub\" arm substitution)" \
			    $expression
		}
		set cmd [list ::expr $expression]
		eval [CommandAsCaller cmd evalBody [format "%s\n%s" \
			{\"$sub\" arm expression)} \
			{    (expression: \"$expression\"}]]
		if {![string is boolean -strict $evalBody]} {
		    set msg "non-boolean expression"
		    return -code error -errorcode $::errorCode -errorinfo \
			    [format "%s\n%s\n%s" $msg \
			    "    (\"$sub\" arm expression)" \
			    "    (expression: \"$expression\")"] $msg
		}
		if {!$evalBody} {
		    continue
		}
		set match $sub
	    }
	    # We've found a successful expression.
	    # Evaluate the corresponding body.
	    if {[string equal - $body]} {
		continue
	    }
	    eval [BodyAsCaller body result code {\"$match\" arm}]
	    return -code $code $result
	}
	if {!$hasDefault && !$evalBody} {
	    return
	}
	if {!$evalBody} {
	    set match default
	}
	if {!$hasDefault || [string equal - $defaultBody]} {
	    return -code error \
		"no body specified for substitution \"$match\""
	}
	eval [BodyAsCaller defaultBody result code {\"$match\" arm}]
	return -code $code $result
    }

}

# rswitch.test - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Provide a set of tests to excercise the control::rswitch command of
# tcllib.
#
# @(#)$Id: rswitch.test,v 1.3 2001/11/07 05:31:42 dgp Exp $

# Initialize the required packages
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::test ::tcltest::cleanupTests
}

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] control.tcl]
namespace import ::control::rswitch

# -------------------------------------------------------------------------

# Test simple numeric relational switching.
proc rsinteger {value} {
    rswitch {$value %s} {
        <5      {set result <5}
        ==5     {set result 5}
        >5      {set result >5}
        default {set result default}
    }
    return $result
}

test rswitch-1.1 {switch < 5} {
    catch {rsinteger 0} result
    set result
} {<5}

test rswitch-1.2 {switch == 5} {
    catch {rsinteger 5} result
    set result
} {5}

test rswitch-1.3 {switch > 5} {
    catch {rsinteger 10} result
    set result
} {>5}

test rswitch-1.4 {switch non numeric} {
    catch {rsinteger A} result
    set result
} {>5}

# -------------------------------------------------------------------------

proc rs:compare {lhs rhs} {
    rswitch {$lhs %s $rhs} {
        <   {return <}
        ==  {return ==}
        >   {return >}
    }
}

test rswitch-2.1 {switch string comparison} {
    catch {rs:compare "hello" "world"} result
    set result
} {<}

test rswitch-2.2 {switch string comparison} {
    catch {rs:compare "hello" "hello"} result
    set result
} {==}

test rswitch-2.3 {switch string comparison} {
    catch {rs:compare "hello" "all"} result
    set result
} {>}

# -------------------------------------------------------------------------
# Here are the test cases I used when developing [rswitch] to check on
# its errorInfo management.  They should be converted to proper tests,
# preferably checking ::errorInfo.  OK, I'll do the first one:

test rswitch-3.0 {rswitch argument checking} {
    list [catch {rswitch 1 \{} msg] $msg $::errorInfo
} {1 {unmatched open brace in list} {unmatched open brace in list
    while executing
"rswitch 1 \{"}}

#rswitch {1 %s} {
#        {{>[string length]}} {string length}
#    }} msg] $msg]
#}
#rswitch 1 foo
#rswitch {1 %s} {
#	{{&& ([string length a]
#	||
#	[string length]}} {string length}
#}
#rswitch {1 %s} {
#	{{&& ([string length a]
#	||
#	[string length])}} {string length}
#}
#rswitch {1 %s} {
#	{{&& ([string length]
#	||
#	[string length])}} {string length}
#}
#rswitch {1 %s 1} {
#    ==  {
#	    set a 1
#	    string length
#	    set b 2
#	}
#}
#rswitch {1 %s 1} {
#    ==  {
#	    set a 1
#	    expr {[string length]}
#	    set b 2
#	}
#}

# -------------------------------------------------------------------------
# Clean up the tests

::tcltest::cleanupTests
return

# Local variables:
#    mode: tcl
#    indent-tabs-mode: nil
# End: