redirect.tcl

::pwtk::redirect

::pwtk::redirect

SYNOPSIS

proc ::pwtk::redirect {args} {

USAGE

   redirect ?stdout? ?stderr? script 
   redirect ?stderr? ?stdout? script

DESCRIPTION

Redirect printing to stdout/stderr to a return value.

Inspired by:

      https://wiki.tcl-lang.org/page/puts+workaround
      https://stackoverflow.com/questions/8531031/how-can-i-redirect-stdout-into-a-file-in-tcl

ARGUMENTS

channels -- which channels to redirect. Possibilities: stdout, stderr, or both of them
script -- script for which the stdout/stderr is redirected

RETURN VALUE

A return value of the script.

SOURCE

    global pwtk_redirect_channels_  pwtk_redirect_result_

    set pwtk_redirect_result_ {}    
    set pwtk_redirect_channels_ {}
    set len [llength $args]

    lassign $args arg1 arg2 arg3
    
    if { $len == 1 } {
        set pwtk_redirect_channels_ stdout
        set script $arg1
    } elseif { $len == 2 } {
        switch $arg1 {
            stdout - stderr {
                set pwtk_redirect_channels_ $arg1
            } default {
                ::pwtk::error "wrong channel '$arg1', must be stdout or stderr" 1
            }
        }
        set script $arg2
    } elseif { $len == 3 } {
        foreach arg [list $arg1 $arg2] {
            switch $arg {
                stdout - stderr {
                    lappend pwtk_redirect_channels_ $arg
                } default {
                    ::pwtk::error "wrong channel '$arg', must be stdout or stderr" 1
                }
            }
        }
        set script $arg3
    } else {
        ::pwtk::error "wrong # of args, must be redirect ?stdout? ?stderr? script" 1
    }
    
    rename puts ::tcl::orig_puts

    proc ::puts {args} {
        global pwtk_redirect_channels_ pwtk_redirect_result_
        
        set nargs [llength $args]        
        if {$nargs<1 || $nargs>3} {
            ::error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
        }

        set nl \n
        if { [lindex $args 0] == "-nonewline" } {
            set nl {}
            set args [lrange $args 1 end]
        }

        if { [llength $args] == 1 } {
            set args [list stdout [join $args]]
        }

        set channel [lindex $args 0]
        set string  [lindex $args 1]

        if { $channel in $pwtk_redirect_channels_ } {
            append pwtk_redirect_result_ ${string}$nl
        } else {
            ::tcl::orig_puts $channel ${string}$nl
        }
    } 

    uplevel $script

    set result $pwtk_redirect_result_
    unset pwtk_redirect_result_

    rename ::puts {}
    rename ::tcl::orig_puts ::puts

    return $result
}

TABLE OF CONTENTS

::pwtk::redirect