Initial commit

1 files changed, 162 insertions, 0 deletions

diff --git a/ds9/library/tsv.tcl b/ds9/library/tsv.tcl
new file mode 100644
index 0000000..628d1e9
--- /dev/null
+++ b/ds9/library/tsv.tcl
@@ -0,0 +1,162 @@
+#  Copyright (C) 1999-2016
+#  Smithsonian Astrophysical Observatory, Cambridge, MA, USA
+#  For conditions of distribution and use, see copyright notice in "copyright"
+
+package provide DS9 1.0
+
+proc TSVRead {t fn} {
+    upvar #0 $t T
+    global $t
+
+    global debug
+    if {$debug(tcl,cat) || $debug(tcl,sia)} {
+	puts stderr "TSVRead"
+    }
+
+    if {$fn == {}} {
+	return
+    }
+
+    catch {
+	set fp [open $fn r]
+
+
+	# init db
+	set T(Nrows) 0
+	set T(Ncols) 0
+	set T(Header) {}
+	set T(HLines) 0
+	
+	# ok, get first non comment line
+	while (true) {
+	    if {[gets $fp line] == -1} {
+		return
+	    }
+
+	    # skip any comments
+	    if {[string range $line 0 0] != "#"} {
+		break;
+	    }
+	}
+
+	# reduce number of spaces
+	regsub -all { +} $line { } line
+
+	# strip any quotes
+	regsub -all {\"} $line {} line
+
+	# determine separator
+	if {[llength [split $line "\t"]] > 1} {
+	    set ss "\t"
+	} elseif {[llength [split $line ","]] > 1} {
+	    set ss ","
+	} elseif {[llength [split $line ":"]] > 1} {
+	    set ss ":"
+	} else {
+	    set ss " "
+	}
+
+	# determine header
+	set first {}
+	set foo [split $line $ss]
+	if {([string is integer [lindex $foo 0]] || [string is double [lindex $foo 0]]) && ([string is integer [lindex $foo 1]] || [string is double [lindex $foo 1]])} {
+	    # determine num cols
+	    set cnt [llength $foo]
+
+	    # we need to build an header
+	    set first $line
+
+	    set line "X${ss}Y"
+	    for {set ii 2} {$ii<$cnt} {incr ii} {
+		append line "${ss}column[expr $ii+3]"
+	    }
+	}
+
+	# process header
+	# cols
+	incr ${t}(HLines)
+	set n $T(HLines)
+	set T(H_$n) $line
+	set T(Header) [split $T(H_$n) $ss]
+
+	# dashes
+	set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+	set T(Ndshs) [llength $T(Dashes)]
+	starbase_colmap $t
+
+	# process table
+	if {$first == {}} {
+	    gets $fp line
+	} else {
+	    set line $first
+	}
+
+	while {![eof $fp]} {
+	    # skip any comments
+	    if {[string range $line 0 0] == "#"} {
+		set line {}
+	    }
+
+	    # reduce number of spaces
+	    regsub -all { +} $line { } line
+	    set line [string trim $line]
+
+	    # do we have something?
+	    if {$line != {}} {
+		# ok, save it
+		incr ${t}(Nrows)
+		set r $T(Nrows)
+
+		set NCols [starbase_ncols $t]
+		set c 1
+		foreach val [split $line $ss] {
+		    set T($r,$c) $val
+		    incr c
+		}
+		for {} {$c <= $NCols} {incr c} {
+		    set T($r,$c) {}
+		}
+	    }
+
+	    gets $fp line
+	}
+
+	close $fp
+    }
+}
+
+proc TSVWrite {t fn} {
+    upvar #0 $t T
+    global $t
+
+    global debug
+    if {$debug(tcl,cat) || $debug(tcl,sia)} {
+	puts stderr "TSVWrite"
+    }
+
+    if {$fn == {}} {
+	return
+    }
+
+    set fp [open $fn w]
+
+    set nr $T(Nrows)
+    set nc $T(Ncols)
+
+    # header
+    for {set cc 1} {$cc < $nc} {incr cc} {
+	puts -nonewline $fp "[lindex $T(Header) [expr $cc-1]]\t"
+    }
+    puts $fp "[lindex $T(Header) [expr $nc-1]]"
+
+    # data
+    for {set rr 1} {$rr <= $nr} {incr rr} {
+	for {set cc 1} {$cc < $nc} {incr cc} {
+	    puts -nonewline $fp "$T($rr,$cc)\t"
+	}
+	puts $fp "$T($rr,$nc)"
+    }
+
+    close $fp
+}
+