Version 3 of vfs::http

Updated 2005-07-17 17:26:11

package provide vfs::http 0.5

  package require vfs 1.0
  package require http

  # This works for basic operations, but has not been very debugged.

  namespace eval vfs::http {}

  proc vfs::http::Mount {dirurl local} {
    ::vfs::log "http-vfs: attempt to mount $dirurl at $local"
    if {[string index $dirurl end] != "/"} {
        append dirurl "/"
    }
    if {[string range $dirurl 0 6] == "http://"} {
        set rest [string range $dirurl 7 end]
    } else {
        set rest $dirurl
        set dirurl "http://${dirurl}"
    }

    if {![regexp {(([^:]*)(:([^@]*))[email protected])?([^/]*)(/(.*/)?([^/]*))?$} $rest \
      junk junk user junk pass host junk path file]} {
        return -code error "Sorry I didn't understand\
          the url address \"$dirurl\""
    }

    if {[string length $file]} {
        return -code error "Can only mount directories, not\
          files (perhaps you need a trailing '/' - I understood\
          a path '$path' and file '$file')"
    }

    if {![string length $user]} {
        set user anonymous
    }

    set token [::http::geturl $dirurl -validate 1]

    if {![catch {vfs::filesystem info $dirurl}]} {
        # unmount old mount
        ::vfs::log "ftp-vfs: unmounted old mount point at $dirurl"
        vfs::unmount $dirurl
    }
    ::vfs::log "http $host, $path mounted at $local"
    vfs::filesystem mount $local [list vfs::http::handler $dirurl $path]
    # Register command to unmount
    vfs::RegisterMount $local [list ::vfs::http::Unmount $dirurl]
    return $dirurl
  }

  proc vfs::http::Unmount {dirurl local} {
    vfs::filesystem unmount $local
  }

  proc vfs::http::handler {dirurl path cmd root relative actualpath args} {
    if {$cmd == "matchindirectory"} {
        eval [list $cmd $dirurl $relative $actualpath] $args
    } else {
        eval [list $cmd $dirurl $relative] $args
    }
  }

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

  proc vfs::http::stat {dirurl name} {
    ::vfs::log "stat $name"

    # get information on the type of this file.  We describe everything
    # as a file (not a directory) since with http, even directories
    # really behave as the index.html they contain.
    set state [::http::geturl "$dirurl$name" -validate 1]
    set mtime 0
    lappend res type file
    lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \
      atime $mtime ctime $mtime mtime $mtime mode 0777
    return $res
  }

  proc vfs::http::access {dirurl name mode} {
    ::vfs::log "access $name $mode"
    if {$mode & 2} {
        vfs::filesystem posixerror $::vfs::posix(EROFS)
    }
    if {$name == ""} { return 1 }
    set state [::http::geturl "$dirurl$name"]
    set info ""
    if {[string length $info]} {
        return 1
    } else {
        error "No such file"
    }
  }

  # We've chosen to implement these channels by using a memchan.
  # The alternative would be to use temporary files.
  proc vfs::http::open {dirurl 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 -glob -- $mode {
        "" -
        "r" {
            set state [::http::geturl "$dirurl$name"]

            set filed [vfs::memchan]
            fconfigure $filed -translation binary
            puts -nonewline $filed [::http::data $state]

            fconfigure $filed -translation auto
            seek $filed 0
            return [list $filed]
        }
        "a" -
        "w*" {
            vfs::filesystem posixerror $::vfs::posix(EROFS)
        }
        default {
            return -code error "illegal access mode \"$mode\""
        }
    }
  }

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

    if {[string length $pattern]} {
        # need to match all files in a given remote http site.

    } else {
        # single file
        if {![catch {access $dirurl $path 0}]} {
            lappend res $path
        }
    }

    return $res
  }

  proc vfs::http::createdirectory {dirurl name} {
    ::vfs::log "createdirectory $name"
    vfs::filesystem posixerror $::vfs::posix(EROFS)
  }

  proc vfs::http::removedirectory {dirurl name recursive} {
    ::vfs::log "removedirectory $name"
    vfs::filesystem posixerror $::vfs::posix(EROFS)
  }

  proc vfs::http::deletefile {dirurl name} {
    ::vfs::log "deletefile $name"
    vfs::filesystem posixerror $::vfs::posix(EROFS)
  }

  proc vfs::http::fileattributes {dirurl path args} {
    ::vfs::log "fileattributes $args"
    switch -- [llength $args] {
        0 {
            # list strings
            return [list]
        }
        1 {
            # get value
            set index [lindex $args 0]
        }
        2 {
            # set value
            set index [lindex $args 0]
            set val [lindex $args 1]
            vfs::filesystem posixerror $::vfs::posix(EROFS)
        }
    }
  }

  proc vfs::http::utime {dirurl path actime mtime} {
    vfs::filesystem posixerror $::vfs::posix(EROFS)
  }

append the following if you are intrested in cding into a directory

  proc vfs::http::stat {dirurl name} {
    # Procedure redfined by Zarutian
    if {$name != {}} {
      set url "$dirurl$name"
    } else {
      set url $dirurl
    }
    ::vfs::log "http-vfs: stat url $url"
    set state [::http::geturl $url -validate 1]
    set mtime 0
    lappend res dev -1 
    lappend res uid -1
    lappend res gid -1
    lappend res nlink 1
    lappend res depth 0
    lappend res atime $mtime
    lappend res ctime $mtime
    lappend res mtime $mtime
    lappend res mode 0777
    if {[string index $url end] == "/"} {
      lappend res type directory
    } else {
      lappend res type file
    }
    return $res
  }

Zarutian 17. july 2005: The vfs::http implemention above loads the whole file into memmory before giving the caller script access to it. I ask is this a deeffiency?

I think it is. So an implemention if vfs::http that uses a dual sided memchan would be better because then the vfs could handle files servral megabytes in size without the interpreter running out of memmory. Also the vfs could handle streaming files. (A dual sided memchan is actualy two channels per memmory buffer: one in, one out.)


See also tclvfs.


Category Package Category VFS Category Internet