saods9-data 7.3.2+repack-1 / usr / share / saods9 / src / url.tcl

#  Copyright (C) 1999-2014
#  Smithsonian Astrophysical Observatory, Cambridge, MA, USA
#  For conditions of distribution and use, see copyright notice in "copyright"

package provide DS9 1.0

proc OpenURLFits {{layer {}} {mode {}}} {
    global fitsurl

    set url $fitsurl
    if {[EntryDialog [msgcat::mc {URL}] [msgcat::mc {Enter URL}] 80 url]} {
	StartLoad
	LoadURLFits $url $layer $mode
	FinishLoad

	set fitsurl $url
    }
}

proc LoadURLFits {url layer mode} {
    if {[string length $url] == 0} {
	return
    }

    ParseURL $url r
    switch -- $r(scheme) {
	ftp {LoadURLFitsFTP $r(authority) $r(path) $layer $mode}
	file {LoadURLFitsFile $r(path) $layer $mode}
	http -
	default {LoadURLFitsHTTP $url $layer $mode}
    }
}

proc LoadURLFitsFTP {host path layer mode} {
    global loadParam
    global ds9
    global debug

    set ftp [ftp::Open $host "ftp" "-ds9@" -mode passive]
    if {$ftp > -1} {
	set fn "$ds9(tmpdir)/[file tail $path]"
	set ftp::VERBOSE $debug(tcl,ftp)
	set "ftp::ftp${ftp}(Output)" FTPLog
	ftp::Type $ftp binary
	if [ftp::Get $ftp $path $fn] {
	    LoadURLFitsFile $fn $layer $mode
	}

	ftp::Close $ftp

	if [file exists $fn] {
	    catch {file delete -force $fn}
	}
    }
}

proc LoadURLFitsFile {fn layer mode} {
    global loadParam

    # alloc it because we can't assume it will last
    set loadParam(file,type) fits
    set loadParam(file,mode) $mode
    set loadParam(load,type) allocgz
    set loadParam(file,name) $fn
    set loadParam(file,fn) $loadParam(file,name)
    set loadParam(load,layer) $layer

    ProcessLoad
}

proc LoadURLFitsHTTP {url layer mode} {
    global ds9
    global ihttp

    ParseURL $url r
    set fn "$ds9(tmpdir)/[file tail $r(path)]"

    set code 200
    set meta {}
    set mime "application/fits"
    set encoding {}

    set ch [open $fn w]
    set token [http::geturl $url \
		   -protocol 1.0 \
		   -timeout $ihttp(timeout) \
		   -channel $ch \
		   -binary 1 \
		   -headers "[ProxyHTTP]"]

    # reset errorInfo (may be set in http::geturl)
    global errorInfo
    set errorInfo {}

    catch {close $ch}

    upvar #0 $token t

    # Code
    set code [http::ncode $token]

    # Meta
    set meta $t(meta)

    # Mime-type
    # we want to strip and extra info after ';'
    regexp -nocase {([^;])*} $t(type) mime

    # Content-Encoding
    foreach {name value} $meta {
	if {[regexp -nocase ^content-encoding $name]} {
	    switch -- [string tolower $value] {
		gzip -
		x-gzip {set encoding gzip}
		compress -
		bzip2 {set encoding bzip2}
		Z {set encoding compress}
		pack -
		z {set encoding pack}
		default {}
	    }
	}
    }

    HTTPLog $token
    # Result?
    switch -- $code {
	200 {}
	default {
	    Error "HTTP [msgcat::mc {Error}] $code"
	    return
	}
    }

    http::cleanup $token

    global debug
    if {$debug(tcl,hv)} {
	puts stderr "Load HTTP: fn $fn : code $code : meta $meta : mime $mime : encoding $encoding"
    }

    # NOTE: error notices may come as text/html
    switch -- [string tolower $mime] {
	"text/plain" {}

	"image/fits" -
	"application/fits" {}

	"application/fits-image" -
	"application/fits-table" -
	"application/fits-group" {}

	"image/x-fits" -
	"binary/x-fits" -
	"application/x-fits" {}

	"image/x-gfits" -
	"binary/x-gfits" -
	"image/gz-fits" -
	"display/gz-fits" {set encoding gzip}

	"image/bz2-fits" -
	"display/bz2-fits" {set encoding bzip2}

	"image/x-cfits" -
	"binary/x-cfits" {set encoding compress}

	"image/x-zfits" -
	"binary/x-zfits" {set encoding pack}

	default {
	    Error "[msgcat::mc {File not Found or Unable to load FITS data MIME type}] $mime"
	    return
	}
    }

    # alloc it because we are going to delete it after load
    StartLoad
    global loadParam

    set loadParam(file,type) fits
    set loadParam(file,mode) $mode
    set loadParam(load,type) allocgz
    set loadParam(file,name) $fn
    set loadParam(file,fn) $loadParam(file,name)
    set loadParam(load,layer) $layer

    # may have to convert the file, based on content-encoding
    switch -- "$encoding" {
	bzip2 {
	    catch {set ch [open "| bunzip2 < $fn " r]}
	    set loadParam(load,type) channel
	    set loadParam(channel,name) $ch
	}
	compress {
	    catch {set ch [open "| uncompress < $fn " r]}
	    set loadParam(load,type) channel
	    set loadParam(channel,name) $ch
	}
	pack {
	    catch {set ch [open "| pcat $fn " r]}
	    set loadParam(load,type) channel
	    set loadParam(channel,name) $ch
	}
    }

    ProcessLoad
    FinishLoad

    if {[file exists $fn]} {
	catch {file delete -force $fn}
    }
}

proc ProcessURLFitsCmd {varname iname} {
    upvar $varname var
    upvar $iname i

    set layer {}
    set mode {}

    switch -- [string tolower [lindex $var $i]] {
	new {
	    incr i
	    CreateFrame
	}
	mask {
	    incr i
	    set layer mask
	}
	slice {
	    incr i
	    set mode slice
	}
    }

    LoadURLFits [lindex $var $i] $layer $mode
}