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

# @@ Meta Begin
# Package transfer::data::destination 0.1
# Meta as::build::date 2009-03-30
# Meta as::origin      http://sourceforge.net/projects/tcllib
# Meta category        Data transfer facilities
# Meta description     Data destination
# Meta license         BSD
# Meta platform        tcl
# Meta require         {Tcl 8.4}
# Meta require         snit
# Meta subject         {data destination} channel transfer copy
# Meta summary         transfer::data::destination
# @@ Meta End



# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.4
package require snit

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide transfer::data::destination 0.1

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# -*- tcl -*-
# ### ### ### ######### ######### #########
##

# Class for the handling of stream destinations.

# ### ### ### ######### ######### #########
## Requirements

package require snit

# ### ### ### ######### ######### #########
## Implementation

snit::type ::transfer::data::destination {

    # ### ### ### ######### ######### #########
    ## API

    #                       Destination is ...
    option -channel  {} ; # an open & writable channel.
    option -file     {} ; # a writable file.
    option -variable {} ; # the named variable.

    method put   {chunk} {}
    method done  {}      {}
    method valid {mv}    {}

    method receive {sock done} {}

    # ### ### ### ######### ######### #########
    ## Implementation

    method put {chunk} {
	if {$xtype eq "file"} {
	    set value [open $value w]
	    set xtype  channel
	    set close 1
	}

	switch -exact -- $xtype {
	    variable {
		upvar \#0 $value var
		append var $chunk
	    }
	    channel {
		puts -nonewline $value $chunk
	    }
	}
	return
    }

    method done {} {
	switch -exact -- $xtype {
	    file - variable {}
	    channel {
		if {$close} {close $value}
	    }
	}
    }

    method valid {mv} {
	upvar 1 $mv message
	switch -exact -- $xtype {
	    undefined {
		set message "Data destination is undefined"
		return 0
	    }
	    default {}
	}
	return 1
    }

    method receive {sock done} {
	set ntransfered 0
	set old [fconfigure $sock -blocking]
	fconfigure $sock -blocking 0
	fileevent $sock readable \
		[mymethod Read $sock $old $done]
	return
    }

    method Read {sock oldblock done} {
	set chunk [read $sock]
	if {[set l [string length $chunk]]} {
	    $self put $chunk
	    incr ntransfered $l
	}
	if {[eof $sock]} {
	    $self done
	    fileevent  $sock readable {}
	    fconfigure $sock -blocking $oldblock

	    lappend done $ntransfered
	    uplevel #0 $done
	}
	return
    }

    # ### ### ### ######### ######### #########
    ## Internal helper commands.

    onconfigure -variable {newvalue} {
	set etype variable
	set xtype string

	if {![uplevel \#0 {info exists $newvalue}]} {
	    return -code error "Bad variable \"$newvalue\", does not exist"
	}

	set value $newvalue
	return
    }

    onconfigure -channel {newvalue} {
	if {![llength [file channels $newvalue]]} {
	    return -code error "Bad channel handle \"$newvalue\", does not exist"
	}
	set etype channel
	set xtype channel
	set value $newvalue
	return
    }

    onconfigure -file {newvalue} {
	if {![file exists $newvalue]} {
	    set d [file dirname $newvalue]
	    if {![file writable $d]} {
		return -code error "File \"$newvalue\" not creatable"
	    }
	    if {![file isdirectory $d]} {
		return -code error "File \"$newvalue\" not creatable"
	    }
	} else {
	    if {![file writable $newvalue]} {
		return -code error "File \"$newvalue\" not writable"
	    }
	    if {![file isfile $newvalue]} {
		return -code error "File \"$newvalue\" not a file"
	    }
	}
	set etype channel
	set xtype file
	set value $newvalue
	return
    }

    # ### ### ### ######### ######### #########
    ## Data structures

    variable etype  undefined
    variable xtype  undefined
    variable value
    variable close 0

    variable ntransfered

    ##
    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide transfer::data::destination 0.1