Named Pipes

The following package implements named pipes, on top of a reflected channel or memchan, depending on which is available. The package uses names to identifies the pipes and to be able to rejoin somewhere else in your code base, which might be of use in large projects. It originally comes from biot. There is some raw testing at the end. EF

##################
## Module Name     --  pipe
## Original Author --  Emmanuel Frecon - [email protected]
## Description:
##
##      This is a tcl-internal implemention of named pipes. Pipes are identified
##      by names, which are unique across the process-space and this name
##      corresponds to a file descriptor that only exists in memory and acts as
##      a FIFO.
##
## Commands Exported:
##      All commands starting with a lowercase.
##################

namespace eval ::namedpipe {
    namespace eval vars {
        variable -prefix     pipe;    # Prefix when no name specified.
        variable generator   0
        variable cmd         {};      # Command to create a pipe
        variable pipes       {};      # Dictionary that will contained known pipes
        variable captured    0;       # Have we captured close yet?
    }
    namespace export {[a-z]*}
}

# Historically, the first implementation of FIFO in process memory were realised
# through a package called Memchan. However, recent Tcl allow to implement file
# I/O programatically and there is now a Tcl-only implementation. The code below
# prefers the modern implementation and reverts to the old, just in case it was
# the only one available on the host.
if { [catch {package require tcl::chan::fifo} ver] == 0 } {
    set ::namedpipe::vars::cmd ::tcl::chan::fifo
} elseif { [catch {package require Memchan} ver] == 0 } {
    set ::namedpipe::vars::cmd ::fifo
}


# ::namedpipe::new -- Create a name pipe.
#
#       Create a named pipe and return its file descriptor.
#
# Arguments:
#        name        Unique name of pipe, one will be generated if none provided.
#
# Results:
#       Return the channel identifier of the pipe, or an empty string on errors.
#
# Side Effects:
#       None.
proc ::namedpipe::new { { name ""} } {
    # Generate "unique" names if none provided. You will have to ask via the
    # procedure <name> below if you want to know which name was generated.
    if { $name eq "" } {
        set name ${vars::-prefix}[incr vars::generator]
    }

    # Get existing file descriptor for name, if any.
    set pipe [channel $name]
    
    # If none existed and we know how to create FIFOs in memory, create one.
    if { $pipe eq "" && [llength $vars::cmd] } {
        # Create a FIFO and remember its assocation to the name
        set pipe [eval $vars::cmd]
        dict set vars::pipes $name $pipe
        
        # Arrange to capture the close command so that we can safely let
        # external code call close on the file descriptor that is returned,
        # while still removing the association created above.
        if { ! $vars::captured } {
            rename ::close [namespace current]::RealClose
            interp alias {} ::close {} [namespace current]::PipeClose
        }
    }
    
    # Return the file descriptor, might be empty
    return $pipe
}


# ::namedpipe::channel -- File descriptor lookup
#
#       Given the name of an existing named pipe, return its file descriptor for
#       FIFO operations.
#
# Arguments:
#        name        Name of file descriptor
#
# Results:
#       File descriptor of named pipe, or an empty string.
#
# Side Effects:
#       None.
proc ::namedpipe::channel { name } {
    if { [dict exists $vars::pipes $name] } {
        return [dict get $vars::pipes $name]
    }
    return ""
}


# ::namedpipe::name -- Name lookup
#
#       Given a known file descriptor, return the name of the named pipe that
#       corresponds, if relevant.
#
# Arguments:
#        fd        File descriptor, typically returned by <new>
#
# Results:
#       Name of the named pipe, or an empty string.
#
# Side Effects:
#       None.
proc ::namedpipe::name { fd } {
    dict for {name pipe} $vars::pipes {
        if { $pipe eq $fd } {
            return $name
        }
    }
    return ""
}


# ::namedpipe::close -- Close a named pipe.
#
#       Close a named pipe, including the FIFO that is behind.
#
# Arguments:
#        name        Name of pipe
#
# Results:
#       Return what was returned by call to close
#
# Side Effects:
#       None.
proc ::namedpipe::close { name } {
    # Resolve name to a file descriptor, if possible.
    set pipe [channel $name]
    if { $pipe ne "" } {
        # Close the file descriptor and remove association
        set res [RealClose $pipe]
        dict unset vars::pipes $name
        ::utils::debug INFO "Destroyed named pipe: $name"
        return $res
    }
    return ""
}


#####################################
##
## Below are all internal procedures, change only if you want to help
##
#####################################


# ::namedpipe::PipeClose -- ::close capture
#
#       This is a wrapper around the regular close command. If the file
#       descriptor passed as a parameter is a named pipe, we close it via the
#       internal implemenation to this library. Otherwise, we just pass it and
#       all arguments to the regular close implementation.
#
# Arguments:
#        fd        File descriptor
#        args        Arguments to close (ignored for named pipes)
#
# Results:
#       What is returned by the respective close functions.
#
# Side Effects:
#       None.
proc ::namedpipe::PipeClose { fd args } {
    set name [name $fd]
    if { $name ne "" } {
        return [close $name]
    }
    return [uplevel [namespace current]::RealClose $fd {*}$args]
}

package provide namedpipe 0.1

#####################################
##
## Simple test whenever this file is sourced directly. This performs
## initialisation and registers a procedure that will be called whenever data
## for any nearby sensor has changed. The procedure outputs the type of the
## value, its type and unit.
##
#####################################

if { [info exists argv0] && [info script] eq $argv0 } {
    set fd [::namedpipe::new]
    puts "Created new pipe $fd, named [::namedpipe::name $fd]"
    puts "Recreating to check unicity of association: [::namedpipe::new [::namedpipe::name $fd]]"
    puts $fd "Test"; flush $fd
    puts "Could properly get back [gets $fd] from pipe"
    close $fd

    puts "Now testing overloading of ::close command"    
    set fd [open [info script]]
    close $fd
}