StreamGoose/tcldep/conf.tcl

#!/usr/bin/env tclsh
package require Tk
package require json
package require json::write
package require inifile

# overall vars
set appdir [ file dirname [ file normalize [ info script ] ] ]
# check if we're running from a starpack
if [string match *app-conf $appdir] {
  set appdir [ file normalize [ file join $appdir ".." ".." ".." ] ]
}
puts "Working directory: $appdir"

set conffile [ file join $appdir "config.json" ]
set labelfile [ file join $appdir "labels.ini" ]

# main configuration read/write procedures

proc readrawjson {fname} {
  # read the JSON contents
  set fp [open $fname r]
  set rawdata [read $fp]
  close $fp
  # parse the JSON contents
  set confdict [::json::json2dict $rawdata]
  return $confdict
}

proc readjson {fname} {
  set confdict [readrawjson $fname]
  # update the controls according to the configuration
  dict for {vname vval} $confdict {
    global conf_$vname
    set conf_$vname $vval
  }
  return $confdict
}

proc dict2json {dictToEncode} {
  ::json::write object {*}[dict map {k v} $dictToEncode {
    if [string is boolean -strict $v] {
      set v $v
    } elseif [string is integer -strict $v] {
      set v $v
    } else {
      set v [::json::write string $v]
    }
  }]
}

proc writejson {fname} {
  set confdict [readrawjson $fname]
  dict for {vname vval} $confdict {
    global conf_$vname
    dict set confdict $vname [set conf_$vname]
  }
  set fdata [dict2json $confdict]
  set fp [open $fname w]
  puts $fp $fdata
  close $fp
}

# dialog button helpers

proc rereadconfig {fname msg} {
  set answer [tk_messageBox -message $msg -icon question -type yesno]
  switch -- $answer {
    yes {readjson $fname}
    no {}
  }
}

proc saveconfig {fname msg} {
  set answer [tk_messageBox -message $msg -icon question -type yesno]
  switch -- $answer {
    yes {writejson $fname}
    no {}
  }
}

proc exitapp {fname msg} {
  saveconfig $fname $msg
  exit
}

# read GUI labels ini file
set lbls [::ini::open $labelfile r]
set backends [::ini::value $lbls general backends]

# overall provider tab layout
ttk::notebook .prov
foreach back $backends {
  set framename .prov.$back
  set tabname [::ini::value $lbls config.gui.$back tabtitle]
  ttk::frame $framename
  .prov add $framename -text $tabname
}

# General controls (need to be hardcoded)

set dbglbl [::ini::value $lbls config.gui.general debug]
set iplbl [::ini::value $lbls config.gui.general server_listen_ip]
set portlbl [::ini::value $lbls config.gui.general server_port]
set ualbl [::ini::value $lbls config.gui.general useragent]
ttk::checkbutton .prov.general.debugchk -text $dbglbl -variable conf_debug -onvalue true -offvalue false
ttk::label .prov.general.serviplbl -text $iplbl
ttk::entry .prov.general.serviptxt -textvariable conf_server_listen_ip -width 16
ttk::label .prov.general.servportlbl -text $portlbl
ttk::entry .prov.general.servporttxt -textvariable conf_server_port -width 5
ttk::label .prov.general.ualbl -text $ualbl
ttk::entry .prov.general.uatxt -textvariable conf_useragent -width 60

grid .prov.general.debugchk -column 0 -row 0 -sticky ne -ipadx 5 -ipady 5
grid .prov.general.serviplbl -column 1 -row 0 -sticky ne -ipadx 5 -ipady 5
grid .prov.general.serviptxt -column 2 -row 0 -sticky ew -padx 5 -pady 5
grid .prov.general.servportlbl -column 3 -row 0 -sticky ne -ipadx 5 -ipady 5
grid .prov.general.servporttxt -column 4 -row 0 -sticky ew -padx 5 -pady 5
grid .prov.general.ualbl -column 0 -row 2 -sticky ne -ipadx 5 -ipady 5
grid .prov.general.uatxt -column 1 -row 2 -sticky ew -columnspan 4 -padx 5 -pady 5

# backend config controls

foreach back $backends {
  if {$back ne "general"} {
    set section config.gui.$back
    set params [::ini::keys $lbls $section]
    set rowidx 1
    foreach key $params {
      if {$key ne "tabtitle"} {
        set lbltext [::ini::value $lbls $section $key]
        set cvarname [string cat conf_ $key]
        set guiname .prov.$back.$key
        if {$key eq [string cat $back _backend_enabled]} {
          set chkname [string cat $guiname chk]
          ttk::checkbutton $chkname -text $lbltext \
            -variable $cvarname -onvalue true -offvalue false
          grid $chkname -column 0 -row 0 -sticky ne -ipadx 5 -ipady 5
        } else {
          set ewidth 40
          set lblname [string cat $guiname lbl]
          set txtname [string cat $guiname txt]
          ttk::label $lblname -text $lbltext
          ttk::entry $txtname -textvariable $cvarname -width $ewidth
          grid $lblname -column 0 -row $rowidx -sticky ne -ipadx 5 -ipady 5
          grid $txtname -column 1 -row $rowidx -sticky ew -padx 5 -pady 5
        }
        incr rowidx
      }
    }
  }
}

# lower button row
foreach lname {reset exit save credits savemodal resetmodal} {
  set vname [string cat $lname lbl]
  set $vname [::ini::value $lbls config.gui.general $lname]
}
ttk::frame .btns -padding 4
ttk::button .btns.reset -text $resetlbl -command {rereadconfig $conffile $resetmodallbl}
ttk::button .btns.exit -text $exitlbl -command {exitapp $conffile $savemodallbl}
ttk::button .btns.save -text $savelbl -command {saveconfig $conffile $savemodallbl}
ttk::label .btns.lbl -text $creditslbl
pack .btns.save -side right -padx 3 -pady 3
pack .btns.exit -side right -padx 3 -pady 3
pack .btns.reset -side right -padx 3 -pady 3
pack .btns.lbl -side left -padx 3 -pady 3

# place the tabs and buttons
grid .prov -column 0 -row 0 -sticky nsew
grid .btns -column 0 -row 1 -sticky sew

# root grid geometry: don't resize the button row
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
grid rowconfigure . 1 -weight 0

# iterate over available platform-dependent themes, apply "clam" if none found
ttk::style theme use clam
catch {ttk::style theme use gtkTtk}
catch {ttk::style theme use aqua}
catch {ttk::style theme use winnative}
catch {ttk::style theme use vista}

wm title . "StreamGoose config"
catch {wm title . [::ini::value $lbls config.gui.general windowtitle]}

# stop working with the labels file
::ini::close $lbls

# read the initial config
readjson $conffile