Tcl Source Code

Artifact 3f726d01c664738cd8b9213d0d2376dbf050eb18:

#!/bin/bash
# This comment hides the next line from the Tcl interpreter.\
exec "$(dirname "$0")/util/tclkit" "$0" "$@"

lappend auto_path lib
package require Tcl 8.6
package require vfs

proc attempt {command} {
    puts [string repeat - 80]\n$command
    tailcall try $command on error {msg options} {
        puts stderr [dict get $options -errorinfo]
    }
}

proc battery {chan} {
    attempt {chan configure $chan -eofchar Z}
    attempt {chan blocked $chan}
    attempt {chan configure $chan}
    attempt {chan copy $chan $chan}
    attempt {chan eof $chan}
    attempt {chan event $chan readable}
    attempt {chan event $chan writable}
    attempt {chan flush $chan}
    attempt {chan gets $chan}
    attempt {chan pending input $chan}
    attempt {chan pending output $chan}
    attempt {chan puts -nonewline $chan hello}
    attempt {chan read $chan}
    attempt {chan seek $chan 0}
    attempt {chan seek $chan 0 current}
    attempt {chan seek $chan 0 end}
    attempt {chan tell $chan}
    attempt {chan truncate $chan}
    attempt {chan close $chan}
}

proc mount {dir {modeOverride {}}} {
    vfs::filesystem mount $dir [list\
    apply {{modeOverride operation root relative actual args} {
        puts [list vfs $operation $root $relative $actual {*}$args]
        if {$operation eq "open"} {
            lassign $args mode permissions
            if {[llength $modeOverride]} {
                set mode $modeOverride
            } else {
                set mode [dict get {
                    {} read w write a write w+ {read write} a+ {read write}
                } $mode]
            }
            chan create $mode {apply {{operation args} {
                puts [list refchan $operation {*}$args]
                if {$operation eq "initialize"} {
                    return {
                        initialize finalize watch read write seek configure cget
                        cgetall blocking
                    }
                } elseif {$operation eq "write"} {
                    lassign $args channelId data
                    return [string length $data]
                } elseif {$operation eq "seek"} {
                    return 0
                }
            }}}
        }
    }} $modeOverride]
}

foreach {dir modeOverride} {
    /test-normal {}
    /test-r read
    /test-w write
    /test-rw {read write}
} {
    mount $dir $modeOverride
    battery [attempt {open [file join $dir read] r}]
    battery [attempt {open [file join $dir write] w}]
    attempt {source [file join $dir source]}
    vfs::filesystem unmount $dir
}

# vim: set sts=4 sw=4 tw=80 et ft=tcl: