From 0e0d1e4682f3861473da26e00e1d61b2c120aba1 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Mon, 8 Feb 2010 19:22:12 +0000 Subject: [PATCH] Paste dialog, URL handling and busy handling fixes. Added the paste dialog for paste.tclers.tk on a context menu for irc. Fixed support for URL browsing on windows and added unix support. Fixed up to use the [tk busy] command when required and fixed a couple of small bugs Signed-off-by: Pat Thoyts --- .gitignore | 2 + bin/bf_irc.tcl | 108 +++++++++++++++---- bin/bullfrog.tcl | 194 ++++++++++++++++++++++++++++++---- bin/tab.tcl | 6 +- lib/chatwidget/chatwidget.tcl | 1 + 5 files changed, 266 insertions(+), 45 deletions(-) diff --git a/.gitignore b/.gitignore index 29763f6..69b2b42 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ CVS .#* *~ +lib/tooltip/ChangeLog +lib/tooltip/tooltip.man diff --git a/bin/bf_irc.tcl b/bin/bf_irc.tcl index 603cf47..16d7ff4 100644 --- a/bin/bf_irc.tcl +++ b/bin/bf_irc.tcl @@ -11,6 +11,8 @@ # package require picoirc 0.5; # tcllib +package require chatwidget +catch {package require tooltip} variable ircuid if {![info exists ircuid]} { set ircuid -1 } @@ -90,7 +92,8 @@ proc IrcConnect {app args} { 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] } @@ -126,8 +129,24 @@ proc IrcJoinChannel {Chat args} { # 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] @@ -144,17 +163,20 @@ proc IrcAddChannel {Chat channel} { $chan(window) chat tag bind URL [list UrlEnter %W] $chan(window) chat tag bind URL [list UrlLeave %W] $chan(window) chat tag bind URL [list UrlClick %W %x %y] - $chat(window) names configure -wrap none + $chan(window) names configure -wrap none $chan(window) names tag bind NICK \ - [list [namespace origin IrcChannelNickMenu] $Channel %W %x %y] + [list [namespace origin IrcChannelNickMenu] $Chat $Channel %W %x %y] $chan(window) names tag bind NICK \ [list [namespace origin IrcNickTooltip] $Chat enter %W %x %y] $chan(window) names tag bind NICK \ [list [namespace origin IrcNickTooltip] $Chat leave %W %x %y] $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel] bind $chan(window) "+unset -nocomplain $Channel" + bind $chan(window) [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 } @@ -168,17 +190,42 @@ proc IrcRemoveChannel {Chat target} { } } -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] } @@ -192,17 +239,8 @@ proc IrcChannelNickCommand {Channel cmd nick} { } 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 } @@ -223,11 +261,14 @@ proc IrcCallback {Chat context state args} { 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] @@ -236,6 +277,11 @@ proc IrcCallback {Chat context state args} { 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 @@ -249,6 +295,7 @@ proc IrcCallback {Chat context state args} { 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])}]] @@ -261,11 +308,23 @@ proc IrcCallback {Chat context state args} { 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]} { @@ -330,13 +389,16 @@ proc IrcCallback {Chat context state args} { } 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 } diff --git a/bin/bullfrog.tcl b/bin/bullfrog.tcl index 2d6e5d4..b56940e 100644 --- a/bin/bullfrog.tcl +++ b/bin/bullfrog.tcl @@ -350,33 +350,142 @@ proc UrlClick {w x y} { } } +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 [list tk_popup $m %X %Y] + + bind $dlg [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 events + +bind Busy break +bind Busy 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 @@ -386,10 +495,53 @@ proc GotoURL {w url} { } } "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 \ @@ -398,7 +550,7 @@ proc GotoURL {w url} { Contact the developers." $tcl_platform(platform)] } } - $dlg configure -cursor {} + Busy $dlg false } # ------------------------------------------------------------------------- diff --git a/bin/tab.tcl b/bin/tab.tcl index 6368950..5804e06 100644 --- a/bin/tab.tcl +++ b/bin/tab.tcl @@ -32,7 +32,11 @@ proc ::ButtonNotebook::CreateImageElements {} { # Create two image based elements to provide buttons to close the # tabs or to detach a tab and turn it into a toplevel. namespace eval ::img {} - set imgdir [file join [file dirname [info script]] images] + if {[info exists ::starkit::topdir]} { + set imgdir [file join $starkit::topdir bin images] + } else { + set imgdir [file join [file dirname [info script]] images] + } image create photo ::img::close -file [file join $imgdir xhn.gif] image create photo ::img::closepressed -file [file join $imgdir xhd.gif] image create photo ::img::closeactive -file [file join $imgdir xhu.gif] diff --git a/lib/chatwidget/chatwidget.tcl b/lib/chatwidget/chatwidget.tcl index 5e22e82..4ff2ad9 100644 --- a/lib/chatwidget/chatwidget.tcl +++ b/lib/chatwidget/chatwidget.tcl @@ -265,6 +265,7 @@ proc chatwidget::Name {self cmd args} { return $state(names) } default { + set r {} foreach item $state(names) { lappend r [lindex $item 0] } return $r } -- 2.23.0