## 
#
# query.tcl v1.7 by strikelight
#
##
#
# Description:
#
# This script will query a server on connection (and on command) and if that
# server supports the query protocol, the script will display the users and the
# channels that the server contains.
#
#
# query.tcl requires tools.tcl to be loaded.
#
##
#
# Usage:
#
# Script automatically obtains information upon connection to query-compatible server.
# To Re-Query the server, either type /query in the partyline OR right click
# in the partyline, choose Server Commands, and then Re-Query Server.
#
# To Query a remote server, type /query <server> in the partyline, where <server> is the
# server you wish to query. (ie. /query tetrinet.us)
#
##
#
# Installation:
#
# query.tcl comes pre-installed with BTrix, but if you happen to remove it and wish to reinstall,
# then take the following steps:
#
# 1) save query.tcl to your scripts directory
# 2) Edit startup.tcl in a text editor and add "source scripts/query.tcl" to the end
#    -OR- in the partyline type /install query.tcl
# 3) Restart Blocktrix
#
##
#
# v1.2 - fixed bug with servers that don't implement channel priority
# v1.3 - added usage of description command
# v1.4 - fixed bug with query.tcl not working with btrix://, tnet://, tfast:// browser links
# v1.7 - added some fail-safes
##

describe "This script will query a server on connection (and on command) and if that \
server supports the query protocol, the script will display the users and the \
channels that the server contains."

if {![info exists tetrix]} { set tetrix 0 }

proc queryserver {server {port 31457}} {
  global query
  closetab "@ Channels"
  closetab "@ Users"
  catch {unset query(users)}
  catch {unset query(chans)}
  if {[set fd [Connect $server $port]] != ""} {
    if {$port == "31457"} {
      fileevent $fd writable [list query:chanwrite $fd $server $port]
#      fileevent $fd readable [list query:chanread $fd $server $port]
    } else {
      fileevent $fd writable [list query:userwrite $fd $server $port]
#      fileevent $fd readable [list query:userread $fd $server $port]
    }
  } elseif {$port == "31457"} {
    set port 30777
    if {[set fd [Connect $server $port]] != ""} {
      fileevent $fd writable [list query:userwrite $fd $server $port]
#      fileevent $fd readable [list query:userread $fd $server $port]
    } else {
# couldn't connect... net problem... disconnect
      if {[isconnected]} { disconnect }
    }
  }
}

proc query:autoupdate {} {
  global query
  if {[isconnected]} {
    queryserver [setserver]
  }
  set query(atimer) [after 600000 query:autoupdate]
}

proc query:chanwrite {fd server port} {
  global query
  set query(chans) ""
  set a [format %c 255]
  if {$port == 31457} {
    puts $fd "listchanÿ"
  } else {
    puts $fd "ÿlistchan"
  }
  catch {fileevent $fd writable {}}
  fileevent $fd readable [list query:chanread $fd $server $port]
}

proc query:chanread {fd server port} {
  global query
  set i 0
  catch {fconfigure $fd -encoding ascii}
  set data2 [gets $fd]
  catch {set data2 [encoding convertfrom identity $data2]}
  if {[string match "*+OK*" [string trim $data2]]} {
    Disconnect $fd
    closetab "@ Channels"
    addtab "@ Channels"
    tabfont "@ Channels" "Courier New" 8
    set i 0
    set a [format %c 4]
    foreach element $query(chans) {
      incr i
      if {$port == 31457} {
        regexp {\"([^\"]*)\" \"(.*)\" ([0-6]*) ([0-6]*) (.*) ([1-3]*)} $element - chan desc players max pri status
        switch -- $status {
          "1" { set status "OPEN  " }
          "2" { set status "INGAME" }
          "3" { set status "PAUSED" }
        }
        if {$players == $max} { set status "FULL  " }
        tablog "@ Channels" "[format %-6s%-17s%-17s "($i)" "[blue]$chan[blue]" "\[[red]$status[red]-$players/$max\]"]"
      } else {
        set chan [lindex [split $element] 0]
        set players [lindex [split $element] 1]
        set desc [join [lrange [split $element] 2 end]]
        tablog "@ Channels" "[format %-6s%-17s "($i)" "[blue]$chan[blue]"] ($players)"
      }
      if {[string trim $desc] != ""} {tablog "@ Channels" "${a}${a} `--> [bold][encoding convertfrom identity $desc][bold]"}
      set next 1
    }      
  } else {
    lappend query(chans) $data2
  }
  after 10
#  plinelog ": $data2"
  if {[info exists next] || [catch {eof $fd}] || [eof $fd] || ($data2 == "")} {
    catch {fileevent $fd readable {}}
    if {($port == 31457) && ([set fd [Connect $server $port]] != "")} {
      fileevent $fd writable [list query:userwrite $fd $server $port]
#      fileevent $fd readable [list query:userread $fd $server $port]
    } else {
      catch {Disconnect $fd}
    }
  }
}

proc query:userwrite {fd server port} {
  global query
  set query(users) ""
  set a [format %c 255]
  if {$port == "31457"} {
    puts $fd "listuserÿ"
  } else {
    puts $fd "ÿquery"
  }
  catch {fileevent $fd writable {}}
  fileevent $fd readable [list query:userread $fd $server $port]
}

proc query:userread {fd server port} {
  global query
  set i 0
  catch {fconfigure $fd -encoding ascii}
  set data2 [gets $fd]
  catch {set data2 [encoding convertfrom identity $data2]}
  if {$port == "31457"} {
    if {[string match "*+OK*" [string trim $data2]]} {
      Disconnect $fd
      closetab "@ Users"
      addtab "@ Users"
      tabfont "@ Users" "Courier New" 8
      set i 0
      set buffer ""
      set maxnick 0
      set maxteam 0   
      foreach element $query(users) {
        regsub -all {\\} $element ":slash" element
        if {![regexp {\"([^\"].*)\" \"(.*)\" \"(.*)\" [0-6] [0-2] [0-9] \"(.*)\"} $element - nick team version chan]} {
          set element [split [string trim $element]]  
          set nick [string range [lindex $element 0] 1 [expr [string length [lindex $element 0]] - 2]]  
          set team [string range [lindex $element 1] 1 [expr [string length [lindex $element 1]] - 2]]  
          set version [string range [lindex $element 2] 1 [expr [string length [lindex $element 2]] - 2]]  
          set chan [string range [lindex $element 6] 1 [expr [string length [lindex $element 6]] - 2]]
        }
        regsub -all {:slash} $nick {\\} nick
        regsub -all {:slash} $team {\\} team
        regsub -all {:slash} $chan {\\} chan
        lappend buffer [list $nick $team $chan]
        if {[string length $nick] > $maxnick} { set maxnick [string length $nick] }
        if {[string length $team] > $maxteam} { set maxteam [string length $team] }
        set next 1
      }
      foreach line $buffer {
        incr i
        set nick [lindex $line 0]
        set team [lindex $line 1]
        set chan [lindex $line 2]
        set ncnick [stripcodes $nick]
        set ncteam [stripcodes $team]
        set adif [expr {[string length $nick] - [string length $ncnick]}]
        set bdif [expr {[string length $team] - [string length $ncteam]}]
        if {$adif != 0} { 
          set a [expr {$maxnick + 1 + $adif + 2}]
        } else {
          set a [expr {$maxnick + 1 + 2}]
        }
        if {$bdif != 0} {
          set b [expr {$maxteam + 1 + $bdif + 2}]
        } else {
          set b [expr {$maxteam + 1 + 2}]
        }
        tablog "@ Users" "[format %-6s%-${a}s%-${b}s "($i)" "[blue][encoding convertfrom identity $nick][blue]" "[purple][encoding convertfrom identity $team][purple]"] [bold]$chan[bold]"
      }
    } else {
      lappend query(users) $data2
    }
  } else {
    if {[string match "*layers:*" $data2]} {
      set maxnick 0
      set buffer ""
      Disconnect $fd
      closetab "@ Users"
      addtab "@ Users"
      tabfont "@ Users" "Courier New" 8
      set data2 [lrange [split $data2] [expr [lsearch [split $data2] *layers:] + 1] [llength [split $data2]]]
      set i 0
#      set channels ""
      foreach nick $data2 {
        set chan "N/A"
        if {[string match "*@#*" $nick]} {
          regexp {@(#.*)$} $nick - chan
#          if {[lsearch $channels $chan] == -1} { lappend channels $chan }
          regsub "@$chan" $nick "" nick
        }
        if {[string length $nick] > $maxnick} { set maxnick [string length $nick] }
        lappend buffer [list $nick $chan]
      }
      foreach line $buffer {
        incr i
        set nick [lindex $line 0]
        set chan [lindex $line 1]
        set ncnick [stripcodes $nick]
        set adif [expr {[string length $nick] - [string length $ncnick]}]
        if {$adif != 0} { 
          set a [expr {$maxnick + 1 + $adif + 2}]
        } else {
          set a [expr {$maxnick + 1 + 2}]
        }
        tablog "@ Users" "[format %-6s%-${a}s "($i)" "[blue][encoding convertfrom identity $nick][blue]"] [bold]$chan[bold]"
      }

    }
  }
  if {[info exists next] || [catch {eof $fd}] || [eof $fd]} {
    catch {fileevent $fd readable {}}
    if {($port != 31457) && ([set fd [Connect $server $port]] != "")} {
      fileevent $fd writable [list query:chanwrite $fd $server $port]
#      fileevent $fd readable [list query:chanread $fd $server $port]
    }
  }
}

#    if {[set fd [Connect [setserver] 31457]] != ""} {
#      fileevent $fd writable [list query:userwrite $fd]
#      fileevent $fd readable [list query:userread $fd]
#    }
#  }

addbind plinemsg query:plinemsg
proc query:plinemsg {player text} {
  global tetrix
# might be in server or playback mode ...
  if {![isconnected]} { return 0 }
  set a [format %c 4]
  if {!($tetrix) && ($player == "Server")} {
    set code 0
    foreach i [split $text ""] {
      scan $i %c b
      if {($b >= 1) && ($b <= 31)} {
        set code 1
        break
      }
    }
  }
  if {($player == "Server") && ([string match "*$a$a$a$a$a$a$a$a*" $text]) && !($tetrix)} {
    set tetrix 1
    queryserver [setserver]
  } elseif {!($tetrix) && ($player == "Server") && ($code) && ([setmode] != "Blocktrix")} {
    set tetrix 1
    queryserver [setserver]
  }
  return 0
}

addbind disconnect query:disconnect
proc query:disconnect {} {
  global tetrix
  set tetrix 0
}

addbind connect query:connect
proc query:connect {} {
  closetab "@ Users"
  closetab "@ Channels"
  if {[setmode] == "Blocktrix"} {
    queryserver [setserver] 30777
  }
}

addmenuitem "Server Commands^Re-Query Server" query:requery
proc query:requery {} {
  if {![isserver] && [isconnected]} {
# && ([setmode] != "Blocktrix")
    if {[setmode] != "Blocktrix"} {
      queryserver [setserver]
    } else {
      queryserver [setserver] 30777
    }
  }
}

addbind pmsgout query:pline
proc query:pline {text} {
  set cmd [string tolower [lindex [split $text] 0]]
  set server [lindex [split $text] 1]
  set mode [lindex [split $text] 2]
  set port "31457"
  if {[string tolower $mode] == "blocktrix"} { set port "30777" }
  if {$cmd == "/query"} {
    if {$server == ""} {
      if {[isconnected] && ([setmode] == "Blocktrix")} { set port "30777" }
      set server [setserver] 
    }
    queryserver $server $port
    return 1
  } elseif {$cmd == "/autoquery"} {
    global query
    if {$server == "on"} {
      if {![info exists query(atimer)]} {
        set query(atimer) [after 600000 query:autoupdate]
      }
      set query(auto) 1
      plinelog "[blue]Auto-Query Turned On[blue]"
      return 1
    } elseif {$server == "off"} {
      if {[info exists query(atimer)]} {
        catch {after cancel $query(atimer)}
        catch {unset query(atimer)}
      }
      set query(auto) 0
      plinelog "[blue]Auto-Query Turns Off[blue]"
      return 1
    } else {
      plinelog "[blue]Auto-Query is currently set to $query(auto)[blue]"
      return 1
    }
  }
  return 0
}

set query(auto) 0

plinelog "query.tcl v1.7 by strikelight now loaded"
