milkbone/plugins/Tk-BList/Milkbone/BList.pm

# milkbone - buddy list toplevel mega-widget

package Milkbone::BList;

use Milkbone qw(slurp abort %ARGS);

use warnings;
use strict;

# use HTTP::Lite;

use Tk;
use Carp;
use Milkbone::Tree;
use base qw(Tk::Toplevel);

Construct Tk::Widget 'MBBList';

my ($away, $blank, $logo, $cell);

sub ClassInit
{
	my ($class, $mw) = @_;
	$class->SUPER::ClassInit($mw);
}

sub Populate
{
	my ($self, $args) = @_;
	$self->SUPER::Populate($args);
}

sub on_browsecmd {
    $_[0]->select_buddy($_[1]);
}

sub on_cmd
{
	my ($self, $item) = @_;
	return unless $item =~ /\./;	
	my ($name) = $self->{tree}->itemCget($item, 0, -text);

	return if !defined($name) || $name eq "";

	hook("create_convo", -user => $name, -fabricated => 1);
}

sub on_destroy
{
	abort;
}

sub load_groups
{
	my ($self) = @_;
	my $groups = hook("protocol_get_groups");

	$self->{tree}->add($_, -text => $_, -style => $self->{group_style}) for @$groups;
}

sub on_buddy_info_changed
{
	my ($self) = $ARGS{-self};
	my ($buddy, $group) = @ARGS{-buddy, -group};
	my ($realname) = $buddy;
	$realname =~ s/ //g;
	$realname =~ tr/A-Z/a-z/;

	if(hook("protocol_is_away", -user => $realname))
	{
		$self->{tree}->itemConfigure("$group.$realname", 0, -image => $away);
	}
	else
	{
		# format has changed
		$self->{tree}->itemConfigure("$group.$realname", 0, -image => $blank, -text => $buddy);
	}

	$self->{tree}->autosetmode;
}

sub on_buddy_in
{
	my ($self) = $ARGS{-self};
	my ($buddy, $group) = @ARGS{-buddy, -group};
	my ($realname) = $buddy;
	$realname =~ s/ //g;
	$realname =~ tr/A-Z/a-z/;

	if(hook("protocol_is_away", -user => $realname))
	{
		$self->{tree}->add("$group.$realname", -text => $buddy, -image => $away);
	}
	elsif(hook("protocol_is_mobile", -user => $realname))
	{
		$self->{tree}->add("$group.$realname", -text => $buddy, -image => $cell);
	}
	else
	{
		$self->{tree}->add("$group.$realname", -text => $buddy, -image => $blank);
	}

	$self->{tree}->autosetmode;
}

sub on_buddy_out
{
	my ($self, $buddy, $group) = @ARGS{-self, -buddy, -group};
	$buddy =~ s/ //g;
	$buddy =~ tr/A-Z/a-z/;

	if($self->{tree}->infoExists("$group.$buddy"))
	{
		$self->{tree}->delete('entry', "$group.$buddy");
	}

	$self->{tree}->autosetmode;
}

sub on_away
{
	my ($self) = @_;

	if(!$self->{is_away})
	{
		hook("protocol_go_away");
		$self->{away}->configure(-text => "Return (0)");
		$self->{is_away} = 1;
		$self->{waiting_msgs} = 0;
	}
	else
	{
		hook("protocol_return");
		$self->{away}->configure(-text => "Away Message");
		$self->{is_away} = 0;
		$self->{waiting_msgs} = 0;
	}
}

sub on_prof
{
	my ($self) = @_;

	my $info = slurp "profile.txt", 1;
	hook("protocol_set_info", -info => $info);
}

sub on_switch_sn
{
}

sub on_check_updates
{
	my ($self) = @_;

	my $http = new HTTP::Lite;
	$http->request("http://milkbone.batkins.com/ver.txt");
	my $newest = $http->body();
	
	if($newest && $newest < $main::VERSION && length($newest) < 6)
	{
		my $res = $self->messageBox(-title => "milkbone update",
			-message => "Milkbone $newest is now available at http://milkbone.batkins.com/.  You ought to get it.", 
			-type => 'OK', -icon => 'question');
	}
}

sub on_rclick
{
	my ($self, $x, $y) = @_;
	my $buddy = $self->{tree}->nearest($y);
	my @temp = split(/\./, $buddy);

	return if @temp == 1;
	$self->select_buddy($self->{tree}->nearest($y));
	
	my $offset = ($^O =~ /Win32/) ? 10 : -30;

	$self->{buddy_menu}->Post($self->x + $x, $self->y + $self->height - $self->{tree}->height + $y + $offset);
}

sub add_blist_menu_item {
    my ($self) = $ARGS{-self};
    warn "No such Blist menu: $ARGS{-menu}" and return unless $self->{"menu_$ARGS{-menu}"};
    $self->{"menu_$ARGS{-menu}"}->command(-label => $ARGS{-label}, -command => $ARGS{-command});
    $self->configure(-menu => $self->{menu});
    return 1;
}

sub select_buddy {
    my ($self, $path) = @_;

	my ($buddy, $group) = split /\./, $path;

	return if $buddy eq "";

	$self->{tree}->selectionClear;
	$self->{tree}->update;
    $self->{selected_buddy} = $path;
    $self->{tree}->selectionSet($path);
}

sub on_add_buddy_menu {
	hook("dlg_add_buddy", -parent => shift);
}

sub on_add_group_menu {
	hook("dlg_add_buddy_group", -parent => shift);
}

sub on_prof_menu
{
	my ($self) = @_;
                
	my ($group, $buddy) = split /\./, $self->{'selected_buddy'};
	return if $buddy eq "";

	hook("get_profile", -user => $buddy);
}

sub on_remove_buddy_menu {
    my ($self) = @_;
    my ($group, $name) = (split /\./, $self->{'selected_buddy'});
    return if $name eq "" or $group eq "";

	if($self->messageBox(-title => "Confirm Buddy Remove", 
		-message => "Are you sure you want to remove $name from your buddy list?", -type => 'YesNo',
		-icon => 'question', -default => 'no') =~ m/yes/i)
	{
		hook("protocol_remove_buddy", -group => $group, -buddy => $name);    
		hook("protocol_commit_blist");
		hook("buddy_out", -buddy => $name, -group => $group);
	}
}

sub init
{
	my ($self, $mw) = @_;
	
	$logo = $self->Photo(-file => "images/logo.bmp");
	$self->configure(-title => "$ARGS{-me}\ - milkbone");

	my ($x, $y);

	$self->withdraw();

	# position the list along the right-hand side of the screen
	$x = $self->screenwidth - $self->width() - 168;
	$y = 22;
	$self->geometry("160x650+$x+$y");

	$self->{menu} = $self->Menu(-borderwidth => 0, -activeborderwidth => 0);

	$self->{menu_file} = $self->{menu}->cascade(-label => "File", -tearoff => 0);
	$self->{menu_file}->command(-label => "Set Away...", -command => sub { hook("on_set_away");} );
	$self->{menu_file}->command(-label => "Set Profile...", -command => sub { hook("on_set_profile");} );
	$self->{menu_file}->command(-label => 'Add Buddy ...', -command => [$self, "on_add_buddy_menu"]);
	$self->{menu_file}->command(-label => 'Add Buddy Group ...', -command => [$self, "on_add_group_menu"]);
	$self->{menu_file}->separator;
	$self->{menu_file}->command(-label => 'Plugins ...', -command => sub { hook("dlg_plugins", -parent => hook("tk_getmain"));	 });
	$self->{menu_file}->command(-label => 'Edit Configuration...', -command => sub { hook("dlg_edit_conf", -parent => hook("tk_getmain"));	 });
	$self->{menu_file}->command(-label => 'Reload Core', -command => 
            sub { reload_core(); });
	$self->{menu_file}->separator;
	$self->{menu_file}->command(-label => "Goodbye and Exit", -command => sub { hook("goodbye") });
	$self->{menu_file}->command(-label => "Exit", -command => [$self, "on_destroy"]);

	$self->{buddy_menu} = $self->Menu(-tearoff => 0);
	$self->{buddy_menu}->command(-label => 'Get Buddy Info', -command => [\&on_prof_menu, $self, Ev('y')]);
	# $self->{buddy_menu}->command(-label => 'Set Alias', -command => [$self, "on_alias_buddy_menu"]);
	$self->{buddy_menu}->command(-label => 'Remove Buddy', -command => [$self, "on_remove_buddy_menu"]);

	$self->{menu_help} = $self->{menu}->cascade(-label => "Help", -tearoff => 0);
	$self->{menu_help}->command(-label => "About...", -command => sub { hook("show_about") });

	$self->configure(-menu => $self->{menu});

	$self->Label(-image => $logo)->pack(-side => 'top', -fill => 'both') unless option("HideBListLogo");

        my $label  = $self->Label(-text => "Logged in.");
        $label->pack(-anchor => 'w');

	$self->{tree} = $self->Scrolled("MBTree" =>
		-scrollbars => 'oe',
		-background => 'white', -font => hook("tk_get_default_font") .  ' 9 medium', -fg => 'black', -selectborderwidth => 0,
		-itemtype => 'imagetext', -highlightthickness => 0, -drawbranch => 0, -indicator => 1,
		-selectbackground => "darkblue", -selectforeground => "white", -ignoreinvoke => 1,
		-selectmode => 'single', -itemtype => 'imagetext', -indent => 14,
		-command => [$self, "on_cmd"])
		->pack(-expand => 1, -fill => 'both');
	$self->{tree}->Subwidget("yscrollbar")->configure(-width => 15);

	$self->{group_style} = $self->{tree}->ItemStyle('imagetext', 
		-background => 'white', -font => hook("tk_get_default_font") . ' 9 bold', -fg => 'black', 
		-selectbackground => "white", -selectforeground => "white", -stylename => 'group');
	$self->{changed_style} = $self->{tree}->ItemStyle('imagetext', 
		-background => 'white', -font => hook("tk_get_default_font") . ' 9', -fg => 'red', 
		-selectbackground => "darkblue", -selectforeground => "white", -stylename => 'changed');
	$self->{normal_style} = $self->{tree}->ItemStyle('imagetext', 
		-background => 'white', -font => hook("tk_get_default_font") . ' 9', -fg => 'black', 
		-selectbackground => "darkblue", -selectforeground => "white", -stylename => 'normal');

	$self->{away_button} = "Away Message";

	$self->{away} = $self->Button(-command => [$self, "on_away"], -text => 'Away Message', -border => 1);
	$self->{away}->pack(-side => 'bottom');

	hook("tk_seticon", -wnd => $self);
	$away = $self->Photo(-file => "images/away.bmp");
	$blank = $self->Photo(-file => "images/blank.gif");
	$cell = $self->Photo(-file => "images/cell.gif");
	$self->OnDestroy([\&on_destroy, $self]);
	$self->{switching} = 0;

	hook("tk_bindwheel", -window => $self->{tree});
	$self->{tree}->bind("<ButtonPress-3>", [$self, "on_rclick", Ev('x'), Ev('y')]);

	# $self->after(5000, [\&on_check_updates, $self]);

	$self->deiconify(); 
	$self->focus();
}

sub on_info_check
{
	my ($self, $user, $group) = @_;

	if($self->{tree}->itemConfigure("$group.$user", -style)->cget(-stylename) eq "changed")
	{
		$self->{tree}->itemConfigure("$group.$user", 0, -style => $self->{normal_style});
	}
}

sub on_msg_in
{
	my ($self) = @_;

	return unless hook("protocol_away_status");

	$self->{waiting_msgs}++;
	$self->{away}->configure(-text => "Return (" . $self->{waiting_msgs} . ")");
}

sub on_group_menu
{
	my ($self) = @_;
}

sub on_new_group
{
	my ($self, $group) = @_;

	$self->{tree}->add($group, -text => $group, -style => $self->{group_style});
}

sub on_alias_buddy_menu
{
	my ($self) = @_;
    my ($group, $name) = (split /\./, $self->{'selected_buddy'});

	my $dlg = $self->Toplevel;
	$dlg->Label(-text => 'Alias:')->pack;
	my $entry = $dlg->Entry->pack;
	$entry->insert('end', hook("protocol_get_realname", -user => $name));

	$dlg->Button(-text => 'Rename', -command => [ 
		sub { 
		hook("protocol_set_comment", 
			-user => $_[0],
			-group => $_[1],
			-comment => $_[2]->get() . "test");
		$_[3]->destroy;
	}, $name, $group, $entry, $dlg])->pack;
}

1;