#
package require picoirc 0.5; # tcllib
+package require chatwidget
+catch {package require tooltip}
variable ircuid
if {![info exists ircuid]} { set ircuid -1 }
set id irc[incr ircuid]
set Chat [namespace current]::$id
upvar #0 $Chat chat
- array set chat [list app $app type irc passwd "" nick ""]
+ array set chat [list app $app type irc passwd "" nick ""\
+ bytes_read 0 bytes_write 0]
while {[string match -* [set option [lindex $args 0]]]} {
switch -exact -- $option {
-server { set chat(server) [Pop args 1] }
# FIX ME:
}
-proc IrcAddChannel {Chat channel} {
+# Reshow and optionally raise a tab window
+proc IrcRaiseChannel {Chat channel {raise false}} {
upvar #0 $Chat chat
+ set w $chat(window)$channel
+ if {[catch {$chat(app).nb index $w}]} {
+ $chat(app).nb add $w -text $channel
+ }
+ if {$raise} {$chat(app).nb select $w}
+ return
+}
+
+# Add a new tab for a channel or re-show a closed window.
+proc IrcAddChannel {Chat channel {raise true}} {
+ upvar #0 $Chat chat
+ if {[winfo exists $chat(window)$channel]} {
+ IrcRaiseChannel $Chat $channel $raise
+ return
+ }
set Channel "${Chat}/$channel"
upvar #0 $Channel chan
array set chan [array get chat]
$chan(window) chat tag bind URL <Enter> [list UrlEnter %W]
$chan(window) chat tag bind URL <Leave> [list UrlLeave %W]
$chan(window) chat tag bind URL <Button-1> [list UrlClick %W %x %y]
- $chat(window) names configure -wrap none
+ $chan(window) names configure -wrap none
$chan(window) names tag bind NICK <Button-3> \
- [list [namespace origin IrcChannelNickMenu] $Channel %W %x %y]
+ [list [namespace origin IrcChannelNickMenu] $Chat $Channel %W %x %y]
$chan(window) names tag bind NICK <Enter> \
[list [namespace origin IrcNickTooltip] $Chat enter %W %x %y]
$chan(window) names tag bind NICK <Leave> \
[list [namespace origin IrcNickTooltip] $Chat leave %W %x %y]
$chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+ bind $chan(window) <Button-3> [list IrcChatContextMenu $Chat $Channel %W %x %y]
$chat(app).nb add $chan(window) -text $channel
- after idle [list $chat(app).nb select $chan(window)]
+ if {$raise} {
+ after idle [list $chat(app).nb select $chan(window)]
+ }
return
}
}
}
-proc IrcChannelNickMenu {Channel w x y} {
+proc IrcChatContextMenu {Chat Channel w x y} {
+ set m $w.contextmenu
+ destroy $m
+ menu $m -tearoff 0
+ $m add command -label "IRC Commands" -state disabled
+ $m add command -label "Paste ..." -command [list PasteDialog $Chat]
+ tk_popup $m [winfo pointerx $w] [winfo pointery $w]
+}
+
+proc IrcChannelNickMenu {Chat Channel w x y} {
+ upvar #0 $Channel channel
set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
if {$nick eq ""} { return }
+ if {[catch {$channel(window) name get $nick -group} group]} { return }
destroy $w.popup
set m [menu $w.popup -tearoff 0]
$m add command -label "$nick" -state disabled
$m add separator
- $m add command -label "Whois" -underline 0 \
- -command [list [namespace origin IrcChannelNickCommand] $Channel whois $nick]
- $m add command -label "Version" \
- -command [list [namespace origin IrcChannelNickCommand] $Channel version $nick]
+ switch -exact -- $group {
+ users - operators {
+ $m add command -label "Chat" \
+ -command [list [namespace origin IrcAddChannel] $Chat $nick]
+ $m add command -label "Whois" -underline 0 \
+ -command [list [namespace origin IrcChannelNickCommand] \
+ $Channel whois $nick]
+ $m add command -label "Version" \
+ -command [list [namespace origin IrcChannelNickCommand] \
+ $Channel version $nick]
+ }
+ jabber {
+ $m add command -label "(jabber user)" -state disabled
+ }
+ default {
+ $m add command -label "(unknown group)" -state disabled
+ }
+ }
tk_popup $m [winfo pointerx $w] [winfo pointery $w]
}
}
proc IrcNickTooltip {Chat type w x y} {
- if {[package provide tooltip] eq {}} { return }
- set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
- if {$nick eq ""} { return }
- #puts stderr "Tooltip $type $nick"
- upvar #0 $Chat chat
- upvar #0 $chat(irc) context
- if {![info exists context(whois,$nick)]} { return }
- set data [dict get $context(whois,$nick) userinfo]
- append data @[dict get $context(whois,$nick) host]
- append data "\nis on " [join [dict get $context(whois,$nick) channels] ", "]
- after idle [list ::tooltip::tooltip $w -tag NICK-$nick $data]
+ #set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ #if {$nick eq ""} { return }
return
}
Status $Chat "Attempting to connect to $irc(server)"
}
connect {
+ puts "connection connect: $args"
+ array set irc {retry 1 retry_delay 10000}
$chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
Status $Chat "Connection to IRC server established."
State $Chat connected
}
close {
+ puts "connection close: $args"
if {[llength $args] != 0} {
$chat(window) message "Failed to connect: [lindex $args 0]" -type system
Status $Chat [lindex $args 0]
Status $Chat "Disconnected."
}
State $Chat !connected
+ if {$irc(retry)} {
+ Status $Chat "Attempting to reconnect..."
+ set irc(retry) 0
+ after $irc(retry_delay) [list ::picoirc::reconnect $context]
+ }
}
userlist {
foreach {target users} $args break
set nick [string range $nick 1 end]
lappend opts -group operators
} else { lappend opts -group users }
+ set nick [string trimleft $nick "+"] ;# remove prefixes
if {[lsearch -index 0 $current $nick] == -1} {
lappend opts -color \
[lindex $colors [expr {int(rand() * [llength $colors])}]]
array set info {name {} host {} channels {} userinfo {}}
array set info $userinfo
set chat(userinfo,$nick) [array get info]
+ set t "$info(userinfo)@$info(host)"
+ Status $Chat "$nick is $t"
+ append t "\non [join $info(channels) {, }]"
+ set w [[$chat(app).nb select] names]
+ catch {tooltip::tooltip $w -tag NICK-$nick $t}
}
chat {
foreach {target nick msg type} $args break
if {$type eq ""} {set type normal}
- set w [IrcFindWindow $Chat $target]
+ # If the target is my nick then it is a privmsg direct to me - see
+ # if we have a conversation window for this sender else create one
+ if {$target eq $chat(nick)} {
+ IrcAddChannel $Chat $nick false
+ set w [IrcFindWindow $Chat $nick]
+ } else {
+ set w [IrcFindWindow $Chat $target]
+ }
if {$nick eq "tcl@tach.tclers.tk"} {
set action ""; set jnick "" ; set jnew ""
if {[regexp {^\s*([^ ]+) is now known as (.*)} $msg -> jnick jnew]} {
}
debug {
foreach {type line} $args break
+ incr chat(bytes_$type) [string length $line]
+ if {[string match "PING*" $line]} { return }
+ if {[string match "PONG*" $line]} { return }
Debug $Chat $line $type
# You can log raw IRC to file by uncommenting the following lines:
#if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
#puts $chat(log) "[string toupper [string range $type 0 0]] $line"
}
- version { return "" }
+ version { return "Bullfrog:1.2:Tcl [info patchlevel]" }
default {
$chat(window) message "unknown irc callback \"$state\": $args" -type error
}
}
}
+proc PasteDialog {Chat} {
+ upvar #0 $Chat chat
+ set wid $chat(app).pastedlg
+ if {[winfo exists $wid]} { wm deiconify $wid; return }
+ set dlg [toplevel $wid -class PasteDialog]
+ wm withdraw $dlg
+ wm title $dlg [mc "Paste data to %s" paste.tclers.tk]
+ wm transient $dlg {}
+ if {[tk windowingsystem] eq "x11"} {catch {wm attributes $dlg -type dialog}}
+ set f [ttk::frame $dlg.f1 -borderwidth 0]
+ set f2 [ttk::frame $f.f2 -borderwidth 0]
+ ttk::label $f2.lbl -text [mc Subject]
+ set subject [ttk::entry $f2.subject]
+ text $f.txt -background white -yscrollcommand [list $f.vs set] -font DebugFont
+ ttk::scrollbar $f.vs -command [list $f.txt yview]
+ set f3 [ttk::frame $f.f3 -borderwidth 0]
+ set send [ttk::button $f3.send -text [mc "Send"] \
+ -default active -width -12 \
+ -command [list set [namespace current]::$wid send]]
+ set cancel [ttk::button $f3.cancel -text [mc "Cancel"] \
+ -default normal -width -12 \
+ -command [list set [namespace current]::$wid cancel]]
+
+ foreach s {PRIMARY CLIPBOARD} {
+ set failed [catch {selection get -selection $s} string]
+ if {!$failed && [string length $string] > 0} {
+ $f.txt insert end $string {}
+ break
+ }
+ }
+ set m [menu $dlg.popup -tearoff 0]
+ $m add command -label [mc "Clear"] -command [list $f.txt delete 0.0 end]
+ #$m add command -label [mc "Eval in whiteboard"] \
+ # -command [list [namespace origin PasteEval] $dlg]
+ bind $f.txt <Button-3> [list tk_popup $m %X %Y]
+
+ bind $dlg <Key-Escape> [list $cancel invoke]
+ pack $f2.lbl -side left
+ pack $subject -side right -fill x -expand 1
+ pack $cancel $send -side right
+ grid $f2 - -sticky ew -pady 2
+ grid $f.txt $f.vs -sticky news
+ grid $f3 - -sticky se
+ grid rowconfigure $f 1 -weight 1
+ grid columnconfigure $f 0 -weight 1
+ pack $f -side top -fill both -expand 1
+ catch {::tk::PlaceWindow $dlg widget .}
+ wm deiconify $dlg
+ focus $subject
+ while {1} {
+ tkwait variable [namespace current]::$wid
+ if {[set [namespace current]::$wid] eq "send" \
+ && [string length [$subject get]] < 1} {
+ tk_messageBox -icon info -title [mc "Subject required"] \
+ -message [mc "You must provide a subject to be displayed\
+ as the title for this paste."]
+ continue
+ }
+ break
+ }
+ if {[string equal [set [namespace current]::$wid] "send"]} {
+ set msg [string trim [$f.txt get 1.0 {end - 1c}]]
+ if {[string length $msg] > 0} {
+ PasteSubmit $Chat [$subject get] $msg
+ }
+ }
+ destroy $dlg
+ unset [namespace current]::$wid
+ return
+}
+proc PasteSubmit {Chat title data} {
+ upvar #0 $Chat chat
+ set url http://paste.patthoyts.tk/-New
+ set q [http::formatQuery s [clock seconds] u $chat(nick) \
+ c tcl t $title p $data]
+ http::geturl $url -query $q \
+ -headers [list Content-type application/x-www-form-urlencoded]\
+ -timeout 60000 -command [list PasteCompleted $Chat]
+}
+proc PasteCompleted {Chat tok} {
+ if {[http::status $tok] ne "ok"} {
+ tk_messageBox -icon error -title "Failed to submit paste" \
+ -message [http::error $tok]
+ } else {
+ Status $Chat "Created new paste."
+ }
+ http::cleanup $tok
+}
+
+# tk busy does not mask off the keyboard events so we set the focus on
+# the busy window (_Busy) and ensure it will not process any <Tab> events
+
+bind Busy <Tab> break
+bind Busy <Shift-Tab> break
+
+proc Busy {dlg state} {
+ variable _busy_$dlg
+ if {$state} {
+ set _busy_$dlg [focus]
+ tk busy hold $dlg
+ focus $dlg._Busy
+ } else {
+ if {[info exists _busy_$dlg]} {
+ focus [set _busy_$dlg]
+ unset _busy_$dlg
+ }
+ tk busy forget $dlg
+ }
+}
+
proc GotoURL {w url} {
global tcl_platform
set dlg [winfo toplevel $w]
- $dlg configure -cursor watch
+ Busy $dlg true
clipboard clear
clipboard append $url
- switch -- $tcl_platform(platform) {
+ switch -exact -- $tcl_platform(platform) {
"windows" {
- # Try using DDE. Escape commas
- package require dde
- set url [string map {, %2c} $url]
+ # Try using DDE to contact a currently open browser.
set handled 0
- foreach app {Firefox Mozilla Netscape Opera IExplore} {
- if {[set srv [dde services $app WWW_OpenURL]] != {}} {
- # We cant actually check for success here.
- catch {dde execute $app WWW_OpenURL $url}
- set handled 1
- break
+ if {![catch {package require dde}]} {
+ set url [string map {, %2c} $url]; # Escape commas
+ foreach app {Firefox Mozilla Netscape Opera IExplore} {
+ if {[set srv [dde services $app WWW_OpenURL]] != {}} {
+ # We cannot actually check for success here.
+ catch {dde execute $app WWW_OpenURL $url}
+ set handled 1
+ break
+ }
}
}
- # Try the shell exec (quote the & chars)
+ # Try the shell exec (quote the & chars on NT)
if {!$handled} {
- if {$tcl_platform(os) eq "Windows NT"} {
- set url [string map {& ^&} $url]
- }
if {[catch {
- eval exec [auto_execok start] [list $url] &
+ eval exec [linsert [auto_execok rundll32.exe] end \
+ "url.dll,FileProtocolHandler" $url &]
} err]} then {
set msg [mc "Error displaying \"%s\" in browser" $url]
append msg "\n" $err
}
}
"unix" {
- # darwin: open -a $env(BROWSER) $url
- # gnome-open
- # kde?
- # find executable, then exec.
+ variable Browser; if {![info exists Browser]} {set Browser ""}
+ if {$tcl_platform(os) eq "Darwin"} {
+ if {$Browser eq ""} { set Browser "Safari" }
+ if {[catch {exec open -a $Browser $url} emsg]} {
+ tk_messageBox -message \
+ "Error displaying $url in browser\n$emsg"
+ }
+ } else {
+ # List of browsers to search for if not specified.
+ # win32: "Windows default" "rundll32" "url.dll,FileProtocolHandler %url"
+ set Browsers {
+ "Use default browser" xdg-open ""
+ "Mozilla Firefox" firefox "-new-tab"
+ "Google Chrome" google-chrome ""
+ "Opera" opera "-newtab"
+ "Gnome Web Browser" gnome-www-browser "--new-tab"
+ }
+
+ if {$Browser eq ""} {
+ foreach {display exe arg} $Browsers {
+ if {[llength [auto_execok $exe]] != 0} {
+ set Browser [linsert [auto_execok $exe] end $arg]
+ break
+ }
+ }
+ }
+
+ if {$Browser eq ""} {
+ tk_messageBox -icon error -title "No browser defined" \
+ -message "No web browser could be found. Please go to\
+ the Options dialog and select a browser to use."
+ }
+
+ # permit stuff like '-remote openURL(%url,new-tab)'
+ if {[string first "%url" $Browser] != -1} {
+ set cmd [string map [list %url [list $url]] $Browser]
+ } else {
+ set cmd [linsert $Browser end $url]
+ }
+ if {[catch {
+ eval exec $cmd &
+ } err]} {
+ tk_messageBox -icon error -title "Error opening browser" \
+ -message "Error displaying $url in browser\n$err"
+ }
+ }
+
}
default {
tk_messageBox -icon error -type ok \
Contact the developers." $tcl_platform(platform)]
}
}
- $dlg configure -cursor {}
+ Busy $dlg false
}
# -------------------------------------------------------------------------
projects / Bullfrog / commitdiff