~aleteoryx/tclircc

6f6e5661f412df88e9e2170d6117b9b3b918d1af — Aleteoryx a month ago dbf7fcb 
cleanup pass
patch browse .tar.gz 
1 files changed, 91 insertions(+), 105 deletions(-)

M irc.tcl

M irc.tcl => irc.tcl +91 -105
@@ 14,7 14,8 @@
# handler: <patlist> <type> <id> <type args...>

namespace eval ::irc {
  variable chanmeta
  variable chan.meta
  variable chan.handlers

  proc ::irc::is {type value {cap {}}} {
    # validation helper.


@@ 97,7 98,6 @@ namespace eval ::irc {

  # documented
  proc ::irc::connect {hostname port {usetls 0}} {
    variable chanmeta
    if $usetls {
      if {[info commands ::tls::socket] == ""} { package require tls }
      set chan [::tls::socket $hostname $port]


@@ 117,10 117,11 @@ namespace eval ::irc {

  # documented
  proc ::irc::enroll {chan {meta {}}} {
    variable chan.meta
    variable chan.handlers
    fconfigure $chan -translation crlf -blocking 0
    dict set meta chan $chan
    dict set meta handlers {}
    set chanmeta($chan) $meta
    set chan.meta($chan) $meta
    set chan.handlers($chan) {}
  }

  # documented


@@ 158,7 159,8 @@ namespace eval ::irc {
    set msg [gets $chan]
    if {$msg == ""} { return }

    variable chanmeta
    variable chan.meta
    variable chan.handlers

    irc::msg parse $msg tags src cmd params
    set src ""


@@ 174,17 176,14 @@ namespace eval ::irc {
                              srcparts $srcparts \
                              cmd $cmd \
                              params $params \
                              meta [dict remove $chanmeta($chan) handlers]]
                              meta [set chan.meta($chan)]]

    foreach handler [dict get $chanmeta($chan) handlers] {
      set patlist [lindex $handler 0]
      set type [lindex $handler 1]
      set id [lindex $handler 2]
    foreach handler [set chan.handlers($chan)] {
      set rest [lassign $handler patlist type id]

      set matched false
      foreach msgpat $patlist {
        set cmdpat [lindex [lindex $handler 0] 0]
        set parampats [lrange [lindex $handler 0] 1 end]
        set parampats [lassign $patlist cmdpat]

        if {[llength $parampats] > [llength $params]} { continue }
        if ![string match $cmdpat $cmd] { continue }


@@ 202,27 201,27 @@ namespace eval ::irc {

      switch -- $type {
        chan {
          set chanid [lindex $handler 3]
          puts $chanid $dispatch
          flush $chanid
          lassign $rest writer interp
          puts $writer $dispatch
          flush $writer
        }
        extern {
          set ochanid [lindex $handler 3]
          puts $ochanid $chan
          puts $ochanid $msg
          flush $ochanid
          lassign $rest ochan ichan
          puts $ochan $chan
          puts $ochan $msg
          flush $ochan
        }
        script {
          set script [lindex $handler 3]
          if {[llength $handler] == 5} {
            set interp [lindex $handler 4]
          set interp [lassign $rest script]
          if [llength $interp] {
            set interp [lindex $interp 0]
          } else {
            set interp [interp create]
            irc::int-setaliases $interp
            interp share {} $chan $interp
          }
          $interp eval [list set dispatch $dispatch]
          $interp eval [list after idle $script]
          {*}$interp eval [list set dispatch $dispatch]
          {*}$interp eval [list after idle $script]
        }
      }
    }


@@ 230,40 229,40 @@ namespace eval ::irc {

  # documented
  proc ::irc::listener {subcommand chan args} {
    variable chanmeta
    variable chan.handlers
    switch -- $subcommand {
      add {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan patlist script\"" }
        set patlist [lindex $args 0]
        set script [lindex $args 1]
        lassign $args patlist script
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        set interp [interp create]
        irc::int-setaliases $interp
        interp share {} $chan $interp

        set pipe [chan pipe]
        set reader [lindex $pipe 0]
        lassign [chan pipe] reader writer
        interp transfer {} $reader $interp
        $interp eval [list set chan $reader]
        $interp eval [list after idle $script]

        dict lappend chanmeta($chan) handlers [list $patlist chan $id [lindex $pipe 1] $interp]
        lappend chan.handlers($chan) [list $patlist chan $id $writer $interp]

        return $id
      }
      remove {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach handler [dict get chanmeta($chan) handlers] {
          if {[lindex $handler 2] != $args} {
        foreach handler [set chan.handlers($chan)]] {
          lassign $handler _ _ handlerid writer
          if {$handlerid != $rmid} {
            lappend newlist $handler
          } else {
            puts [lindex $handler 3] end
            flush [lindex $handler 3]
            puts $writer end
            flush $writer
          }
        }
        dict set chanmeta($chan) handlers $newlist
        set chan.handlers($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }


@@ 271,37 270,35 @@ namespace eval ::irc {

  # documented
  proc ::irc::handler {subcommand chan args} {
    variable chanmeta
    variable chan.handlers
    switch -- $subcommand {
      add {
        if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::handlers add chan patlist script ?interp?\"" }
        set patlist [lindex $args 0]
        set script [lindex $args 1]
        set interp [lassign $args patlist script]
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        set interp ""
        if {[llength $args] == 3} {
          set interp [lindex $args 2]
          irc::int-setaliases $interp
          interp share {} $chan $interp
          set interp [list $interp]
        if [llength $interp] {
          irc::int-setaliases {*}$interp
          interp share {} $chan {*}$interp
        }

        dict lappend chanmeta($chan) handlers [concat [list $patlist script $id $script] $interp]
        lappend chan.handlers($chan) [list $patlist script $id $script {*}$interp]

        return $id
      }
      remove {
        if {[llength args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach handler [dict get chanmeta($chan) handlers] {
          if {[lindex $handler 2] != $args} {
        foreach handler [set chan.handlers($chan)] {
          set interp [lassign $handler _ _ handlerid _]
          if {$handlerid != $rmid} {
            lappend newlist $handler
          } else {
            interp delete [lindex $handler 4]
          } elseif [llength $interp] {
            interp delete {*}$interp
          }
        }
        dict set chanmeta($chan) handlers $newlist
        set chan.handlers($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }


@@ 310,23 307,22 @@ namespace eval ::irc {
  # nodoc
  proc ::irc::int-onextern {ichan chan} {
    set msg [gets $ichan]
    if [$msg == ""] return
    if {$msg == ""} return
    puts $chan $msg
    flush $chan
  }
  # documented
  proc ::irc::extern {subcommand chan args} {
    variable chanmeta
    variable chan.handlers
    switch -- $subcommand {
      add {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::extern add chan patlist ochan ichan\"" }
        set patlist [lindex $args 0]
        set ochan [lindex $args 1]
        set ichan [lindex $args 2]
        if {[llength $args] != 3} { return -code error "wrong # args: should be \"irc::extern add chan patlist ochan ichan\"" }
        lassign $args patlist ochan ichan
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        dict lappend chanmeta($chan) handlers [list $patlist extern $id $ochan $ichan]
        lappend chan.handlers($chan) [list $patlist extern $id $ochan $ichan]

        fileevent $chan readable [list ::irc::int-onextern $ichan $chan]
        fileevent $ichan readable [list ::irc::int-onextern $ichan $chan]

        return $id
      }


@@ 334,15 330,16 @@ namespace eval ::irc {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::extern remove chan id\"" }
        set newlist ""
        foreach handler [dict get chanmeta($chan) handlers] {
          if {[lindex $handler 2] != $args} {
          lassign $handler _ _ handlerid ochan ichan
          if {$handlerid != $rmid} {
            lappend newlist $handler
          } else {
            puts [lindex $handler 3] $chan
            puts [lindex $handler 3] end
            close [lindex $handler 4]
            puts $ochan $chan
            puts $ochan end
            close $ichan
          }
        }
        dict set chanmeta($chan) handlers $newlist
        set chan.handler($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }


@@ 374,7 371,7 @@ namespace eval ::irc {
    switch -- $subcommand {
      parse {
        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::src parse src ?partsVar?\"" }
        set src [lindex $args 0]
        lassign $args src
        set partsVar ""
        if {[llength $args] == 1} { set partsVar [lindex $args 1] }



@@ 395,7 392,8 @@ namespace eval ::irc {
      }
      servername {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::src server servername\"" }
        if ![irc::is src::servername $args] { return -code error "argument is not a servername" }
        lassign $args servername
        if ![irc::is src::servername $servername] { return -code error "argument is not a servername" }
        return $args
      }
      user {


@@ 403,16 401,14 @@ namespace eval ::irc {

        set user ""
        if {[lindex $args 0] == "-user"} {
          set user [lindex $args 1]
          set args [lassign $args _ user]
          if ![irc::is src::part $user] { return -code error "-user argument is not a user" }
          set args [lrange $args 2 end]
          set user "!$user"
        }
        set host ""
        if {[lindex $args 0] == "-host"} {
          set host [lindex $args 1]
          set args [lassign $args _ host]
          if ![irc::is src::part $host] { return -code error "-host argument is not a host" }
          set args [lrange $args 2 end]
          set host "@$host"
        }



@@ 430,8 426,7 @@ namespace eval ::irc {
    switch -- $subcommand {
      exists {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags exists tags key\"" }
        set tags [lindex $args 0]
        set key [lindex $args 1]
        lassign $args tags key

        foreach tag [split $tags ";"] {
          if { ![string first "$key=" $tag] || $tag == $key } { return true }


@@ 440,9 435,8 @@ namespace eval ::irc {
      }
      remove {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags remove tags key\"" }
        set tags [lindex $args 0]
        lassign $args tags key
        set ret ""
        set key [lindex $args 1]

        foreach tag [split $tags ";"] {
          if { [string first "$key=" $tag] && $tag != $key } {


@@ 454,11 448,11 @@ namespace eval ::irc {
      }
      get {
        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::tags get tags ?key?\"" }
        set tags [lindex $args 0]
        set key [if {[llength $args] == 2} {lindex $args 1}]
        set key [lassign $args tags]

        if {$key == ""} {
        if ![llength $key] {
          set ret ""

          foreach tag [split $tags ";"] {
            set split [string first = $tag]
            set key [string range $tag 0 $split-1]


@@ 468,6 462,7 @@ namespace eval ::irc {
          return $ret
        }

        lassign $key key
        foreach tag [split $tags ";"] {
          if {![string first "$key=" $tag]} {
            return [irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]


@@ 478,16 473,14 @@ namespace eval ::irc {
      }
      set {
        if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::tags set tags key ?value?\"" }
        set tags [lindex $args 0]
        set value [lassign $args tags key]
        set ret ""
        set key [lindex $args 1]
        set value [if {[llength $args] == 3} { lindex $args 2 }]
        set found false

        set found false
        foreach tag [split $tags ";"] {
          if { !$found && ![string first "$key=" $tag] || $tag == $key } {
            if {$value != ""} {
              append ret "$key=[irc::esc tags::value $value];"
            if [llength $value] {
              append ret "$key=[irc::esc tags::value {*}$value];"
            } else {
              append ret "$key;"
            }


@@ 498,8 491,8 @@ namespace eval ::irc {
        }

        if !$found {
          if {$value != ""} {
            append ret "$key=[irc::esc tags::value $value];"
          if [llength $value] {
            append ret "$key=[irc::esc tags::value {*}$value];"
          } else {
            append ret "$key;"
          }


@@ 538,7 531,7 @@ namespace eval ::irc {
      }
      dict {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::tags dict tags\"" }
        set tags [lindex $args 0]
        lassign $args tags

        set ret ""
        foreach tag [split $tags ";"] {


@@ 562,25 555,22 @@ namespace eval ::irc {

        # TODO: unordered flag parsing
        if {[lindex $args 0] == "-tags"} {
          set args [lassign $args _ tags]
          if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
          set msg "@[irc::tags merge [lindex $args 1]] "
          set args [lrange $args 2 end]
          set msg "@[irc::tags merge $tags] "
        }

        if {[lindex $args 0] == "-src"} {
          if {[llength $args] < 3} { return -code error "missing src argument to -src option" }
          set src [lindex $args 1]
          set args [lassign $args _ src]
          if ![irc::is src $src] { return -code error "-src argument is not a src" }
          append msg ":$src "
          set args [lrange $args 2 end]
        }

        set cmd [lindex $args 0]
        set args [lassign $args cmd]
        if ![irc::is cmd $cmd] { return -code error "invalid irc command \"$cmd\"" }
        append msg "[string toupper $cmd] "

        set args [lrange $args 1 end]

        if ![llength $args] { return [string range $msg 0 end-1] }

        set trailing [lindex $args end]


@@ 598,8 588,7 @@ namespace eval ::irc {
      }
      send {
        if {[llength $args] < 2} { return -code error "wrong # args: should be \"irc::msg send chan ?-tags tags? ?-src src? cmd ?arg ...? \"" }
        set chan [lindex $args 0]
        set args [lrange $args 1 end]
        set args [lassign $args chan]
        puts $chan "[irc::msg fmt {*}$args]\n"
        flush $chan
      }


@@ 608,11 597,11 @@ namespace eval ::irc {
      # there's no risks, but it might behave oddly with a broken server.
      parse {
        if {[llength $args] != 5} { return -code error "wrong # args: should be irc::msg parse message tagsVar srcVar cmdVar paramsVar" }
        set message [lindex $args 0]
        upvar [lindex $args 1] tags
        upvar [lindex $args 2] src
        upvar [lindex $args 3] cmd
        upvar [lindex $args 4] params
        lassign $args message tagsVar srcVar cmdVar paramsVar
        upvar $tagsVar tags
        upvar $srcVar src
        upvar $cmdVar cmd
        upvar $paramsVar params

        # tags
        set tags ""


@@ 661,10 650,7 @@ namespace eval ::irc {
set chan [irc::connect localhost 8000 0]
puts $chan
irc::listen on $chan
irc::handler add $chan FOO {
  puts $rawmsg
  puts $chan "FOO2 BAR2"
  flush $chan
}
lassign [chan pipe] ichan ochan
irc::extern add $chan * $ochan $ichan

vwait foo