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

# @@ Meta Begin
# Package vfs::ns 0.5
# Meta as::author  Vincent Darley
# Meta as::origin  http://sourceforge.net/projects/tclvfs
# Meta category    Virtual filesystems
# Meta description Tclvfs allows Virtual Filesystems to be built using Tcl
# Meta description scripts only. It is also a repository of such
# Meta description Tcl-implemented filesystems (metakit, zip, ftp, tar,
# Meta description http, webdav, namespace, url)
# Meta license     BSD
# Meta platform    tcl
# Meta require     {Tcl 8.4}
# Meta require     vfs
# Meta subject     zip ftp tar http webdav vfs filesystem metakit namespace
# Meta subject     url
# Meta summary     Extra virtual filesystems for Tcl.
# @@ Meta End



# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.4
package require vfs

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide vfs::ns 0.5

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

package provide vfs::ns 0.5

package require vfs 1.0

# Thanks to jcw for the idea here.  This is a 'file system' which
# is actually a representation of the Tcl command namespace hierarchy.
# Namespaces are directories, and procedures are files.  Tcl allows
# procedures with the same name as a namespace, which are hidden in
# a filesystem representation.

namespace eval vfs::ns {}

proc vfs::ns::Mount {ns local} {
    if {![namespace exists ::$ns]} {
	error "No such namespace"
    }
    ::vfs::log "ns $ns mounted at $local"
    vfs::filesystem mount $local [list vfs::ns::handler $ns]
    vfs::RegisterMount $local [list vfs::ns::Unmount]
    return $local
}

proc vfs::ns::Unmount {local} {
    vfs::filesystem unmount $local
}

proc vfs::ns::handler {ns cmd root relative actualpath args} {
    regsub -all / $relative :: relative
    if {$cmd == "matchindirectory"} {
	eval [list $cmd $ns $relative $actualpath] $args
    } else {
	eval [list $cmd $ns $relative] $args
    }
}

# If we implement the commands below, we will have a perfect
# virtual file system for namespaces.

proc vfs::ns::stat {ns name} {
    ::vfs::log "stat $name"
    if {[namespace exists ::${ns}::${name}]} {
	return [list type directory size 0 mode 0777 \
	  ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \
	  uid -1 gid -1 nlink 1]
    } elseif {[llength [info procs ::${ns}::${name}]]} {
	return [list type file]
    } else {
	return -code error "could not read \"$name\": no such file or directory"
    }
}

proc vfs::ns::access {ns name mode} {
    ::vfs::log "access $name $mode"
    if {[namespace exists ::${ns}::${name}]} {
	return 1
    } elseif {[llength [info procs ::${ns}::${name}]]} {
	if {$mode & 2} {
	    error "read-only"
	}
	return 1
    } else {
	error "No such file"
    }
}

proc vfs::ns::exists {ns name} {
    if {[namespace exists ::${ns}::${name}]} {
	return 1
    } elseif {[llength [info procs ::${ns}::${name}]]} {
	return 1
    } else {
	return 0
    }
}

proc vfs::ns::open {ns name mode permissions} {
    ::vfs::log "open $name $mode $permissions"
    # return a list of two elements:
    # 1. first element is the Tcl channel name which has been opened
    # 2. second element (optional) is a command to evaluate when
    #    the channel is closed.
    switch -- $mode {
	"" -
	"r" {
	    set nfd [vfs::memchan]
	    fconfigure $nfd -translation binary
	    puts -nonewline $nfd [_generate ::${ns}::${name}]
	    fconfigure $nfd -translation auto
	    seek $nfd 0
	    return [list $nfd]
	}
	default {
	    return -code error "illegal access mode \"$mode\""
	}
    }
}

proc vfs::ns::_generate {p} {
    lappend a proc $p
    set argslist [list]
    foreach arg [info args $p] {
	if {[info default $p $arg v]} {
	    lappend argslist [list $arg $v]
	} else {
	    lappend argslist $arg
	}
    }
    lappend a $argslist [info body $p]
}

proc vfs::ns::matchindirectory {ns path actualpath pattern type} {
    ::vfs::log "matchindirectory $path $actualpath $pattern $type"
    set res [list]

    if {[::vfs::matchDirectories $type]} {
	# add matching directories to $res
	if {[string length $pattern]} {
	    eval lappend res [namespace children ::${ns}::${path} $pattern]
	} else {
	    if {[namespace exists ::${ns}::${path}]} {
		eval lappend res ::${ns}::${path}
	    }
	}
    }
    
    if {[::vfs::matchFiles $type]} {
	# add matching files to $res
	if {[string length $pattern]} {
	    eval lappend res [info procs ::${ns}::${path}::$pattern]
	} else {
	    eval lappend res [info procs ::${ns}]
	}
    }
    set realres [list]
    foreach r $res {
	regsub "^(::)?${ns}(::)?${path}(::)?" $r $actualpath rr
	lappend realres $rr
    }
    #::vfs::log $realres
    
    return $realres
}

proc vfs::ns::createdirectory {ns name} {
    ::vfs::log "createdirectory $name"
    namespace eval ::${ns}::${name} {}
}

proc vfs::ns::removedirectory {ns name recursive} {
    ::vfs::log "removedirectory $name"
    namespace delete ::${ns}::${name}
}

proc vfs::ns::deletefile {ns name} {
    ::vfs::log "deletefile $name"
    rename ::${ns}::${name} {}
}

proc vfs::ns::fileattributes {ns name args} {
    ::vfs::log "fileattributes $args"
    switch -- [llength $args] {
	0 {
	    # list strings
	    return [list -args -body]
	}
	1 {
	    # get value
	    set index [lindex $args 0]
	    switch -- $index {
		0 {
		    ::info args ::${ns}::${name}
		}
		1 {
		    ::info body ::${ns}::${name}
		}
	    }
	}
	2 {
	    # set value
	    set index [lindex $args 0]
	    set val [lindex $args 1]
	    switch -- $index {
		0 {
		    error "read-only"
		}
		1 {
		    error "unimplemented"
		}
	    }
	}
    }
}

proc vfs::ns::utime {what name actime mtime} {
    ::vfs::log "utime $name"
    error ""
}