gui/implementation/TableBox.tcl


@implementation TableBox {
  - init {} {
      $super init
      set counter 1
      set separator {}
      $super hideBorder
      $frame configure -relief sunken -bd 1
      frame $frame.f

      canvas $frame.f.headers -bd 0 -relief flat -width 10 -height 10 
      pack $frame.f.headers -fill both -expand 1
      $frame.f.headers create window 0 0 \
        -window [set headers [frame $frame.f.headers.frame -bd 0]] \
        -anchor nw -tag headers
      canvas $frame.f.main -bd 0 -relief flat -width 10 -height 10 
      $frame.f.main create window 0 0 \
        -window [set main [frame $frame.f.main.frame -bd 0]] \
        -anchor nw -tag main

      set xscroll [scrollbar $frame.xscroll -orient horizontal \
        -command "$self xview"]
      set yscroll [scrollbar $frame.yscroll -orient vertical \
        -command "$self yview"]

      $frame.f.main configure -xscrollcommand [list $xscroll set]

      grid $frame.f $frame.yscroll -sticky snew -padx 0 -pady 0
      grid $frame.xscroll -sticky snew -padx 0 -pady 0
      grid rowconfigure $frame 0 -weight 1
      grid columnconfigure $frame 0 -weight 1

      grid $frame.f.headers -sticky snew -padx 0 -pady 0
      grid $frame.f.main -sticky snew -padx 0 -pady 0
      grid rowconfigure $frame.f 1 -weight 1
      grid columnconfigure $frame.f 0 -weight 1

      set callbacks(Selection) {}

      $self on: Configure do: {
        set w [eventData get: path]
        if {"$w" == "$frame.f.main.frame"} {
            $frame.f.main configure -scrollregion [set bbox [$frame.f.main bbox all]]
            $frame.f.headers configure -scrollregion $bbox
        } elseif {"$w" == "$frame.f.headers.frame"} {
            $frame.f.headers configure \
              -height [winfo height $frame.f.headers.frame] 
        } elseif {"$w" == "$frame.headers"} {
            $frame.f.headers configure \
              -height [winfo height $frame.f.headers.frame] \
              -scrollregion [$frame.f.headers bbox all]
        } elseif {"$w" == "$frame.f.main"} {
            $frame.f.main itemconfigure [$frame.f.main find withtag main] \
              -height [winfo height $frame.f.main]
            $frame.f.main configure -scrollregion [set bbox [$frame.f.main bbox all]]
            $frame.f.headers configure -scrollregion $bbox
        }
      }
      
      $self enableEvent: Configure \
                     on: [list $frame.f.main.frame $frame.f.headers.frame \
                               $frame.f.main $frame.f.headers]

      $self on: ButtonPress-1 do: {
        $self rowOfSelection: [[eventData get: path] nearest [eventData get: y]]
        $self selectionChange
      }
      $self on: B1-Motion do: {
        $self rowOfSelection: [[eventData get: path] nearest [eventData get: y]]
        $self selectionChange
      }
      $self on: Button-4 do: {
        foreach column [pack slaves $main] {
          if {"[eventData get: path]" != "$column"} {
            $column yview scroll -5 units
          }
        }
      }
      $self on: Button-5 do: {
        foreach column [pack slaves $main] {
          if {"[eventData get: path]" != "$column"} {
            $column yview scroll +5 units
          }
        }
      }
    }

  - columns: columns {
      if [string length $separator] {
        foreach column [split $columns $separator] { $self addColumn: $column }
      } else {
        foreach column $columns { $self addColumn: $column }
      }
    }
  - columns {} {
      set columns {}
      foreach column [pack slaves $headers] {
        lappend columns [$column get 0 end]
      }
      if [string length $separator] {
        return [join $columns $separator]
      } else {
        return $columns
      }
    }
  - rowOfSelection: row {
      foreach column [pack slaves $main] {
        $column selection clear 0 end
        if [string length $row] {
          $column select anchor $row
          $column select set anchor $row
          set rowOfSelection $row
        }
      }
    }
  - rowOfSelection {} {
      return $rowOfSelection
    }
  - selection {} {
      return [$self row: $rowOfSelection]
    }
  - row: aRow {
      set result {}
      set columns [pack slaves $main]
      if {[llength $columns] == 0} { return }
      foreach column $columns {
        lappend result [$column get $i]
      }
      if [string length $separator] {
        return [join [string trimright $result \n] $separator]
      } else {
        return [string trimright $result \n]
      }
    }
  - addColumn: column {
      global tcl_platform

      set length [expr [string length $column] + 3]
      pack [listbox $headers.$counter -relief raised -bd 1 -width $length \
        -height 1 -exportselection no \
        -background [$frame.f.headers cget -bg] \
        -selectbackground [$frame.f.headers cget -bg]] \
        -side left -fill y -expand 1 -padx 0 -pady 0
      $headers.$counter insert end $column
      pack [listbox $main.$counter -width $length -height 5 \
        -relief raised -bd 1 \
        -exportselection no -yscrollcommand [list $yscroll set]] \
        -side left -fill y -expand 1 -padx 0 -pady 0

      $headers configure -width [winfo reqwidth [winfo parent $headers]]

      $self enableEvent: {ButtonPress-1 B1-Motion Button-4 Button-5} \
                     on: $main.$counter
      incr counter
    }

  - add: record {
      set columns [pack slaves $main]
      if {[string length $separator]} {
        if {[llength [split $record $separator]] > [llength $columns]} {
          set record [join [lrange [split $record $separator] 0 [expr [llength $columns] -1]] $separator]
        }
        set items [split $record $separator]
      } else {
        if {[llength $record] > [llength $columns]} {
          set record [join [lrange $record 0 [expr [llength $columns] -1]]]
        }
        set items $record
      }

      foreach column $columns item $items {
        if {[set len [expr [string length $item] +3]] \
          > [$column cget -width]} {
          $column configure -width $len
          $headers.[lindex [split $column .] end] configure -width $len
        }
        $column insert end $item
      }
    }
  - insert:atRow: {record row} {
      set columns [pack slaves $main]
      if {[string length $separator]} {
        if {[llength [split $record $separator] > [llength $columns]} {
          set record [join [lrange [split $record $separator] 0 [expr [llength $columns] -1]] $separator]
        }
      } else {
        if {[llength $record] > [llength $columns]} {
          set record [join [lrange $record 0 [expr [llength $columns] -1]]]
        }
      }

      foreach column $columns item [split $record $separator] {
        if {[set len [expr [string length $item] +3]] \
          > [$column cget -width]} {
          $column configure -width $len
          $headers.[lindex [split $column .] end] configure -width $len
        }
        $column insert $row $item
      }
    }
  - deleteRow: row {
      foreach column [pack slaves $main] {
        $column delete $row $row
      }
    }
  - loadFromFile: aFile {
      if [catch {set f [open $aFile r]} err] {
        @error "$self loadFromFile: $aFile ($err)"
        return -1
      }
      gets $f line
      if {[string length $separator]} {
        set len [llength [split $line $separator]]
      } else {
        set len [llength $line]
      }
      if {![string length [$self columns]]} {
        for {set i 1} {$i <= $len} {incr i} {
          $self addColumn: $i
        }
      }

      while {[eof $f] == 0} {
        gets $f line
        if [string length $line] { 
          $self add: $line 
        }
      }
      close $f
    }
  - content {} {
      set result {}
      set columns [pack slaves $main]
      if {[llength $columns] == 0} { return }
      for {set i 0} {$i < [[lindex $columns 0] size]} {incr i} {
        set line {}
        foreach column $columns {
          append line [$column get $i],
        }
        append result [string trimright $line ,]\n
      }
      return [string trimright $result \n]
    }
  - xview {args} {
      eval [winfo parent $headers] xview $args
      eval [winfo parent $main] xview $args
    }
  - yview {args} {
      foreach l [pack slaves $main] {
        eval $l yview $args
      }
    }
  - onSelection: aCallback {
      set callbacks(Selection) $aCallback
    }
  - onSelection {} {
      return $callbacks(Selection)
    }
  - selectionChange {} {
      catch {eval $callbacks(Selection)}
    }
  - separator {} { return $separator }
  - separator: _separator { set separator $_separator }
  - dealloc {} { 
      catch {destroy $main $headers}
      return [$super dealloc]
    }
}