/usr/share/tcltk/tcllib1.19/transfer/ddest.tcl is in tcllib 1.19-dfsg-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | # -*- tcl -*-
# ### ### ### ######### ######### #########
##
# Class for the handling of stream destinations.
# ### ### ### ######### ######### #########
## Requirements
package require snit
# ### ### ### ######### ######### #########
## Implementation
snit::type ::transfer::data::destination {
# ### ### ### ######### ######### #########
## API
# Destination is ...
option -channel -default {} -configuremethod C-chan ; # an open & writable channel.
option -file -default {} -configuremethod C-file ; # a writable file.
option -variable -default {} -configuremethod C-var ; # the named variable.
option -progress -default {}
method put {chunk} {}
method done {} {}
method valid {mv} {}
method receive {sock done} {}
# ### ### ### ######### ######### #########
## Implementation
method put {chunk} {
if {$myxtype eq "file"} {
set mydest [open $mydest w]
set myxtype channel
set myclose 1
}
switch -exact -- $myxtype {
variable {
upvar \#0 $mydest var
append var $chunk
}
channel {
puts -nonewline $mydest $chunk
}
}
return
}
method done {} {
switch -exact -- $myxtype {
file - variable {}
channel {
if {$myclose} {
close $mydest
}
}
}
}
method valid {mv} {
upvar 1 $mv message
switch -exact -- $myxtype {
undefined {
set message "Data destination is undefined"
return 0
}
default {}
}
return 1
}
method receive {sock done} {
set myntransfered 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 myntransfered $l
if {[llength $options(-progress)]} {
uplevel #0 [linsert $options(-progress) end $myntransfered]
}
}
if {[eof $sock]} {
$self done
fileevent $sock readable {}
fconfigure $sock -blocking $oldblock
uplevel #0 [linsert $done end $myntransfered]
}
return
}
# ### ### ### ######### ######### #########
## Internal helper commands.
method C-var {o newvalue} {
set myetype variable
set myxtype string
if {![uplevel \#0 {info exists $newvalue}]} {
return -code error "Bad variable \"$newvalue\", does not exist"
}
set mydest $newvalue
return
}
method C-chan {o newvalue} {
if {![llength [file channels $newvalue]]} {
return -code error "Bad channel handle \"$newvalue\", does not exist"
}
set myetype channel
set myxtype channel
set mydest $newvalue
return
}
method C-file {o 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 myetype channel
set myxtype file
set mydest $newvalue
return
}
# ### ### ### ######### ######### #########
## Data structures
variable myetype undefined
variable myxtype undefined
variable mydest {}
variable myclose 0
variable myntransfered
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide transfer::data::destination 0.2
|