#!/usr/bin/wish
# $Id$
lappend auto_path .
package require BWidget
set font "fixed"
set loginconf(user) test
set loginconf(password) test
set loginconf(resource) test
set loginconf(server) localhost
set loginconf(port) 5222
set loginconf(priority) 8
set loginconf(usedigest) 0
set loginconf(usessl) 0
set loginconf(sslport) 5223
set loginconf(useproxy) 0
set loginconf(httpproxy) localhost
set loginconf(httpproxyport) 3128
set usetabbar 1
set default_jlib jabberlib-tclxml
proc browseurl {url} {
global env tcl_platform
set_status $url
update
switch -- $tcl_platform(platform) {
windows {
switch -- $tcl_platform(os) {
"Windows NT" {
exec $env(COMSPEC) /c start $url &
}
default {
exec start $url &
}
}
}
macintosh {
if {![info exists env(BROWSER)]} {
set env(BROWSER) "Browse the Internet"
AppleScript execute \
"tell application \"env(BROWSER)\"\nopen url \"$url\"\nend tell\n"
}
}
default {
if {![info exists env(BROWSER)]} {
foreach b [list galeon konqueror mozilla netscape iexplorer \
opera] {
if {[llength [set e [auto_execok $b]]] > 0} {
set env(BROWSER) [lindex $e 0]
break
}
}
if {![info exists env(BROWSER)]} {
MessageDlg .browse_err -icon info \
-message {Please define $BROWSER} -type ok
return
}
}
if {[catch { exec $env(BROWSER) -remote $url }]} {
exec $env(BROWSER) $url &
}
}
}
set_status ""
}
set pixmaps_theme default
proc postload {} {}
proc menuload {menudesc} { return $menudesc }
proc finload {} {}
if {[file exists ~/.tkabber/config.tcl]} {
source ~/.tkabber/config.tcl
}
set version 0.0.0.0.1-alpha-20020823
tk appname tkabber
#option readfile ermine.xrdb userDefault
#option readfile examples/teopetuk.xrdb userDefault
option add *Entry.font $font widgetDefault
#option add *Entry.background White
#option add *Text.background White
if {$tcl_platform(platform) == "unix"} {
set debug_lvls {jlib warning}
} else {
# Don't show debug information on enemy os
set debug_lvls {}
}
proc debugmsg {level msg} {
global debug_lvls
if {[lsearch -exact $debug_lvls $level] >= 0} {
puts "$level: $msg"
}
}
proc rescmd {id res ls} {
puts "RESULT: $id $res $ls"
}
proc fullpath {args} {
return [eval file join [file dirname [info script]] $args]
}
proc pixmap {args} {
global pixmaps_theme
set p [eval fullpath pixmaps $pixmaps_theme $args]
if {[file exists $p]} {
return $p
} else {
return [eval fullpath pixmaps default $args]
}
}
proc load_source {args} {
set fullpath [eval fullpath $args]
debugmsg tkabber "Loading $fullpath"
uplevel #0 source $fullpath
}
load_source $default_jlib jabberlib.tcl
package require jabberlib 0.8.2
if {[catch { package require Img }]} {
debugmsg tkabber \
"unable to load the Img package, so no PNG/JPEG image support!
The IMG package is available at http://www.xs4all.nl/~njitmans/img.html"
}
if {[catch { package require Tclx }]} {
load_source Tclx.tcl
}
load_source utils.tcl
load_source plugins.tcl
load_source balloon.tcl
load_source presence.tcl
load_source roster.tcl
load_source editgroups.tcl
load_source messages.tcl
load_source chats.tcl
load_source joingrdialog.tcl
load_source emoticons.tcl
load_source login.tcl
load_source browser.tcl
load_source userinfo.tcl
load_source iq.tcl
load_source datagathering.tcl
load_source search.tcl
load_source register.tcl
load_source filetransfer.tcl
load_source filters.tcl
load_source avatars.tcl
postload
###### XML library hack
#proc xml::XML:decrypt {text} {
# return $text
#}
proc ::LOG text {
debugmsg jlib "$text\n"
}
###############################################################################
# Interface
###############################################################################
set w {}
wm title . "Tkabber"
#wm iconbitmap . [Bitmap::get [pixmap tkabber tkabber_22x22.gif]]
set toolbaricon(groupchat) [Bitmap::get [pixmap tkabber glade-groupchat.gif]]
set toolbaricon(newuser) [Bitmap::get [pixmap tkabber glade-new-user.gif]]
set toolbaricon(jb) [Bitmap::get [pixmap tkabber jb.gif]]
set toolbaricon(online) [Bitmap::get [pixmap tkabber glade-online.gif]]
set toolbaricon(offline) [Bitmap::get [pixmap tkabber glade-offline.gif]]
set descmenu {
"&Tkabber" {} {} 1 {
{cascad "Presence" {} presence 1 {
{command "Online" {} {} {} -command {set userstatus available}}
{command "Free to chat" {} {} {} -command {set userstatus chat}}
{command "Away" {} {} {} -command {set userstatus away}}
{command "Extended Away" {} {} {} -command {set userstatus xa}}
{command "Do not disturb" {} {} {} -command {set userstatus dnd}}
{command "Invisible" {} {} {} -command {set userstatus invisible}}
}}
{command "Log in..." {} {} {Ctrl l} -command {show_login_dialog}}
{command "Log out" {} {} {Ctrl f} -command {logout}}
{command "Log out with reason..." {} {} {} -command {show_logout_dialog}}
{separator}
{command "Profile on" {} {} {} -command {
profile -commands -eval on
}}
{command "Profile report" {} {} {} -command {
profile off profil
profrep profil real profresults
}}
{separator}
{command "Quit" {} {} {} -command {exit}}
}
"&Services" {} {} 1 {
{command "Send message..." {} {} {} \
-command {message::send_dialog "" "" ""}}
{cascad "Roster" {} {} 1 {
{command "Add user..." {} {} {} \
-command {message::send_subscribe_dialog ""}}
{command "Add conference..." {} {} {} -command {add_group_dialog}}
}}
{command "Browser" {} {} {} -command {browser::open}}
{command "Join group..." {} {} {} -command {join_group_dialog}}
{cascad "Chats" {} {} 1 {
{checkbutton "Stop autoscroll" {} {} {} \
-variable chat::stop_scroll}
}}
{command "Filters..." {} {} {} -command {filters::open}}
{command "Edit my info..." {} {} {} \
-command {userinfo::open ${loginconf(user)}@$loginconf(server)/$loginconf(resource) 1}}
{cascad "Avatar" {} {} 1 {
{checkbutton "Announce" {} {} {} \
-variable avatar::avatar(announce)}
{checkbutton "Allow downloading" {} {} {} \
-variable avatar::avatar(share)}
{command "Send to server" {} {} {} \
-command {avatar::store_on_server}}
}}
{separator}
{cascad "Admin tools" {} {} 1 {
{command "Send broadcast message..." {} {} {} \
-command {eval {message::send_dialog \
"$loginconf(server)/announce/online" \
{} {}}}}
}}
}
"&Help" {} {} 1 {
{command "Quick help..." {} {} {} -command {
MessageDlg .m -anchor center -aspect 50000 -title "Quick help" \
-type user -buttons OK -message "
Tabs:
Close tab C-F4
Next tab C-PgDown
Previous tab C-PgUp
Hide/Show roster C-r
Chats:
Complete nick TAB
Previous history message C-Up
Next history message C-Down
"
}}
{command "About..." {} {} {} -command {
MessageDlg .m -anchor center -aspect 50000 -title About \
-type user -buttons OK -message "Tkabber $version
Copyright (c) 2002 Alexey Shchepin
Author: Alexey Shchepin
http://www.jabber.ru/projects/tkabber/
"
}}
}
}
if {[clength [info commands profile]] == 0} {
set tmpmenu {}
set eatP 0
foreach menu [lindex $descmenu 4] {
if {[string first "Profile " [lindex $menu 1]] == 0} {
set eatP 1
} elseif {$eatP} {
set eatP 0
} else {
lappend tmpmenu $menu
}
}
set descmenu [lreplace $descmenu 4 4 $tmpmenu]
}
set descmenu [menuload $descmenu]
set mf [MainFrame .mainframe -menu $descmenu -textvariable status]
pack $mf -expand yes -fill both
bind $mf <Destroy> {
jlib::disconnect
exit
}
set toolbar [$mf addtoolbar]
set bbox [ButtonBox $toolbar.bbox -spacing 0 -padx 1 -pady 1]
$bbox add -image $toolbaricon(newuser) \
-highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
-padx 1 -pady 1 -command {message::send_subscribe_dialog ""} \
-helptext "Add new user..."
$bbox add -image $toolbaricon(jb) \
-highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
-padx 1 -pady 1 -command {browser::open} \
-helptext "Jabber Browser"
$bbox add -image $toolbaricon(groupchat) \
-highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
-padx 1 -pady 1 -command {join_group_dialog} \
-helptext "Join group..."
if {$roster::show_only_online} {
set button_image $toolbaricon(offline)
set button_helptext "Show online & offline users"
} else {
set button_image $toolbaricon(online)
set button_helptext "Show online users only"
}
$bbox add -image $button_image \
-highlightthickness 0 -takefocus 0 -relief link -borderwidth 1 \
-padx 1 -pady 1 -command {roster::switch_only_online} \
-helptext $button_helptext
pack $bbox -side left -anchor w
menubutton .presence -menu .presence.menu -relief raised \
-textvariable userstatusdesc -direction above
pack .presence -side bottom -anchor w -in [$mf getframe]
if {[winfo exists [set m $w.presence.menu]]} {
destroy $m
}
menu $m
$m add command -label "Online" -command {set userstatus available}
$m add command -label "Free to chat" -command {set userstatus chat}
$m add command -label "Away" -command {set userstatus away}
$m add command -label "Extended Away" -command {set userstatus xa}
$m add command -label "Do not disturb" -command {set userstatus dnd}
$m add command -label "Invisible" -command {set userstatus invisible}
if {$usetabbar} {
set pw [PanedWindow [$mf getframe].pw -side bottom]
pack $pw -fill both -expand yes
set rw [$pw add -minsize 0 -weight 1]
set nw [$pw add -minsize 32 -weight 5]
roster::create $w.roster -width 150 -height 300 -popup roster::popup_menu
pack $w.roster -expand yes -fill both -side left -in $rw
NoteBook .nb -width 400
pack .nb -side right -in $nw -fill both -expand yes
bind . <Control-Key-r> {collapse_roster}
bind . <Control-Prior> {tab_move .nb -1}
bind . <Control-Next> {tab_move .nb 1}
bind . <Control-Key-F4> {
if {[.nb raise] != ""} {
eval destroy [pack slaves [.nb getframe [.nb raise]]]
.nb delete [.nb raise] 1
tab_move .nb 0
}
}
set m [menu .tabsmenu -tearoff 0]
$m add command -label "Close" -accelerator C-F4 \
-command {
if {[.nb raise] != ""} {
eval destroy [pack slaves [.nb getframe $curmenutab]]
.nb delete $curmenutab 1
tab_move .nb 0
}
}
.nb bindtabs <3> {tab_menu %X %Y}
wm geometry . 788x550
} else {
roster::create $w.roster -width 150 -height 300 -popup roster::popup_menu
pack $w.roster -expand yes -fill both -side left -in [$mf getframe]
}
proc add_win {path args} {
global usetabbar
set title ""
set tabtitle ""
set class ""
set raisecmd ""
foreach {attr val} $args {
switch -- $attr {
-title {set title $val}
-tabtitle {set tabtitle $val}
-class {set class $val}
-raisecmd {set raisecmd $val}
default {error "Unknown option $attr"}
}
}
if {$usetabbar} {
set page [crange [win_id tab $path] 1 end]
set f [.nb insert end $page -text $tabtitle -raisecmd $raisecmd]
frame $path -class $class
pack $path -expand yes -fill both -in $f
#tkwait visibility $path
set ::tabcolors($page) ""
after idle .nb raise $page
} else {
toplevel $path -class $class
wm title $path $title
}
}
proc tab_move {nb shift} {
set len [llength [$nb pages]]
if {$len > 0} {
set newidx [expr [$nb index [$nb raise]] + $shift]
if {$newidx < 0} {
set newidx [expr $len - 1]
} elseif {$newidx >= $len} {
set newidx 0
}
$nb see [lindex [$nb pages] $newidx]
$nb raise [lindex [$nb pages] $newidx]
}
}
array set alert_lvls {error 1 server 1 message 2 mesg_to_user 3}
set alert_colors {Black DarkBlue Blue Red}
proc tab_set_updated {path updated level} {
global usetabbar
global tabcolors
global alert_lvls alert_colors
if {$usetabbar} {
set page [crange [win_id tab $path] 1 end]
#update idletasks
if {$updated && $page != [.nb raise] && \
[info exists alert_lvls($level)]} {
set lvlnum $alert_lvls($level)
} else {
set lvlnum 0
}
#.nb.c itemconfigure $page:text -fill $color
if {!$updated || $tabcolors($page) < $lvlnum} {
set color [lindex $alert_colors $lvlnum]
.nb itemconfigure $page -foreground $color
set tabcolors($page) $lvlnum
}
#puts "$path $updated $page $color [.nb raise]"
}
}
proc tab_menu {x y page} {
global curmenutab
set curmenutab $page
tk_popup .tabsmenu $x $y
}
###############################################################################
proc collapse_roster {} {
global rw
[winfo parent $rw] configure -width 0
bind . <Control-Key-r> {uncollapse_roster}
}
proc uncollapse_roster {} {
global rw
[winfo parent $rw] configure -width 4c
bind . <Control-Key-r> {collapse_roster}
}
###############################################################################
set status_afterid ""
proc set_status {text} {
global status
global status_afterid
after cancel $status_afterid
set status $text
set status_afterid [after 5000 clear_status]
}
proc clear_status {} {
global status
set status ""
}
###############################################################################
#cmdtrace 22
finload
if {[file exists proton.tcl]} {
# show_login_dialog
login
} else {
show_login_dialog
}