Initial revision

Milkbone.pm

@@ -0,0 +1,422 @@
+# -----------------------------------------------------------------------------
+# Author(s)	:	Bill Atkins and Eric Thul
+# Title		:	MOS core tools
+# Date		:	12.21.02
+# Desc		:	the hamster that keep MOS going
+# QoTP		:	got milkbone tools?
+# Notes		:	for more information see the plugin documentation
+# License	:	under the same terms as mos.pl
+# -----------------------------------------------------------------------------
+
+package Milkbone;
+
+use strict;
+use warnings;
+
+use Carp qw(longmess);
+use PAR;
+use Milkbone::HookEntry;
+use Benchmark;
+
+our $VERSION = "0.355";
+
+require Exporter;
+
+our @ISA = qw( Exporter );
+our @EXPORT = qw( hook is_running abort queued_hook register_hook option path data %ARGS slurp
+	deregister_hook strip_html user_file set_option MOSLoop set_interval unload_plugin load_plugin init_plugin reload_core);
+our @EXPORT_OK = qw( );
+
+my ($running, $dirty);
+my $interval = 0.006;
+our (%hooks, %options, %data, %plugins);
+our (%ARGS) = ();
+
+$running = 1;
+
+$| = 1;
+
+sub is_running
+{
+	$running;
+}
+
+sub set_interval
+{
+	$interval = shift;
+}
+
+sub abort
+{
+	$running = 0;
+	die @_;
+}
+
+sub init
+{
+	# initialization
+	register_hook("load_options", \&load_options);
+	register_hook("load_plugins", \&load_plugins);
+	register_hook("post_mainloop", \&post_mainloop);
+	register_hook("pre_mainloop", \&pre_mainloop);
+	register_hook("save_options", \&save_options);
+	register_hook("loaded_plugins", \&plugin_list);
+	register_hook("error", \&error);
+}
+
+# ------------------------------------------
+# Plugin and Hook System
+# ------------------------------------------
+
+sub load_options
+{
+	my ($directive, $temp, @args);
+
+	open(GLOBAL, "<mb.conf") or die "Can't open config file: $!";
+
+	while(<GLOBAL>)
+	{
+		next if /^\#/;
+		next if /^\s*\n/;
+
+		chomp;
+		
+		($directive, @args) = split /\s|\,/;
+
+		if(@args > 1)
+		{
+			my @val = grep { !/^$/ } @args;
+			$options{$directive} = \@val;
+		}
+		else
+		{
+			my $val = $args[0];
+			$options{$directive} = \$val;
+		}
+	}
+
+	close(GLOBAL);
+}
+
+sub save_options
+{
+    	return unless $dirty;
+	my ($val, @temp, $str);
+	open(GLOBAL, ">mb.conf") or die "Can't open config file: $!";
+	print GLOBAL "# mb.conf - milkbone global configuration file\n\n";
+
+	for(keys(%options))
+	{
+		$val = $options{$_};
+
+		if(ref($val) eq "SCALAR")
+		{
+			print GLOBAL "$_ $$val\n";
+		}
+		else
+		{
+			@temp = @$val;
+			s/\s*// for @temp;
+			@temp = grep { $_ ne "" } @temp;
+			$str = join(', ', @$val);
+			$str =~ s/, (, )*/, /g;
+			print GLOBAL "$_ " . $str . "\n";
+		}
+	}
+
+	close(GLOBAL);
+}
+
+sub option
+{
+	my $val = $options{$_[0]};
+
+	return undef unless $val;
+
+	if(ref($val) eq "SCALAR")
+	{
+		$$val;
+	}
+	else
+	{
+		@$val;
+	}
+}
+
+sub set_option
+{
+	my ($name, $val) = @_;
+
+	$options{$name} = \$val;
+        $dirty = 1;
+}
+
+sub load_plugin
+{
+	my ($plugin) = @_;
+
+	return unless $plugin;
+
+	if(-e path("plugins/$plugin.pl"))
+	{
+	}
+        # PAR support - disabled in non-Mercury releases
+	#elsif(-e path("plugins/$plugin.zip"))
+	#{
+	#	PAR->import(path("plugins/$plugin.zip"));
+	#}
+	elsif(-e path("plugins/$plugin") and -d path("plugins/$plugin"))
+	{
+		unshift @INC, path("plugins/$plugin");
+	}
+	else
+	{
+		die "Couldn't load plugin $plugin";
+		return;
+	}
+
+        $plugins{$plugin} = 1;
+}
+
+sub unload_plugin
+{
+	my ($plugin) = @_;
+        my $package = $plugin;
+        $package =~ s/-//g;
+
+	for my $element (keys %hooks)
+	{
+		my @new;
+		for(@{$hooks{$element}})
+		{
+			unless($_->{package} eq $package)
+			{
+				push @new, $_;
+			}
+		}
+		$hooks{$element} = \@new;
+	}
+
+        delete $plugins{$plugin};
+
+        for(keys %INC)
+        {
+            delete $INC{$_} if /^plugins\/$plugin/;
+        }
+
+        print %plugins;
+}
+
+sub plugin_list
+{
+    [keys(%plugins)];
+}
+
+sub init_plugin
+{
+	my ($plugin) = @_;
+	eval "require \"$plugin.pl\";" or hook("error", -short => "Couldn't require $plugin.pl for $plugin: $! $@");
+}
+
+sub load_plugins
+{
+	
+	my @plugins = grep({ $_ } (option("Modules"), option("Plugins")));
+	push @INC, "./plugins";
+	load_plugin($_) for @plugins;
+	init_plugin($_) for(@plugins);
+}
+
+sub hook
+{
+	my ($hook, %args) = @_;
+	my %old;
+	my ($res);
+
+	warn "Unregistered hook called: $hook" . ' ' . join(' ', caller) . "\n" if !exists($hooks{$hook});
+
+	%old = %ARGS;
+
+	for $hook (@{$hooks{$hook}})
+	{
+		%ARGS = %args;
+
+		$ARGS{$_} = $hook->{args}->{$_} for %{$hook->{args}};
+	eval { $res = $hook->call; };
+		print longmess($! . $@) if $@;
+	}
+
+	%ARGS = %old;
+
+	return $res;
+}
+
+sub reload_core
+{
+    delete $INC{'Milkbone.pm'};
+    eval "require 'Milkbone.pm';";
+}
+
+sub register_hook
+{
+	my ($hook, $coderef, $args) = @_;
+	my ($package, $file, $line) = caller;
+	my $entry = new Milkbone::HookEntry($hook, $coderef, $args, $package);
+
+	push @{$hooks{$hook}}, $entry; 
+}
+
+sub deregister_hook
+{
+	my ($hook) = @_;
+	my ($file, $package, $line) = caller;
+	my @temp = @{$hooks{$hook}};
+
+	die "Required hook missing" if !exists($hooks{$hook}) and $hook eq "tick";
+	warn "Unregistered hook deleted: $hook" if !exists($hooks{$hook});
+
+	@temp = grep { ($_->{package} ne $package) && ($_->{hook_name} ne $hook) } @temp;
+
+	@{$hooks{$hook}} = @temp;
+}
+
+sub MOSLoop
+{
+	my $i = 0;
+	while(is_running)
+	{
+		hook("tick");
+		select(undef, undef, undef, $interval) if $i++ % 5 == 0 && $interval;
+	}
+}
+
+# ------------------------------------------
+# Default Hooks
+# ------------------------------------------
+
+sub post_mainloop
+{
+	hook("save_options");
+}
+
+sub pre_mainloop
+{
+}
+
+sub error
+{
+	unlink "errlog.txt" and warn "errlog.txt has exceeded 500K." if -s "errlog.txt" > 500 * 1024;
+	open(LOG, ">>errlog.txt") or die "Can't open error file: $!";
+	print LOG $ARGS{-short} . "\n" if $ARGS{-short};
+	print LOG $ARGS{-long} . "\n" if $ARGS{-long};
+	close(LOG);
+}
+
+# ------------------------------------------
+# Utilities
+# ------------------------------------------
+
+sub path
+{
+	my ($in) = @_;
+
+	if($^O =~ /Win32/)
+	{
+		$in =~ s~/~\\~g;
+	}
+	else
+	{
+		$in =~ s~\\~/~g; 
+	}
+	return $in;
+}
+
+sub data : lvalue
+{
+	$data{$_[0]};
+}
+
+sub slurp
+{
+	my ($file, $no_chomp) = @_;
+	open(FILE, $file) or return "FAILED";
+	my @all = <FILE>;
+	close(FILE) or return "FAILED";
+
+	chomp @all unless $no_chomp;
+
+	if(wantarray)
+	{
+		return @all;
+	}
+	else
+	{
+		return join('', @all);
+	}
+}
+
+sub strip_html
+{
+	$_ = shift;
+	s/<br>/\n/gi;
+	s/<.*?>//gi;	
+	s/&amp;/&/gi;
+	s/&gt;/>/gi;
+	s/&lt;/</gi;
+	s/&quot;/\"/gi;
+	return $_;
+}
+
+# This code assumes that Win32 and *NIX are the only architectures milkbone
+# will be used on.  This probably isn't that bad of an assumption, since Mac
+# OS X is now BSD-based.
+
+sub nix
+{
+    $^O !~ /Win32/;
+}
+
+sub win32
+{
+    $^O =~ /Win32/;
+}
+
+sub nt
+{
+    return unless win32();
+    
+    eval 'use Win32';
+    return (Win32::GetOSVersion())[4];
+}
+
+sub user_file
+{
+	my ($file) = @_;
+	my $user = data("me");
+
+        my $dir = (nix()  ? "$ENV{HOME}/.milkbone" : 
+            (nt() ? "$ENV{APPDATA}/milkbone" : "profiles"));
+
+	mkdir $dir unless -e $dir && -d $dir;
+	mkdir path("$dir/$user") unless -e path("$dir/$user") && -d path("$dir/$user");
+
+	return path("$dir/$user/$file");
+}
+
+# ------------------------------------------
+# Overrrides
+# ------------------------------------------
+
+*CORE::GLOBAL::die = sub {
+	return CORE::die(@_) if $_[0] =~ /TK_BREAK/;
+	hook("error", -short => join(' ', @_), -long => longmess(join(' ', @_)), -fatal => 1);
+	print longmess(@_);
+	abort;
+};
+
+*CORE::GLOBAL::warn = sub {
+	hook("error", -short => join(' ', @_), -long => longmess(join(' ', @_)));
+	print longmess(@_);
+};
+
+1;

build-temp.bat

@@ -0,0 +1,4 @@
+cd plugins
+perl compress_dist.pl
+cd ..
+perlapp --nocompress --lib lib --verbose --icon images\mbone.ico --force --xclude mos.pl --freestanding --exe milkbone.exe --trim POSIX --add Tk;Tk::Photo;Tk::Text;Tk::TextUndo;Tk::ROText;Tk::HList;Tk::Tree;Tk::ItemStyle;Tk::LabEntry;Socket;Digest::MD5;Win32::API;Win32::GuiTest;Tk::Font;UNIVERSAL;Win32::Sound;Winamp::Control;Tk::BrowseEntry

build.bat

@@ -0,0 +1,5 @@
+cd plugins
+perl compress_dist.pl
+cd ..
+perlapp --nocompress --gui --lib lib --verbose --icon images\mbone.ico --force --xclude mos.pl --freestanding --exe milkbone.exe --trim POSIX --add Tk;Tk::Photo;Tk::Text;Tk::TextUndo;Tk::ROText;Tk::HList;Tk::Tree;Tk::ItemStyle;Tk::LabEntry;Socket;Digest::MD5;Win32::API;Win32::GuiTest;Tk::Font;Winamp::Control;Tk::BrowseEntry;Win32::Sound
+upx milkbone.exe 

docs/BUGS.txt

@@ -0,0 +1,9 @@
+periods in screen names
+fatal error garbage
+deregister might need some work
+if you have the buddy group minused so it doesnt show the members and when someone logs on after it is minused, they show up listed under the list still even though it is minimized
+might not log on easily after getting booted
+weird double convos
+typing goes away when you send
+mobile icons = buggy
+graceful failing on linux (and vice-versa)

docs/CREDIT.txt

@@ -0,0 +1,14 @@
+dan chokola				Original inspiration to rewrite aim
+marci caraballo				"Goodbye and Sign Off" feature
+aj kappe				Broadcast Messages
+eric thul				File-Sharing Searches
+greg blair				Special characters
+dave mcpherson				Profile Change Alert
+matthew sachs				Wrote the Net::OSCAR module
+paul christian				Automatic sarcasm
+aj kappe				history of sent messages
+aj kappe				wishbone instead of wishlist
+dan chokola				remote command line
+marc dashevsky				the spiffy BrowseEntry control (not yet used)
+eric thul and bill atkins		plugin/MOS separation
+rob mccool				for documenting httpd.conf and not noticing that we stole his words :)

docs/FILEMAP.txt

@@ -0,0 +1,21 @@
+mb.pl
+----
+
+The core of milkbone.  mb.pl coordinates all other modules and contains the code for the MBMain function, which
+governs milkbone's basic flow of execution.  All Net::OSCAR events are handled in mb.pl and dispatched thence to the 
+appropriate module.
+
+Milkbone.pm
+----
+
+Milkbone.pm contains common Milkbone routines, including:
+
+    1.  slurp and pour - for whole-file input and output
+    2.  hook - for calling user-installed hooks (as part of the plugin system)
+    3.  begin_log and end_log - for logging errors to errlog.txt
+    4.  path - for using Windows paths on UNIX and vice-versa
+
+Milkbone\OS.pm
+----
+
+MIlkbone::OS encapsulates OS-specific calls to allow easier porting.

docs/HISTORY.txt

@@ -0,0 +1,25 @@
+the history of milkbone
+-----------------------
+
+When people ask how milkbone came to be, I like to tell a little story.  It goes like this:
+
+------------------
+now it came to pass that in those days Satan came unto the peoples of the 
+internet and said, 'behold - i give you AOL.'  and the soccer moms and the 
+other unfaithful ones took up the gift and said, "yea, this is good and we 
+shall use it and spread it over the earth."  and they didst take AOL in the 
+form of innocent-looking cd's sent through the mail and they didst use it and 
+pay exorbitant rates for it and they didst tell their friends until all the 
+world was caught up in the unholy trap.
+
+and then it happened that the origins of AOL were discovered and some of the 
+people did say: 'alas! for we have been deceived' and they cast off the poision 
+of AOL and created then a Holy Hand Messenger and, counting from one to three, 
+didst say unto the world, 'hark! for freedom lies in aimLess' and they didst 
+pull the pin and didst count from one to three, not including four and not 
+counting zero.  and aimLess then was released and all was well.
+------------------
+
+Except for the part about Satan creating AOL, this story is purely fictional.  It was originally our slogan until we realized it was WAY too long.  (aimLess and Holy Hand Messenger were former names for milkbone)
+
+The real history is a little different, but I have no interest in typing it now.

docs/HOOKS.txt

@@ -0,0 +1,227 @@
+Milkbone.pm:25:our @EXPORT = qw( hook is_running abort queued_hook register_hook option path data %ARGS slurp
+Milkbone.pm:26:	deregister_hook strip_html user_file set_option MOSLoop set_interval);
+Milkbone.pm:31:our (%hooks, %options, %data);
+Milkbone.pm:56:	register_hook("load_options", \&load_options);
+Milkbone.pm:57:	register_hook("load_plugins", \&load_plugins);
+Milkbone.pm:58:	register_hook("post_mainloop", \&post_mainloop);
+Milkbone.pm:59:	register_hook("pre_mainloop", \&pre_mainloop);
+Milkbone.pm:60:	register_hook("save_options", \&save_options);
+Milkbone.pm:61:	register_hook("error", \&error);
+Milkbone.pm:187:sub hook
+Milkbone.pm:189:	my ($hook, %args) = @_;
+Milkbone.pm:193:	warn "Unregistered hook called: $hook" . ' ' . join(' ', caller) . "\n" if !exists($hooks{$hook});
+Milkbone.pm:197:	for $hook (@{$hooks{$hook}})
+Milkbone.pm:201:		$ARGS{$_} = $hook->{args}->{$_} for %{$hook->{args}};
+Milkbone.pm:202:		$res = $hook->call;
+Milkbone.pm:210:sub register_hook
+Milkbone.pm:212:	my ($hook, $coderef, $args) = @_;
+Milkbone.pm:214:	my $entry = new Milkbone::HookEntry($hook, $coderef, $args, $package);
+Milkbone.pm:216:	push @{$hooks{$hook}}, $entry;
+Milkbone.pm:219:sub deregister_hook
+Milkbone.pm:221:	my ($hook) = @_;
+Milkbone.pm:223:	my @temp = @{$hooks{$hook}};
+Milkbone.pm:225:	die "Required hook missing" if !exists($hooks{$hook}) and $hook eq "tick";
+Milkbone.pm:226:	warn "Unregistered hook deleted: $hook" if !exists($hooks{$hook});
+Milkbone.pm:228:	@temp = grep { ($_->{package} ne $package) && ($_->{hook_name} ne $hook) } @temp;
+Milkbone.pm:230:	@{$hooks{$hook}} = @temp;
+Milkbone.pm:238:		hook("tick");
+Milkbone.pm:249:	hook("save_options");
+Milkbone.pm:336:	hook("error", -short => join(' ', @_), -long => longmess(join(' ', @_)), -fatal => 1);
+Milkbone.pm:342:	hook("error", -short => join(' ', @_), -long => longmess(join(' ', @_)));
+mos.pl:35:			hook("load_options");
+mos.pl:36:			hook("load_plugins");
+mos.pl:42:	hook("load_options");
+mos.pl:43:	hook("load_plugins");
+mos.pl:44:	hook("pre_mainloop");
+mos.pl:46:	hook("create_logon_prompt");
+mos.pl:51:	hook("post_mainloop");
+plugins/Milkbot.pl:21:register_hook("signed_in", \&init);
+plugins/Milkbot.pl:24:	hook("protocol_get_realname", -user => $me = $ARGS{-me});
+plugins/Milkbot.pl:26:	register_hook("milkbot_set_command", sub {
+plugins/Milkbot.pl:29:	hook("milkbot_get_commands");
+plugins/Milkbot.pl:30:	register_hook("msg_in", \&on_im);
+plugins/Milkbot.pl:41:		hook("milkbot_command", -cmd => $cmd);
+plugins/Milkbot.pl:42:		hook("milkbot_command_$cmd", -user => $from, -msg => $msg);
+plugins/Milkbot.pl:51:	hook("protocol_send_im", -dest => $to, -msg => $msg, -away => $away);
+plugins/Forum-Check/Forum-Check.pl:12:register_hook("pre_mainloop", sub {
+plugins/Forum-Check/Forum-Check.pl:17:	my $mw = hook("tk_getmain");
+plugins/Forum-Check/Forum-Check.pl:24:			hook("error", -short => "New posts in the BATKINS forum.");
+plugins/Forum-Check/Speak.pl:20:register_hook("msg_in", sub { say("You have a message from $ARGS{-user}"); });
+plugins/Win32X.pl:13:register_hook("flash_window", sub {
+plugins/XAMP.pl:17:register_hook "signed_in", sub {
+plugins/XAMP.pl:19:	hook("protocol_commit_info");
+plugins/XAMP.pl:21:	hook("tk_getmain")->repeat(5000, sub {
+plugins/XAMP.pl:24:		hook("protocol_commit_info") if $commit;
+plugins/XAMP.pl:28:	register_hook("request_mod", sub {
+plugins/XAMP.pl:44:	hook("protocol_mod_prof", -name => "%a", -value => $artist);
+plugins/XAMP.pl:45:	hook("protocol_mod_away", -name => "%a", -value => $artist);
+plugins/XAMP.pl:56:	hook("protocol_mod_prof", -name => "%s", -value => $song);
+plugins/XAMP.pl:57:	hook("protocol_mod_away", -name => "%s", -value => $song);
+plugins/Net-OSCAR/Net/OSCAR.pm:2154:Added hooks to allow client do MD5 digestion for authentication (auth_challenge
+plugins/Net-OSCAR/Net/OSCAR.pm:2612:Rocco Caputo for helping to work out the hooks that let use be used with
+plugins/Net-OSCAR/Net-OSCAR.pl:28:register_hook("protocol_add_buddy",		sub { $oscar->add_buddy($ARGS{-group}, $ARGS{-buddy}); } );
+plugins/Net-OSCAR/Net-OSCAR.pl:29:register_hook("protocol_away_status",	sub { $is_away; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:30:register_hook("protocol_commit_blist",	sub { $oscar->commit_buddylist; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:31:register_hook("protocol_commit_info",	sub { $oscar->set_away($away) if $is_away; $oscar->set_info($prof); } );
+plugins/Net-OSCAR/Net-OSCAR.pl:32:register_hook("protocol_get_away",		sub { $oscar->{away}; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:33:register_hook("protocol_get_groups",	sub { [ $oscar->groups ]; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:34:register_hook("protocol_get_prof",		sub { $oscar->{profile} } );
+plugins/Net-OSCAR/Net-OSCAR.pl:35:register_hook("protocol_get_realname",	sub { $oscar->buddy($ARGS{-user})->{screenname} or $ARGS{-user}; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:36:register_hook("protocol_go_away",		sub { $is_away = 1; hook("protocol_commit_info"); } );
+plugins/Net-OSCAR/Net-OSCAR.pl:37:register_hook("protocol_idle_since",	sub { $oscar->buddy($ARGS{-who})->{idle}; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:38:register_hook("protocol_is_away",		sub { return $oscar->buddy($ARGS{-user})->{away}; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:39:register_hook("protocol_is_on",			sub { $oscar->buddy($ARGS{-who})->{online} } );
+plugins/Net-OSCAR/Net-OSCAR.pl:40:register_hook("protocol_mod_away",		\&mod_away );
+plugins/Net-OSCAR/Net-OSCAR.pl:41:register_hook("protocol_mod_prof",		\&mod_prof );
+plugins/Net-OSCAR/Net-OSCAR.pl:42:register_hook("protocol_on_since",		sub { $oscar->buddy($ARGS{-who})->{onsince}; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:43:register_hook("protocol_remove_buddy",	sub { $oscar->remove_buddy($ARGS{-group}, $oscar->buddy($ARGS{-buddy})->{screenname}); } );
+plugins/Net-OSCAR/Net-OSCAR.pl:44:register_hook("protocol_request_info",	sub { request_info($ARGS{-user}); });
+plugins/Net-OSCAR/Net-OSCAR.pl:45:register_hook("protocol_return",		sub { $oscar->set_away(''); %away_sent = (); $is_away = 0; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:46:register_hook("protocol_send_im",		\&send_im );
+plugins/Net-OSCAR/Net-OSCAR.pl:47:register_hook("protocol_set_away",		\&set_away );
+plugins/Net-OSCAR/Net-OSCAR.pl:48:register_hook("protocol_set_prof",		\&set_prof );
+plugins/Net-OSCAR/Net-OSCAR.pl:49:register_hook("protocol_signon",		\&signon);
+plugins/Net-OSCAR/Net-OSCAR.pl:50:register_hook("protocol_signed_in",		sub { $signed_in; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:51:register_hook("protocol_signoff",		sub { $oscar->signoff; } );
+plugins/Net-OSCAR/Net-OSCAR.pl:64:		hook("error", -short => $desc, -long => longmess($desc), -fatal => $fatal);
+plugins/Net-OSCAR/Net-OSCAR.pl:69:		hook("buddy_in", -buddy => $_[1], -group => $_[2]); 
+plugins/Net-OSCAR/Net-OSCAR.pl:74:		hook("buddy_out", -buddy => $_[1], -group => $_[2]); 
+plugins/Net-OSCAR/Net-OSCAR.pl:79:		hook("msg_in", -user => $_[1], -msg => $_[2], -away => $_[3]) if $_[1]; 
+plugins/Net-OSCAR/Net-OSCAR.pl:80:		hook("msg_in_$_[1]", -user => $_[1], -msg => $_[2], -away => $_[3]);
+plugins/Net-OSCAR/Net-OSCAR.pl:86:		hook("signed_in", -me => $user);
+plugins/Net-OSCAR/Net-OSCAR.pl:92:		hook("error", 
+plugins/Net-OSCAR/Net-OSCAR.pl:95:		hook("rate_alert") if $_[1] == RATE_LIMIT;
+plugins/Net-OSCAR/Net-OSCAR.pl:104:		hook("protocol_info_received_$_[1]", -profile => $prof, -away => $_[2]->{awaymsg}); 
+plugins/Net-OSCAR/Net-OSCAR.pl:115:	hook("tk_getmain")->after(30, \&tick);
+plugins/Net-OSCAR/Net-OSCAR.pl:130:	hook("tk_getmain")->after(30, \&tick);
+plugins/Net-OSCAR/Net-OSCAR.pl:141:		hook("after", -time => 50, -code => [\&request_info, $other_user]);
+plugins/Net-OSCAR/Net-OSCAR.pl:168:	register_hook("request_mod", sub{} );	# for when those hooks just arent yet registered, use register_hook(tm)
+plugins/Net-OSCAR/Net-OSCAR.pl:169:	hook("request_mod");
+plugins/Net-OSCAR/Net-OSCAR.pl:178:	register_hook("request_mod", sub{} );	# ditto, can't wait till hook priorities!
+plugins/Net-OSCAR/Net-OSCAR.pl:179:	hook("request_mod");
+plugins/Sound/Sound.pl:7:register_hook("signed_in", sub { play_sound("signed_in"); });
+plugins/Sound/Sound.pl:8:register_hook("protocol_go_away", sub { play_sound("go_away"); });
+plugins/Sound/Sound.pl:9:register_hook("protocol_return", sub { play_sound("return"); });
+plugins/Sound/Sound.pl:10:register_hook("msg_in", sub { play_sound("msg_in"); });
+plugins/Sound/Sound.pl:11:register_hook("protocol_send_im", sub { play_sound("send_im"); });
+plugins/Sound/Sound.pl:12:register_hook("buddy_in", sub { play_sound("buddy_in"); });
+plugins/Sound/Sound.pl:13:register_hook("buddy_out", sub { play_sound("buddy_out"); });
+plugins/Sound/Sound.pl:14:register_hook("error", sub { play_sound("error"); });
+plugins/Sound/Sound.pl:15:register_hook("protocol_signoff", sub { play_sound("signoff"); });
+plugins/Sound/Sound.pl:19:	return if hook("protocol_away_status") and !option("SoundsWhileAway") and $_[0] ne "go_away";
+plugins/Tk-About/Tk-About.pl:6:my $mw = hook("tk_getmain");
+plugins/Tk-About/Tk-About.pl:8:register_hook "show_about", sub { $mw->MBAbout->focus; };
+plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm:32:    hook("protocol_add_buddy", -group => $group, -buddy => $name);    
+plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm:33:    hook("protocol_commit_blist");
+plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm:41:	my $groups = hook("protocol_get_groups");
+plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm:63:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-AddBuddy/Tk-AddBuddy.pl:9:register_hook("dlg_add_buddy", sub {
+plugins/Tk-BList/Tk-BList.pl:12:my $mw = hook("tk_getmain");
+plugins/Tk-BList/Tk-BList.pl:14:register_hook("signed_in", sub { 
+plugins/Tk-BList/Tk-BList.pl:20:	register_hook("buddy_in", sub { Milkbone::BList::on_buddy_in } , {-self => $blist});
+plugins/Tk-BList/Tk-BList.pl:21:	register_hook("buddy_out", \&Milkbone::BList::on_buddy_out, {-self => $blist});
+plugins/Tk-BList/Tk-BList.pl:22:	register_hook("add_blist_menu_item", \&Milkbone::BList::add_blist_menu_item, {-self => $blist});
+plugins/Tk-BList/Tk-BList.pl:24:	register_hook("protocol_go_away", sub { 
+plugins/Tk-BList/Tk-BList.pl:30:	register_hook("protocol_return", sub { 
+plugins/Tk-BList/Tk-BList.pl:37:	register_hook("error_fatal", sub {
+plugins/Tk-BList/Tk-BList.pl:41:	register_hook("msg_in", sub {
+plugins/Tk-BList/Tk-BList.pl:50:sub reg_change_hook
+plugins/Tk-BList/Tk-BList.pl:54:	register_hook("get_profile", sub {
+plugins/Tk-BList/Milkbone/BList.pm:51:	hook("create_convo", -user => hook("protocol_get_realname", -user => $name), -fabricated => 1);
+plugins/Tk-BList/Milkbone/BList.pm:62:	my $groups = hook("protocol_get_groups");
+plugins/Tk-BList/Milkbone/BList.pm:77:		if(hook("protocol_is_away", -user => $realname))
+plugins/Tk-BList/Milkbone/BList.pm:89:		if(hook("protocol_is_away", -user => $realname))
+plugins/Tk-BList/Milkbone/BList.pm:123:		hook("protocol_go_away");
+plugins/Tk-BList/Milkbone/BList.pm:130:		hook("protocol_return");
+plugins/Tk-BList/Milkbone/BList.pm:142:	hook("protocol_set_info", -info => $info);
+plugins/Tk-BList/Milkbone/BList.pm:199:	hook("dlg_add_buddy", -parent => shift);
+plugins/Tk-BList/Milkbone/BList.pm:209:	hook("get_profile", -user => $buddy, -group => $group);
+plugins/Tk-BList/Milkbone/BList.pm:221:		hook("protocol_remove_buddy", -group => $group, -buddy => $name);    
+plugins/Tk-BList/Milkbone/BList.pm:222:		hook("protocol_commit_blist");
+plugins/Tk-BList/Milkbone/BList.pm:223:		hook("buddy_out", -buddy => $name, -group => $group);
+plugins/Tk-BList/Milkbone/BList.pm:246:	$self->{menu_file}->command(-label => "Set Away...", -command => sub { hook("on_set_away");} );
+plugins/Tk-BList/Milkbone/BList.pm:247:	$self->{menu_file}->command(-label => "Set Profile...", -command => sub { hook("on_set_profile");} );
+plugins/Tk-BList/Milkbone/BList.pm:250:	$self->{menu_file}->command(-label => "Goodbye and Exit", -command => sub { hook("goodbye") });
+plugins/Tk-BList/Milkbone/BList.pm:258:	$self->{menu_help}->command(-label => "About...", -command => sub { hook("show_about") });
+plugins/Tk-BList/Milkbone/BList.pm:288:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-BList/Milkbone/BList.pm:316:	return unless hook("protocol_away_status");
+plugins/Tk-Convo/Milkbone/Convo.pm:53:	hook("protocol_send_im", -dest => $self->{buddy}, -msg => $msg, -away => 0);
+plugins/Tk-Convo/Milkbone/Convo.pm:69:	hook("remove_convo", -user => shift->{buddy});
+plugins/Tk-Convo/Milkbone/Convo.pm:74:	hook("get_profile", -user => shift->{buddy});
+plugins/Tk-Convo/Milkbone/Convo.pm:154:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-Convo/Tk-Convo.pl:10:my $mw = hook("tk_getmain");
+plugins/Tk-Convo/Tk-Convo.pl:13:register_hook("create_convo", sub {
+plugins/Tk-Convo/Tk-Convo.pl:24:	register_hook("msg_in_$buddy", sub {
+plugins/Tk-Convo/Tk-Convo.pl:27:			hook("create_convo", -user => hook("protocol_get_realname", -user => $ARGS{-user}));
+plugins/Tk-Convo/Tk-Convo.pl:30:		hook("flash_window", -wnd => $convo);
+plugins/Tk-Convo/Tk-Convo.pl:33:	register_hook("buddy_in_$buddy", sub {
+plugins/Tk-Convo/Tk-Convo.pl:37:	register_hook("buddy_out_$buddy", sub {
+plugins/Tk-Convo/Tk-Convo.pl:44:	$convo->withdraw if hook("protocol_away_status") != 0;
+plugins/Tk-Convo/Tk-Convo.pl:46:	hook("flash_window", -wnd => $convo) unless $ARGS{-fabricated};
+plugins/Tk-Convo/Tk-Convo.pl:49:register_hook("remove_convo", sub {
+plugins/Tk-Convo/Tk-Convo.pl:50:	deregister_hook("msg_in_$ARGS{-user}");
+plugins/Tk-Convo/Tk-Convo.pl:51:	deregister_hook("buddy_in_$ARGS{-user}");
+plugins/Tk-Convo/Tk-Convo.pl:52:	deregister_hook("buddy_out_$ARGS{-user}");
+plugins/Tk-Convo/Tk-Convo.pl:58:register_hook("msg_in", sub {
+plugins/Tk-Convo/Tk-Convo.pl:59:	hook("create_convo", -user => hook("protocol_get_realname", -user => $ARGS{-user}));
+plugins/Tk-Convo/Tk-Convo.pl:62:register_hook("get_convo", sub {
+plugins/Tk-Convo/Tk-Convo.pl:66:register_hook("protocol_go_away", sub {
+plugins/Tk-Convo/Tk-Convo.pl:70:register_hook("protocol_return", sub {
+plugins/Tk-Convo/Tk-Convo.pl:74:register_hook("goodbye", sub {
+plugins/Tk-Convo/Tk-Convo.pl:77:	hook("protocol_send_im", -dest => $_, -msg => $goodbye, -away => 0) for(keys(%convos));
+plugins/Tk-Convo/Tk-Convo.pl:80:register_hook("buddy_in", sub {
+plugins/Tk-Convo/Tk-Convo.pl:81:	hook("buddy_in_$ARGS{-buddy}", -group => $ARGS{-group}) if $convos{$ARGS{-buddy}};
+plugins/Tk-Convo/Tk-Convo.pl:84:register_hook("buddy_out", sub {
+plugins/Tk-Convo/Tk-Convo.pl:85:	hook("buddy_out_$ARGS{-buddy}", -group => $ARGS{-group}) if $convos{$ARGS{-buddy}};
+plugins/Tk-File/Milkbone/File.pm:51:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-File/Milkbone/File.pm:67:		hook("protocol_set_prof", -data => $text);
+plugins/Tk-File/Milkbone/File.pm:71:		hook("protocol_set_away", -data => $text);
+plugins/Tk-File/Tk-File.pl:10:my $mw = hook("tk_getmain");
+plugins/Tk-File/Tk-File.pl:12:register_hook "edit_file", sub {
+plugins/Tk-File/Tk-File.pl:29:register_hook "on_set_profile", sub {
+plugins/Tk-File/Tk-File.pl:30:	hook("edit_file", -type => "profile");
+plugins/Tk-File/Tk-File.pl:33:register_hook "on_set_away", sub {
+plugins/Tk-File/Tk-File.pl:34:	hook("edit_file", -type => "away");
+plugins/Tk-File/Tk-File.pl:37:register_hook "signed_in", sub {
+plugins/Tk-File/Tk-File.pl:57:	hook("protocol_set_prof", -data => $prof);
+plugins/Tk-File/Tk-File.pl:58:	hook("protocol_set_away", -data => $away);
+plugins/Tk-GUI/Tk-GUI.pl:38:register_hook("tk_seticon", sub { $ARGS{-wnd}->Icon(-image => $icon); });
+plugins/Tk-GUI/Tk-GUI.pl:40:register_hook("tick", \&tick);
+plugins/Tk-GUI/Tk-GUI.pl:41:register_hook("tk_getmain", sub {
+plugins/Tk-GUI/Tk-GUI.pl:45:register_hook("after", sub {
+plugins/Tk-GUI/Tk-GUI.pl:61:register_hook("error", sub {
+plugins/Tk-GUI/Tk-GUI.pl:64:	hook("tk_seticon", -wnd => $error_box);
+plugins/Tk-GUI/Tk-GUI.pl:72:		hook("protocol_signoff") if $fatal;
+plugins/Tk-GUI/Tk-GUI.pl:73:		exit if $fatal and hook("protocol_signed_in");
+plugins/Tk-Logon/Milkbone/Logon.pm:14:my $mw = hook("tk_getmain");
+plugins/Tk-Logon/Milkbone/Logon.pm:45:	hook("protocol_signoff") if $self->{signed_on};
+plugins/Tk-Logon/Milkbone/Logon.pm:59:	hook("protocol_signon", -user => $self->{sname}, -pass => $self->{pass});
+plugins/Tk-Logon/Milkbone/Logon.pm:72:	hook("protocol_signoff");
+plugins/Tk-Logon/Milkbone/Logon.pm:128:	$self->{controls}->Button(-text => 'about', -command => sub { hook("show_about") }, 
+plugins/Tk-Logon/Milkbone/Logon.pm:140:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-Logon/Tk-Logon.pl:9:my $mw = hook("tk_getmain");
+plugins/Tk-Logon/Tk-Logon.pl:12:register_hook("create_logon_prompt", sub {
+plugins/Tk-Logon/Tk-Logon.pl:16:	register_hook("signed_in", sub { 
+plugins/Tk-Logon/Tk-Logon.pl:21:	register_hook("error", sub {
+plugins/Tk-PluginsConf/Milkbone/PluginsConf.pm:72:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-PluginsConf/Tk-PluginsConf.pl:9:register_hook("dlg_plugins", sub {
+plugins/Tk-Profile/Milkbone/Profile.pm:57:	hook("remove_profile", -who => $self->{who});
+plugins/Tk-Profile/Milkbone/Profile.pm:82:	my $on_time = time - hook("protocol_on_since", -who => $who);
+plugins/Tk-Profile/Milkbone/Profile.pm:88:	if(hook("protocol_idle_since", -who => $who))
+plugins/Tk-Profile/Milkbone/Profile.pm:90:		my $idle_time = hook("protocol_idle_since", -who => $who);
+plugins/Tk-Profile/Milkbone/Profile.pm:110:	hook("tk_seticon", -wnd => $self);
+plugins/Tk-Profile/Tk-Profile.pl:9:my $mw = hook("tk_getmain");
+plugins/Tk-Profile/Tk-Profile.pl:11:register_hook("get_profile", sub {
+plugins/Tk-Profile/Tk-Profile.pl:20:	hook("protocol_request_info", -user => $who);
+plugins/Tk-Profile/Tk-Profile.pl:24:	register_hook("protocol_info_received_$who", sub {
+plugins/Tk-Profile/Tk-Profile.pl:41:register_hook("remove_profile", sub {
+plugins/Tk-Profile/Tk-Profile.pl:42:	deregister_hook("protocol_info_received_" . $ARGS{-who});
+plugins/Win32-Tray/Win32-Tray.pl:12:register_hook("signed_in", sub {
+plugins/Win32-Tray/Win32-Tray.pl:24:	hook("tk_getmain")->repeat(500, sub {
+plugins/Win32-Tray/Win32-Tray.pl:28:	register_hook("post_mainloop", sub {
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:27:register_hook("milkbot_get_commands", \&init);
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:70:		hook("milkbot_set_command", -name => $_, -desc => $commands{$_}[1]);
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:72:	register_hook("milkbot_command", sub { $cmd = $ARGS{-cmd};
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:73:		register_hook("milkbot_command_$cmd", sub {
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:75:			deregister_hook("milkbot_command_$cmd") if $cmd;
+plugins/Milkbot-Xmms/Milkbot-Xmms.pl:82:	hook("protocol_send_im", -dest => $to, -msg => $msg, -away => $away);

docs/KLUDGES.txt

@@ -0,0 +1 @@
+the browser system

docs/OSCARMODS.txt

@@ -0,0 +1,2 @@
+Accepts typing notifications
+Retrieves mobile information

docs/README.txt

@@ -0,0 +1,57 @@
+milkbone 0.13 README
+-------------------------------------
+
+milkbone is a rewrite of the AOL Instant Messenger client program for the Win32 operating system.  milkbone is 
+written entirely in perl (well, there's a BIT of C) and is open-source freeware.  milkbone may be freely 
+redistributed under the GPL as long as this file remains intact and any modifications to the core are noted.
+
+USE
+------------------------------------
+
+Win32
+-----
+
+To run milkbone, simply execute mb.exe or, if you have Perl installed on your system, run src\mb.pl (from the source 
+distro).
+
+Log on with your username and password.  Then just go for it. :)
+
+UNIX/Linux
+----------
+
+milkbone is designed for use on Win32 systems.  However, since the milkbone core is written in perl and uses the 
+Perl/Tk library, milkbone will also run on UNIX-based systems.  See COMPATIBILITY.txt for known compatibility issues.
+
+Mac OS
+------
+
+Milkbone should work on Mac OS X, although this has never been tested.  Anywone who feels like testing can go
+ahead and do so.
+
+DEVELOPMENT
+------------------------------------
+
+milkbone was written and is maintained by the aimLess Consortium.  The following individuals are members of the 
+Consortium's development team at this time:
+
+Bill Atkins (thebone@batkins.com)		Lead Programmer
+Sidharth Malhotra				Programmer
+Eric Thul   					Programmer and UNIX Porter
+Dan Chokola					Programmer
+
+The Consortium is always looking for Perl programmers to lend us a hand.  Contact us if you're interested.
+
+The milkbone core is distributed from http://milkbone.batkins.com/   The milkbone mailing list is available at 
+aimless@batkins.com.
+
+DONATIONS
+-----------------------------------
+
+The aimLess Consortium is always willing to accept donations.  If you want to help milkbone by donating a few dollars, contact 
+thebone@batkins.com.  Remember, we do all this for free; a little donation would make the entire Consortium feel good
+about itself.
+
+CONTACT US
+-------------------------------------
+
+Please send any comments/suggestions/concerns to thebone@batkins.com.

docs/SLOGANS.txt

@@ -0,0 +1,9 @@
+it's a dog-eat-dog world, and I'm wearing milkbone underwear.
+if you have't tried milkbone yet, then perhaps you're a nazi.
+milkbone  is as stable as a frying pan
+milkbone > milk + bone
+an amalgam of sweetness
+milkbone - now with mystical kung-fu power
+it's kosher
+ it's all set and poised to serioualy mess up aim and its evil monopoly, so join the revolution. 
+ bringing the spunk that is milkbone"

docs/SPECS.txt

@@ -0,0 +1,34 @@
+ # -----------------------------------------------------------------------------
+# Bill Atkins and Eric Thul
+# Milkbone DesignDoc
+# 12.21.02
+# -----------------------------------------------------------------------------
+
+
+1. Problem Statement:
+	a. Goal - To create an enhanced version of AIM and establish a new messaging protocol.
+	b. Constraints - Run on multi platforms ( UNIX, MAC OSX, WIN32 ), also use the Oscar protocol for communication with AIM and AOL IM. Have a pluggable backplane and be modular. Use minimal memory and hard drive space. Provide the major features of AIM and much more, ex: Buddylists, Chatting, IM, Icons, Profiles. Make the core as small and basic as possible.
+	c. Inputs - Username and password ( AIM info), also text and pictures, away messages, profiles.
+	d. Output - Messages from other users, profiles, icons, logs.
+	e. Simplification - make a totally modular program with each component developed separately and able to be plugged into the core.
+
+2. Relevent Objects ( modules ):
+	a. Core
+	b. Protocol ( backend )
+	c. GUI ( frontend )
+	____ Event Handles ( hooks ) ____
+	d. BuddyList
+	e. ProfileManager
+	f. ChatManager
+	g. IMManager
+	h. AwayMessage
+	i. Preferences
+	j. Logger
+	k. Login
+
+3. N/A
+
+4. Open Issues:
+	a. Establishing the new protocol may pose a bit of a challenge with running a server and all the other connections to Oscar and other char client protocols.
+	b. To break the char limit on the profiles.
+	c. todo list ( see relevant file )

docs/VERSION.txt

@@ -0,0 +1,463 @@
+0.355
+--
+
+* Removed PAR usage
+* Plugin reloading works pretty darned well
+* Uses ~/.milkbone on Linux, AppData on Win2K, XP, etc. and profiles on Win98, etc.; needs testing on NT
+* Reloading of the core (Milkbone.pm) is now supported)
+* mb.conf is only saved if changed
+* Reloading of plugins works
+* Plugin list now updates properly
+* Sounds off by default
+* Cleaned out some useless files
+* Removed some useless sounds
+* Now runs on Perl 5.6 on non-Win32 machines
+* Tray icon now allows hiding and showing of windows (enabled by default)
+* XAMP rewritten - it's bunches cleaner now
+* Timeout renamed to AwayTimeout
+* Fixed goodbye bug (again)
+* Duplicate convo bug fixed
+* Line break thing in profiles is gone
+* Errors no longer kill milkbone on Linux
+* Fixed font sizes on Linux
+  * Fancier toolbar
+* < and > work in profiles and convos (you can send them as &lt and &gt for now)
+* Splash screen
+* Mouse wheel works in Linux
+* No more boxes in focused widgets on Linux
+* Sounds now play asynchronously on Linux (without starting too many play processes)
+* Fixed weirdness with context menu on Linux
+* Fancier buttons and menus on Linux (a LOT fancier)
+* Preliminary aliasing support
+* Alias-saving works (but is disabled)
+* Sound works on Linux (without running artsd)
+* Really fixed the Busted SNAC bug
+
+0.354 6-9-2003
+---
+
+* May have fixed the Busted SNAC/ Empty Convo Bug (hopefully it is fixed, because that name is WAY too long)
+* Fixed newline problem in profiles
+
+0.353 5-4-2003
+---
+
+* Typing status doesn't clear after sending
+* Mouse-wheeling in buddy list
+* Smaller buddy list scrollbar
+* New buddy list font
+* Fixed goodbye
+* Fixed protocol_send_im
+* Extraneous timers now die instead of eating CPU time; this is a good thing
+* Added support for chat to net-oscar (Tk-Chat plugin forthcoming)
+* buddy_in and buddy_info_changed are now separate hooks
+* Add buddy group dialog
+
+0.352a	4-30-2003
+---
+
+* Fixed a deadly profile-viewing bug
+
+0.352 4-30-2003
+---
+
+* Underline support
+* Increased the time required to get a rate error for viewing profiles
+* Scrolls properly after a buddy comes in or out
+* Tray icon is disabled until I figure out why it slows down the boot process so much (this makes for faster loading)
+* Toolbar buttons depress appropriately
+* Sends more timely notifications
+* Includes the 0.351a patch
+* Minor problems with typing notifications
+* Added support for sending underlines
+* Can set style of current text by clicking toolbar buttons
+* No more errors from the toolbar
+* Empty convo title bug might be gone :)
+
+0.351a 4-26-2003
+---
+
+* Fixed some bugs in typing notification that caused rate errors
+
+0.351 4-26-2003
+---
+
+* send_im adds to the convo window (for milkbot)
+* Fixed a reregistration bug in Net-OSCAR
+* Putting %v in your profile or away will reveal your milkbone version
+* Sends typing notifications
+* Displays typing notifications
+* Beta of a plugin loader (soon there'll be an unloader, too)
+* Fixed Goodbye and Exit
+* Fixed warnings from XAMP
+* Much-improved combo boxes
+* No flicker when loading AddBuddy
+* Beta of FCL
+* Better error-handling (less death)
+* Now indicates whether a buddy is on a cell phone (with an image pirated from AIM :D )
+* deregister_hook is now decidedly functional
+* Plugin Configurator
+* Can now send out <'s and >'s to aim users
+* Fixed bug in convo titles (related to getting the buddy's real name)
+* Milkbot and Milkbot-Music now work on Win32
+* Fixed background color bugs in convos
+* Speeded up Tk-GUI's load time
+
+0.35 4-20-2003
+---
+
+* Milkbot split into generic module and music-specific module (dan chokola)
+* Some work on FCL
+* Patched Tk - cut down on a few memory leaks
+* Now autoscrolls again in convos
+* Fixed bug when receiving IM's from nonbuddies
+* Works with Winamp 3.0
+* Scrolling titles in Winamp
+* Timestamps (hit F2 in a convo)
+* Tray icon with Exit (on Win32)
+
+0.341 4-13-2003
+---
+
+* Sends < and > properly
+* Fixed error after looking at size-adjusted fonts
+* Profiles still look pretty when you maximize them
+* Fixed extra newlines at the end of aways and profiles
+* Fixed Cancel bug in AddBuddy
+
+0.34 4-11-2003
+---
+
+* Fixed the newline-formatting bug in Tk-Convo
+* The Add Buddy box now has a dropdown (a cheap-looking dropdown, but a dropdown nonetheless)
+* CVS server set up (link at http://milkbone.batkins.com)
+* Fixed font size problem
+* Fixed color problems in profiles (pointed out by greg)
+* Fixed add buddy dialog (pointed out by mario)
+
+0.333a 4-10-2003
+---
+
+* Fixed the silly bug in the set profile boxes (thanks for breaking it, dan! ;) )
+
+0.333 4-10-2003
+---
+
+* FCL works in profiles and aways
+* Added support for font faces and colors (sizes coming soon)
+* Nested tags work (no more <b>'s)
+* Added support for underlined text
+
+0.332a 4-9-2003
+---
+
+* Profile focusing works better
+* Fixed Add Buddy dialog
+* Fixed Remove Buddy
+* About box now has escape enabled
+* Fixed lag in edit boxes
+* Prepare for CVS..... (next version)
+* Reorganized the source tree
+* Fixed away message counter
+
+0.332 4-8-2003
+---
+
+* Buddy list now tracks number of waiting messages
+* Waiting message count in buddy list
+* XAMP is ready (the rewrite of AIMAMP) (dan chokola)
+* Top window is no longer editable
+* Automatic compression script in src/plugins
+* Links in messages
+* Better indenting in the buddy list (dan chokola)
+* Away icons that are just slightly cooler
+* Plugins are in ZIP's instead of PAR's for easier access (suggested by DJ)
+* Rate errors with profiles are (almost) gone
+* Error messages no longer crash milkbone
+* Formatting screen names now works properly with buddy list
+* Tray icon in win32 (experimental)
+* No more gap in the convo windows (kudos to dan chokola for pointing out my wrongness)
+* Plugin order in mb.conf no longer affects operation
+* Profiles now work like browsers
+* Current version now shown in about box, profile, and logon screen
+* Expiration message gone
+* New conversations flash in the taskbar
+* Tk-AddBuddy now a separate plugin
+* AOL profile message works a little better (dan chokola)
+* Profile color and font revised (dan chokola)
+* Sound on Linux (dan chokola)
+* Tk-GUI now contains cross-platform Tk code (replaces Tk-Win32 and Tk-Linux)
+* <, <, &, and " now appear correctly in conversations
+* AIMAMP now works on Windows and Linux
+* AIMAMP plugin separates artist and title (dan chokola)
+* (Much) better support for profile  and away templates (dan chokola) 
+* Carriage return issues in convos fixed (dan chokola)
+
+0.331 2-18-2003
+---
+
+* Fixed a bug in the browser that caused it to retain text settings when it shouldn't have
+* MUCH better processor usage (0% most of the time, with peaks of around 8%)
+
+0.33 2-17-2003
+---
+
+* Preliminary support for FCL (fonts, colors, links) - bold text is now properly displayed
+* Brand-new convos now flash in the title bar
+* Fixed an insidious bug in AIMAMP (pointed out by eric)
+
+0.323 2-15-2003
+---
+
+* Less CPU Usage (pointed out by dj and tyler)
+* Proper icon for away/profile editor
+* Errlog is now opened only when necessary so you can empty it while milkbone's still running
+* AIMAMP errors gone (pointed out by eric)
+* Error log now never exceeds 500K (pointed out by eric)
+* Fixed those annoying 'signed in' messages
+
+0.322 2-9-2003
+---
+
+* REALLY fixed the random crashes
+
+0.321 2-9-2003
+---
+
+* Fixed AIMAMP errors in errlog.txt
+* Fixed repetitive buddy in messages
+* Fixed random crash nonsense
+
+0.32 2-9-2003
+---
+
+* Preliminary support for remembering the size of convo windows
+* Configuration changes are now saved
+* &quot; no longer appears in profiles
+* Warning for rate limits
+* Had to disable the combo in AddBuddy - it's all manual until next version
+* You no longer have to change songs after changing your profile
+* %s now works properly in away messages
+* Errors no longer kill milkbone (unless they're fatal - then they do)
+* You can talk to people who aren't on your buddy list without getting hash errors
+* Can add buddies into a specific group
+* Buddy deletion actually works now
+* Idle time display
+* Empty groups show up
+* Buddy groups in order
+
+0.31 2-7-2003
+---
+
+* Built-in AIMAMP (put %s in your away message or profile)
+* Online time in profile window
+* An even suaver buddy list
+* Multiple buddy selection has become an oxymoron
+* By switching from GIF's to BMP's, milkbone uses less RAM
+* Remove buddies from the context menu (molhotra)
+* Add buddies from the File menu (molhotra)
+* Away messages will only be returned every Timeout seconds (thanks to greg for the suggestion)
+* Away messages are ow sent to incoming messages (thanks to dan for pointing this out)
+* Convos now hide when going away
+* About box works
+* Tab problem is now fully fixed (no message boxes)
+* You can now save away messages again (thanks, mundane detail!!)
+* Fixed focusing problems (mostly - profiles are still a little funky)
+* Added preliminary (non-working) code for buddy coloring
+* Buddy list now properly updates when a user logs out (this worked before the Rewrite, of course)
+* Added a Timeout directive
+* Get Buddy Info bug may be fixed
+* PAR is now actually used
+* Initialization file is now $plugin.pl instead of main.pl
+* Error logging actually works (props to bwahl for pointing this out)
+* Properly removes buddies from list on signout
+* Focuses new convos and profiles
+* Writes to errlog are now appended instead of overwritten
+
+0.3 2-5-2003
+---
+
+* Goodbye directive
+* Buddy list turns gray when you go away (and that even rhymes)
+* Right-clicking for profiles (molhotra)
+* User data goes into profiles folders
+* Tk compiled into milkbone.exe because of PAR problems
+* %n replacement
+* The Port directive allows TCNJ and Stockton students (and many others) to finally get through their firewalls
+* StdLib module contains standard Perl modules
+* Assorted aesthetic improvements to the Profile module - icon, nice title
+* Unlimited Redo's/Undo's with Ctrl-Z
+* More robust profile retrieving (this took a while for some reason)
+* Hook registration and deregistration
+* More informative deaths
+* MUCH smaller distro (thanks to PAR and UPX)
+* Fixed the infamous Tab Problem
+* Slicker away message icons
+* Global configuration in mb.conf
+* Eliminated the tray icon (it will return when it decides to do something)
+* Plugins can be written as single files (idea from molhotra)
+* Hitting enter in mid-text no longer breaks up stream
+* Recompiled for use with Perl 5.8
+* Suave-looking buddy lists
+* The --load command-line option will unpack all dependencies (except Tk, which is the one that matters :) )
+* PAR is now used for decompression instead of perlapp
+* Code can now be plugged into milkbone, although no documentation for this has been written
+* Completely redesigned the core
+
+0.21 12-9-2
+----
+
+* New logo
+* Prevented (hopefully) a bug that made the bone quit at random
+
+0.2 12-8-2
+----
+
+* Extended time for update-checking
+* Created the filemap
+* Shaved around 600K from the final executable 
+* Removed useless images; replaced POSIX with straight constants
+* Replaced the bloated LWP package with HTTP::Lite
+* New logo
+* Recompiled everything for compatibility with Perl 5.8
+* Bought the PDK (no more expirations :) )
+* Preliminary hooking
+* Logging to errlog.txt (for el gato :) )
+* Prettier deaths (with message boxes)
+* Installer will now overwrite shortcuts - this is a Good Thing
+* Milkbone::OS now separates OS-dependent code from the core
+* All modules now stored in src/lib
+* Checks for empty messages before going away
+* Re-released 0.161
+
+0.161 11-26-2
+----
+
+* When XP groups your convos in the taskbar, they show up as "milkbone" instead of "mb"
+* Editing of multiple-line profiles works
+* Hides messages and changes button when away
+* Tweaked the compilation options to reduce milkbone's startup time to just under 1.5 seconds
+* Goodbye and Exit now clears the tray icon (chokola)
+* Now logins (as well as logouts) are noted in the conversation window (this was a LOT harder than you'd think :) )
+* Tweaked the update system to prevent annoying messages that might appear behind a proxy
+
+0.16  11-24-2
+----
+
+* Update alerts
+* Taskbar windows flash
+
+0.155 11-23-2
+----
+
+* Cleaned up the installer script
+* About box from menu
+* Set aways and profiles from File menu
+* Added an annoying drumming for new messages until I can get flashing to work (it only drums
+  if the new message isn't in the focus
+* Logo bar above buddy list
+* Fixed &quot; and &lt;-type strings in profiles, aways, and messages
+* More compact buddy list
+* Fixed bug that killed milkbone when user looks at a non-away user's profile (after viewing this profile, 
+  viewing any other profiles would crash milkbone)
+* Allowed messages that come in while away to be displayed
+* Messed around with the hashes to fix the SNAC error
+* Overloaded CORE::GLOBAL::die to prevent improper signoff errors (which led to inexplcable busted SNAC's) and
+  and to prevent the tray icon from living after death
+
+
+0.154 11-21-2
+----
+
+* Profiles scroll (with mousewheel) and wrap and respond to the escape button
+* Fixed auto-response (chokola)
+* Times instead of courier in profiles
+
+0.153 11-19-2
+----
+
+* Can set profiles
+* Can set away messages
+* Removed the silly buttons
+* Added away messages to profiles
+* Made path names more portable to make UNIX ports easier
+* Added code to lessen the chance that the icon would remain in the tray after a crash
+
+0.152 11-14-02
+----
+
+* Away icons
+* Added Get Profile function (uses the world's greatest kludge to accomplish viewing of profiles)
+* Spiffed up the about box and gave it its own class
+* Set up status bot on screen name billiamive
+* Moved misplaced functions in mb.pl
+* Plus and minus buttons
+* Installer now sends documentation as well 
+
+
+0.151 11-14-02
+----
+
+* Funky buttons
+* milkbonestatus (edit: billiamive) screenname will now reveal the status of the project
+* About box
+* Signed off message is inserted into conversation
+* Removed autofocus nonsense
+* Added code to flash windows - doesn't seem to work
+* Word-wrap
+
+0.15 11-13-02
+----
+
+* Realtime updating of buddy list
+* Now displays an error box when AIM has a problem
+* Incoming and outgoing messages work with buddy list (I think)
+* Buddy list
+* New "Connecting to" text :)
+* Removed a very sneaky bug that logged users off if they hit Enter at the logon screen
+
+0.14 11-12-02
+----
+
+* New compiler
+* Screen name formatting works (e.g. Gato Gregorio instead of gatogregorio)
+* TIMING ISSUES FIXED!!!! - a tweak in MBLoop has eliminated the flicker - WOOT!
+* Can now cancel and then sign in again without lockup
+* First installer
+* Tested new logo
+* All windows use bone icon
+* Fixed a bug that might have appeared when two similar screen names sent IMs
+* Automated test and build scripts
+* Fixed illegal op problem
+* File | Close closes IM windows
+* Escape key closes IMs
+
+0.131	11-0-02
+----
+
+* Minor bugfixes
+
+0.13	11-08-02
+----
+
+* rewritten for use with Matthew Sachs' Net::OSCAR
+* allowed incoming IM's
+* allowed conversations
+* tweaked Net::OSCAR to remove dependence on Scalar::Util's bootstrap
+
+0.12	10-13-02
+----
+
+* fixed timing issues with 0.10
+* fixed minor interface bugs
+
+0.11
+----
+
+NONEXISTENT - version numbering error
+
+
+0.10	0-12-02
+----
+
+* connected to AIM with the TOC protocol (Aryeh Goldsmith's Net::AIM)

docs/WISHBONE.txt

@@ -0,0 +1,31 @@
+convos shouldnt start minimized
+warning for zips
+chat capabilities
+buddy icons
+direct connect
+custom keys
+sarcasm
+a real line in the away messages
+CLEANER CODE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+history (hitting up brings last message)
+switch screen name
+minimized convos
+secure convos (with fortis?)
+shoudl only flash if not active
+ctrl-r restores last window
+hooks - should flag for only one; should be able to add to top or bottom of queue
+Tk-Profile and Tk-Convo classes as spiffy-looking as Tk-BList and Tk-Logon
+multiple connections
+sorted buddy lists
+auto-splitting
+buddy conf files
+MUCH bettter configuration handling
+Refocuses convos windows that have been hidden when double-clicked in the buddy list
+emotes
+show current track
+buddy ordering
+chat rooms
+logon saver
+add buddy groups
+documentation
+file transfer

errlog.txt

@@ -0,0 +1,20 @@
+Your message to could not be sent for the following reason: PERLmonk86 is not logged in, so the attempted operation (sending an IM, getting user information) was unsuccessful
+Your message to could not be sent for the following reason: PERLmonk86 is not logged in, so the attempted operation (sending an IM, getting user information) was unsuccessful at plugins/Net-OSCAR/Net/OSCAR.pm line 1852
+	Net::OSCAR::do_callback('error','Net::OSCAR=HASH(0x889a074)','Net::OSCAR::Connection=HASH(0x88abd0c)',4,'Your message to could not be sent for the following reason: P...',0) called at plugins/Net-OSCAR/Net/OSCAR.pm line 1856
+	Net::OSCAR::callback_error('Net::OSCAR=HASH(0x889a074)','Net::OSCAR::Connection=HASH(0x88abd0c)',4,'Your message to could not be sent for the following reason: P...',0) called at plugins/Net-OSCAR/Net/OSCAR/Common.pm line 323
+	Net::OSCAR::Common::send_error('Net::OSCAR=HASH(0x889a074)','Net::OSCAR::Connection=HASH(0x88abd0c)',4,'Your message to could not be sent for the following reason: %...',0,'Net::OSCAR::Screenname=SCALAR(0x84c2cfc)') called at plugins/Net-OSCAR/Net/OSCAR/Callbacks.pm line 148
+	Net::OSCAR::Callbacks::process_snac('Net::OSCAR::Connection=HASH(0x88abd0c)','HASH(0x8a38294)') called at plugins/Net-OSCAR/Net/OSCAR/Connection.pm line 339
+	Net::OSCAR::Connection::process_one('Net::OSCAR::Connection=HASH(0x88abd0c)',1,0) called at plugins/Net-OSCAR/Net/OSCAR.pm line 459
+	Net::OSCAR::process_connections('Net::OSCAR=HASH(0x889a074)','SCALAR(0x84c2ccc)','SCALAR(0x8a2c234)','SCALAR(0x84c2cd8)') called at plugins/Net-OSCAR/Net/OSCAR.pm line 495
+	Net::OSCAR::do_one_loop('Net::OSCAR=HASH(0x889a074)') called at plugins/Net-OSCAR/Net-OSCAR.pl line 202
+	NetOSCAR::tick() called at /usr/lib/perl5/site_perl/5.8.0/i586-linux/Tk/After.pm line 83
+	eval {...} called at /usr/lib/perl5/site_perl/5.8.0/i586-linux/Tk/After.pm line 83
+	Tk::After::once('Tk::After=ARRAY(0x8a373c4)') called at plugins/Tk-GUI/Tk-GUI.pl line 61
+	eval {...} called at plugins/Tk-GUI/Tk-GUI.pl line 61
+	TkGUI::tick() called at lib/Milkbone/HookEntry.pm line 41
+	Milkbone::HookEntry::call('Milkbone::HookEntry=HASH(0x85dd320)') called at Milkbone.pm line 245
+	eval {...} called at Milkbone.pm line 245
+	Milkbone::hook('tick') called at Milkbone.pm line 288
+	Milkbone::MOSLoop() called at /home/bill/milkbone/mos.pl line 53
+	main::main() called at /home/bill/milkbone/mos.pl line 59
+

lib/Milkbone/AllHooks.pm

@@ -0,0 +1,15 @@
+# allows you to call hooks like subs - 
+# use base 'Milkbone::AllHooks';
+# hookname(@args);
+
+package Milkbone::AllHooks;
+
+use Milkbone;
+
+sub AUTOLOAD
+{
+    my $hook = $AUTOLOAD;
+    hook($hook, @_);
+}
+
+1;

lib/Milkbone/HookEntry.pm

@@ -0,0 +1,44 @@
+# -----------------------------------------------------------------------------
+# Author(s)	:	Bill Atkins
+# Title		:	MOS hook info
+# Date		:	1.22.02
+# Desc		:	tracks information about registered hooks
+# Notes		:	for more information see the plugin documentation
+# License	:	under the same terms as mos.pl
+# -----------------------------------------------------------------------------
+
+package Milkbone::HookEntry;
+
+use strict;
+use warnings;
+
+require Exporter;
+
+our @ISA = qw( Exporter );
+our @EXPORT = qw( );
+our @EXPORT_OK = qw( );
+
+sub new 
+{
+	my $self = {};
+	my $class = shift;
+	bless $self, $class;
+
+	my ($hook_name, $callback, $args, $package) = @_;
+
+	$self->{hook_name} = $hook_name;
+	$self->{callback} = $callback;
+	$self->{args} = $args;
+	$self->{package} = $package;
+
+	return $self;
+}
+
+sub call
+{
+	my ($self, %args) = @_;
+
+	$self->{callback}->(%args, %{$self->{args}});
+}
+
+1;

lines.pl

@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use File::Find;
+
+my $sum;
+
+sub process
+{
+    return if -d;
+    return unless /\.p(l|m)$/;
+    my ($res) = `wc -l $_`;
+    $sum += ($res =~ /(\d+)/)[0];
+}
+
+find(\&process, ".");
+print $sum . "\n"

makedist.pl

@@ -0,0 +1,3 @@
+#!/usr/bin/perl
+
+use Archive::Tar;

mb.conf

@@ -0,0 +1,10 @@
+# mb.conf - milkbone global configuration file
+
+Goodbye sorry, gotta, go
+Modules Tk-PluginsConf, Net-OSCAR, Tk-GUI, Tk-Logon, Tk-BList, Tk-Profile, Tk-File, Tk-About, Tk-AddBuddy, Tk-Convo
+Plugins Sound, XAMP, Templog, Monitor
+Port 5190
+HeavyLogging 0
+SoundsWhileAway 0
+Timeout 60
+TrayIcon 1

milkbone.nsi

@@ -0,0 +1,84 @@
+; Generated NSIS script file (generated by makensitemplate.phtml 0.21)
+; by 209.244.239.94 on Sep 20 02 @ 17:37
+
+; NOTE: this .NSI script is designed for NSIS v1.8+
+
+Name "milkbone"
+OutFile "milkbone-inst.exe"
+BrandingText " "
+CRCCheck on
+ShowInstDetails show
+DirShow show
+SetOverwrite on
+
+; Some default compiler settings (uncomment and change at will):
+; SetCompress auto ; (can be off or force)
+; SetDatablockOptimize on ; (can be off)
+; CRCCheck on ; (can be off)
+; AutoCloseWindow false ; (can be true for the window go away automatically at end)
+; ShowInstDetails hide ; (can be show to have them shown, or nevershow to disable)
+; SetDateSave off ; (can be on to have files restored to their orginal date)
+
+InstallDir "$PROGRAMFILES\milkbone"
+InstallDirRegKey HKEY_LOCAL_MACHINE "SOFTWARE\batkins\milkbone" ""
+DirShow show ; (make this hide to not let the user change it)
+DirText "Select the directory to install milkbone in:"
+
+Section "" ; (default section)
+SetOutPath "$INSTDIR"
+; add files / whatever that need to be installed here.
+WriteRegStr HKEY_LOCAL_MACHINE "SOFTWARE\batkins\milkbone" "" "$INSTDIR"
+WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\milkbone" "DisplayName" "milkbone (remove only)"
+WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\milkbone" "UninstallString" '"$INSTDIR\uninst.exe"'
+
+CreateDirectory "$INSTDIR\images"
+CreateDirectory "$INSTDIR\plugins"
+CreateDirectory "$INSTDIR\profiles"
+CreateDirectory "$INSTDIR\sounds"
+File milkbone.exe
+File mb.conf
+File perl58.dll
+
+SetOutPath $INSTDIR\images
+File images\*
+SetOutPath $INSTDIR\sounds
+File sounds\*
+SetOutPath $INSTDIR\plugins
+File  plugins\*.zip
+File  plugins\*.pl
+SetOutPath $INSTDIR
+
+SetShellVarContext all
+CreateDirectory "$SMPROGRAMS\milkbone"
+CreateShortCut "$SMPROGRAMS\milkbone\milkbone.lnk" "$INSTDIR\milkbone.exe"
+CreateShortCut "$DESKTOP\milkbone.lnk" "$INSTDIR\milkbone.exe"
+
+; write out uninstaller
+WriteUninstaller "$INSTDIR\uninst.exe"
+SectionEnd ; end of default section
+
+; begin uninstall settings/section
+UninstallText "This will uninstall milkbone from your system"
+
+Section Uninstall
+; add delete commands to delete whatever files/registry keys/etc you installed here.
+SetShellVarContext all
+
+Delete "$INSTDIR\milkbone.exe"
+Delete "$INSTDIR\images\*.*"
+RMDir "$INSTDIR\images"
+Delete "$INSTDIR\milkbone.exe"
+Delete "$INSTDIR\perl58.dll"
+Delete "$INSTDIR\uninst.exe"
+RMDir "$INSTDIR";
+
+Delete "$SMPROGRAMS\milkbone\milkbone.lnk"
+Delete "$DESKTOP\milkbone.lnk"
+RMDir "$SMPROGRAMS\milkbone"
+
+DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\myCompany\milkbone"
+DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\milkbone"
+RMDir "$INSTDIR"
+SectionEnd ; end of uninstall section
+
+; eof

mos.pl

@@ -0,0 +1,59 @@
+#!/usr/bin/perl
+
+# -----------------------------------------------------------------------------
+# Author(s)	:	Bill Atkins and Eric Thul
+# Title		:	MOS Core
+# Date		:	12.21.02
+# Desc		:	the core for Milkbone
+# QoTP		:	got milkbone?
+# Notes		:	for more information see the plugin documentation	
+# License	:	it's on our TODO list...
+# -----------------------------------------------------------------------------
+
+use 5.006;
+
+use warnings;
+use strict;
+
+use lib 'lib';
+use lib '.';
+
+use Tk;
+
+$SIG{CHLD} = 'IGNORE';
+
+use Milkbone;
+
+$| = 1;
+
+sub main
+{
+	Milkbone->init();
+
+	for(@ARGV)
+	{
+		if($_ eq '--load' or $_ eq '-l')
+		{
+			hook("load_options");
+			hook("load_plugins");
+			
+			exit;
+		}
+	}
+
+	hook("load_options");
+
+	require "plugins/Tk-Splash.pl" unless option("NoSplash");
+
+	hook("load_plugins");
+	hook("pre_mainloop");
+
+	hook("create_logon_prompt");
+
+	MOSLoop;
+
+	hook("post_mainloop");
+}
+
+# off it goes...
+main();

patch.nsi

@@ -0,0 +1,31 @@
+; Generated NSIS script file (generated by makensitemplate.phtml 0.21)
+; by 209.244.239.94 on Sep 20 02 @ 17:37
+
+; NOTE: this .NSI script is designed for NSIS v1.8+
+
+Name "milkbone patch"
+OutFile "milkbone-patch.exe"
+BrandingText " "
+CRCCheck on
+ShowInstDetails show
+DirShow show
+SetOverwrite on
+
+; Some default compiler settings (uncomment and change at will):
+; SetCompress auto ; (can be off or force)
+; SetDatablockOptimize on ; (can be off)
+; CRCCheck on ; (can be off)
+; AutoCloseWindow false ; (can be true for the window go away automatically at end)
+; ShowInstDetails hide ; (can be show to have them shown, or nevershow to disable)
+; SetDateSave off ; (can be on to have files restored to their orginal date)
+
+InstallDirRegKey HKEY_LOCAL_MACHINE "SOFTWARE\batkins\milkbone" ""
+DirShow hide ; (make this hide to not let the user change it)
+
+Section "" ; (default section)
+SetOutPath "$INSTDIR\plugins"
+; add files / whatever that need to be installed here.
+
+File plugins\Tk-Convo.zip
+
+SectionEnd

plugins/Bark.pl

@@ -0,0 +1,11 @@
+package Bark;
+
+use Milkbone;
+
+register_hook("msg_in", sub {
+    return if hook("protocol_away_status");
+    return if $ARGS{-msg} eq "BARK!";
+    hook("protocol_send_im", -dest => $ARGS{-user}, -msg => "BARK!");
+});
+
+1;

plugins/Forum-Check/Forum-Check.pl

@@ -0,0 +1,43 @@
+package ForumCheck;
+
+use Milkbone;
+use Tk;
+use strict;
+use HTTP::Lite;
+use Digest::MD5;
+use constant 'PAGE' => 'http://www.batkins.com/forum/?action=recent';
+
+my ($original, $latest);
+
+register_hook("pre_mainloop", sub {
+	my $http = new HTTP::Lite;
+	$http->request(PAGE);
+	$original = check($http->body());
+
+	my $mw = hook("tk_getmain");
+	$mw->repeat(10 * 1000, \&check);
+	check();
+});
+
+sub get_latest
+{
+	(split /<td colspan="3" bgcolor="#F8F8F8" valign="top" height="40" class="windowbg2">/, shift)[1];
+}
+
+sub check
+{
+	my $http = new HTTP::Lite;
+	$http->request(PAGE);
+	$latest = get_latest($http->body());
+
+	if($latest ne $original and $original ne ""){
+		hook("error", -short => "New posts in the BATKINS forum.");
+		$original = $latest;
+	}
+	elsif($original eq "")
+	{
+		$original = $latest;
+	}
+}
+
+1;

plugins/Forum-Check/Speak.pl

@@ -0,0 +1,20 @@
+package Speak;
+
+use Milkbone;
+use Win32::OLE qw( EVENTS );
+
+my $DirectSS = new Win32::OLE( "{EEE78591-FE22-11D0-8BEF-0060081841DE}" ) or die "$!";
+
+sub say
+{
+	my $say = shift;
+	$DirectSS->Speak($say);
+
+	while( $DirectSS->{Speaking} )
+	{
+			Win32::OLE->SpinMessageLoop();
+			Win32::Sleep( 100 );
+	}
+}
+
+register_hook("msg_in", sub { say("You have a message from $ARGS{-user}"); });

plugins/Log.pl

@@ -0,0 +1,59 @@
+package Log;
+
+use Milkbone;
+
+use strict;
+use warnings;
+
+my $dir = option("LogDir");
+
+register_hook("msg_in", \&on_msg_in);
+register_hook("protocol_send_im", \&on_protocol_send_im);
+register_hook("buddy_in", \&on_buddy_in);
+register_hook("buddy_info_changed", \&on_buddy_info_changed);
+register_hook("buddy_out", \&on_buddy_out);
+
+sub on_msg_in
+{
+	my ($day, $month, $year, $hour, $min, $sec) = (localtime)[4, 3, 5, 2, 1, 0];
+	$year += 1900;
+	$month++;
+
+	mkdir "$logdir/$ARS{-user}" unless -e "$logdir/$ARS{-user}/;
+	log_item("$logdir/$ARS{-user}/$day-$month-$year", $ARGS{-user} . " ($day-$month-$year $hour:$min:$sec) " .
+		": $ARGS{-msg} \n");
+}
+
+sub on_buddy_in
+{
+}
+
+sub on_buddy_info_changed
+{
+}
+
+sub on_buddy_out
+{
+}
+
+sub on_protocol_send_im
+{
+	my ($day, $month, $year, $hour, $min, $sec) = (localtime)[4, 3, 5, 2, 1, 0];
+	$year += 1900;
+	$month++;
+
+	mkdir "$logdir/$ARS{-user}" unless -e "$logdir/$ARS{-user}/;
+	log_item("$logdir/$ARS{-user}/$day-$month-$year", data("me") . " ($day-$month-$year $hour:$min:$sec) " .
+		": $ARGS{-msg} \n");
+}
+
+sub log_item
+{
+	my ($file, $text) = @_;
+
+	open(LOG, ">>$file");
+	print LOG $text;
+	close(LOG);
+}
+
+1;

plugins/Milkbot-Music.pl

@@ -0,0 +1,281 @@
+#!usr/bin/perl
+
+#########################################################################
+#	Author	Daniel Chokola						#
+#	Title	Milkbot							#
+#	Date	4/16/2003						#
+#	Desc	Controls Winamp or XMMS over Milkbone via Milkbot	#
+#########################################################################
+
+package MilkbotMusic;
+
+use strict;
+no strict 'refs';
+use warnings;
+
+use Milkbone;
+
+
+if($^O =~ /linux/) {
+	eval "use Xmms::Remote";
+}
+elsif($^O =~ /Win32/) {
+	eval "use Winamp::Control";
+}
+
+my ($amp, $os, %commands);
+
+register_hook("milkbot_get_commands", \&init);
+
+sub init {
+	my $cmd = '';
+
+	if($^O =~ /Win32/i) {
+		$os = 'win32';
+	}
+	elsif($^O =~ /linux/) {
+		$os = 'linux';
+	}
+
+	if($^O =~ /Win32/) {
+		$amp = Winamp::Control->new(host => 'localhost', port => 4800, passwd => 'pass');
+	}
+	elsif($^O =~ /linux/) {
+		$amp = new Xmms::Remote ();
+	}
+
+        $commands{'.list'}[0]   = "list_$os";
+        $commands{'.list'}[1]   = '.list [num]--makes a list of songs num long based on the song currently playing, 5 by default';
+        $commands{'.next'}[0]   = "next_$os";
+        $commands{'.next'}[1]   = '.next--jumps ahead one track';
+        $commands{'.paus'}[0]   = "paus_$os";
+        $commands{'.paus'}[1]   = '.paus--pauses the current song';
+        $commands{'.play'}[0]   = "play_$os";
+        $commands{'.play'}[1]   = '.play--plays the current song';
+        $commands{'.prev'}[0]   = "prev_$os";
+        $commands{'.prev'}[1]   = '.prev--jumps back one track';
+        $commands{'.rand'}[0]   = "rand_$os";
+        $commands{'.rand'}[1]   = '.rand--randomly selects a song';
+        $commands{'.rpt'}[0]    = "rpt_$os";
+        $commands{'.rpt'}[1]    = '.rpt [on|off]--toggles the repeat status (on or off)';
+        $commands{'.shuf'}[0]   = "shuf_$os";
+        $commands{'.shuf'}[1]   = '.shuf [on|off]--toggles the shuffle status (on or off)';
+        $commands{'.song'}[0]   = "song_$os";
+        $commands{'.song'}[1]   = '.song--displays the current song';
+        $commands{'.stop'}[0]   = "stop_$os";
+        $commands{'.stop'}[1]   = '.stop--stops playback';
+        $commands{'.vis'}[0]    = "vis_$os";
+        $commands{'.vis'}[1]    = '.vis--turns on the visualization';
+
+	for(keys(%commands)) {
+		hook("milkbot_set_command", -name => $_, -desc => $commands{$_}[1]);
+	}
+	register_hook("milkbot_command", sub { $cmd = $ARGS{-cmd};
+		register_hook("milkbot_command_$cmd", sub {
+			$commands{$cmd}[0]->($ARGS{-user}, $ARGS{-msg});
+			deregister_hook("milkbot_command_$cmd") if $cmd;
+		});
+	});
+}
+
+sub send_im {
+	my ($to, $msg, $away) = @_;
+	$away = 0;
+	print $msg, $to;
+	hook("protocol_send_im", -dest => $to, -msg => $msg, -away => $away);
+}
+
+sub list_linux {
+	my ($from, $msg) = @_;
+	my @list;
+
+	return if($amp->get_playlist_length < 1);
+	if($msg) {
+		for(my $i = 0; $i < $msg; $i++) {
+			$list[$i] = $amp->get_playlist_title($amp->get_playlist_pos + $i - (($msg - 1) / 2));
+		}
+	}
+	if(@list) {
+		$list[$msg / 2] = '<b>' . $list[$msg / 2] . '</b>';
+		send_im($_[0], join("\n", @list), 0);
+	}
+	else {
+		for(my $i = 0; $i < 5; $i++) {
+			$list[$i] = $amp->get_playlist_title($amp->get_playlist_pos + $i - 2);
+		}
+		$list[2] = '<b>' . $list[2] . '</b>';
+		send_im($_[0], join("\n", @list), 0);
+	}
+}
+
+sub next_linux {
+	$amp->playlist_next;
+	sleep(1.1);
+	song_linux(@_);
+}
+
+sub paus_linux {
+	$amp->pause;
+	send_im($_[0], 'Pause <b>toggled</b>.', 0);
+}
+
+sub play_linux {
+	$amp->play;
+	sleep(1.1);
+	song_linux(@_);
+}
+
+sub prev_linux {
+	$amp->playlist_prev;
+	sleep(1.1);
+	song_linux(@_);
+}
+
+sub rand_linux {
+	$amp->playlist_next;	# a simple, but inelegant solution to the
+	$amp->toggle_shuffle;	# problem of randomizing tracks in xmms:
+	$amp->playlist_next;	# do it twice!
+	$amp->toggle_shuffle;
+	sleep(1.1);
+	song_linux(@_);
+}
+
+sub rpt_linux {
+	$amp->toggle_repeat();
+	send_im($_[0], 'Repeat <b>toggled</b>.', 0);
+}
+
+sub shuf_linux {
+	$amp->toggle_shuffle();
+	send_im($_[0], 'Shuffle <b>toggled</b>.', 0);
+}
+
+sub stop_linux {
+	$amp->stop;
+	send_im($_[0], '<b>Stopped</b>', 0);
+}
+
+sub song_linux {
+	my $song = $amp->get_playlist_title($amp->get_playlist_pos());
+	if($song) {
+		send_im($_[0], "Now playing:\n<b>$song</b>", 0);
+	}
+	else {
+		send_im($_[0], '<b>Stopped</b>.', 0);
+	}
+}
+
+sub vis_linux {
+	send_im($_[0], 'Command <b>failed</b>.', 0);
+}
+
+sub list_win32 {
+	my ($from, $msg) = @_;
+	my @list;
+
+	return if($amp->get_playlist_length < 1);
+	if($msg) {
+		for(my $i = 0; $i < $msg; $i++) {
+			$list[$i] = $amp->getplaylisttitle($amp->getlistpos + $i - (($msg - 1) / 2));
+		}
+	}
+	if(@list) {
+		$list[$msg / 2] = '<b>' . $list[$msg / 2] . '</b>';
+		send_im($_[0], join("\n", @list), 0);
+	}
+	else {
+		for(my $i = 0; $i < 5; $i++) {
+			$list[$i] = $amp->getplaylisttitle($amp->getplaylistpos + $i - 2);
+		}
+		$list[2] = '<b>' . $list[2] . '</b>';
+		send_im($_[0], join("\n", @list), 0);
+	}
+}
+
+sub next_win32 {
+	$amp->next;
+	song_win32(@_);
+}
+
+sub paus_win32 {
+	$amp->pause;
+	song_win32(@_) if $amp->isplaying;
+}
+
+sub play_win32 {
+	$amp->play;
+	song_win32(@_);
+}
+
+sub prev_win32 {
+	$amp->prev;
+	sleep(1.1);
+	song_win32(@_);
+}
+
+sub rand_win32 {
+	my $status;
+	$status = $amp->shuffle_status;
+	$amp->shuffle(a => 1);
+	$amp->next;
+	$amp->shuffle(a => 0) if(!$status);
+	sleep(1.1);
+	song_win32(@_);
+}
+
+sub rpt_win32 {
+	my ($from, $msg) = @_;
+
+	$msg =~ tr/A-Z/a-z/ if $msg;
+	if($msg =~ /on/) {
+		$amp->repeat(1);
+		send_im($_[0], 'Repeat <b>on</b>.', 0);
+	}
+	elsif($msg =~ /off/) {
+		$amp->repeat(0);
+		send_im($_[0], 'Repeat <b>off</b>.', 0);
+	}
+	else {
+		send_im($_[0], $commands{'.rpt'}[1], 0);
+	}
+}
+
+sub shuf_win32 {
+	my $msg = $_[1];
+
+	$msg =~ tr/A-Z/a-z/ if $msg;
+	if($msg =~ /on/) {
+		$amp->shuffle(a => 1);
+		send_im($_[0], 'Shuffle <b>on</b>.', 0);
+	}
+	elsif($msg =~ /off/) {
+		$amp->shuffle(a => 0);
+		send_im($_[0], 'Shuffle <b>off</b>.', 0);
+	}
+	else {
+		send_im($_[0], $commands{'.shuf'}[1], 0);
+	}
+}
+
+sub stop_win32 {
+	$amp->fadeoutandstop;
+	send_im($_[0], '<b>Stopped</b>.', 0);
+}
+
+sub song_win32 {
+	my $song;
+
+	if($amp->isplaying) {
+		$song = $amp->getcurrenttitle;
+		send_im($_[0], "Now playing:\n<b>$song</b>", 0)
+	}
+	else {
+		send_im($_[0], '<b>Stopped</b>.', 0);
+	}
+}
+
+sub vis_win32 {
+	$amp->exec_visual();
+	send_im($_[0], 'Visualization <b>toggled</b>.', 0);
+}
+1;

plugins/Milkbot.pl

@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+#########################################################################
+#	Author	Daniel Chokola						#
+#	Title	Milkbot							#
+#	Date	4/5/2003						#
+#	Desc	Controls a remote computer via milkbone			#
+#########################################################################
+
+package Milkbot;
+
+use strict;
+use warnings;
+
+use Milkbone;
+
+my $me;
+my %commands;
+
+register_hook("signed_in", \&init);
+
+sub init {
+	hook("protocol_get_realname", -user => $me = $ARGS{-me});
+
+	register_hook("milkbot_set_command", sub {
+		$commands{$ARGS{-name}} = $ARGS{-desc};
+	});
+	hook("milkbot_get_commands");
+	register_hook("msg_in", \&on_im);
+}
+
+sub on_im {
+	my ($from, $raw_msg, $away) = @ARGS{-user, -msg, -away};
+	my ($cmd, $msg);
+	$raw_msg =~ s/<.+?>//g;
+	($cmd, $msg) = $raw_msg =~ m/^(.*?)\s+(.*)/;
+	($cmd) = $raw_msg =~ m/^(.*)/ unless $cmd;
+	$cmd =~ tr/A-Z/a-z/;
+	if($commands{$cmd}){
+		hook("milkbot_command", -cmd => $cmd);
+		hook("milkbot_command_$cmd", -user => $from, -msg => $msg);
+	}
+	elsif($cmd =~ /\.help/) {
+		help($from, $msg);
+	}
+}
+
+sub send_im {
+	my ($to, $msg, $away) = @_;
+	hook("protocol_send_im", -dest => $to, -msg => $msg, -away => $away);
+}
+
+sub help {
+	my ($from, $msg) = @_;
+	my $cmds = '';
+
+	for(keys(%commands)) {
+		$cmds = "$cmds$_\t";
+	}
+
+	if(!$msg || !$commands{$msg}) {
+	send_im($from, "Hello, I am $me. I am a bot that can control ".
+		"this computer over the Milkbone IM network. Currently, ".
+		"accepted commands are:\n$cmds\nYou can also type help ".
+		"[command] to get more detailed info on that command.", 0);
+	}
+	else {
+		send_im($from, $commands{$msg}, 0);
+	}
+}
+
+1;

plugins/Monitor.pl

@@ -0,0 +1,35 @@
+use Milkbone;
+use Net::SMTP;
+
+use strict;
+use warnings;
+
+sub sendmail
+{
+    print "sending message";;
+    my ($sub, $text, $user) = @_;
+    my $smtp = Net::SMTP->new('smtpauth.earthlink.net', 
+                              Hello => 'milkbone.org', Debug => 1);
+
+    $smtp->auth('batkins86@earthlink.net', 'superfly');
+    $smtp->mail("$user\@milkbone.org");
+    $smtp->to('savannah@batkins.com');
+
+    $smtp->data();
+    $smtp->datasend("To: \n");
+    $smtp->datasend("From: Milkbone Monitor <$user\@milkbone.org>\n");
+    $smtp->datasend("Subject: $sub \n");
+    $smtp->datasend("\n");
+    $smtp->datasend($text);
+    $smtp->dataend();
+
+    $smtp->quit;
+}
+
+register_hook("msg_in", sub {
+        print "msg received";
+        return unless hook("protocol_away_status");
+        sendmail('Message Received', "Received the following message from $ARGS{-user}:\n\n$ARGS{-msg}", $ARGS{-user});
+});
+
+1;

plugins/Net-OSCAR/Net-OSCAR.pl

@@ -0,0 +1,283 @@
+# -----------------------------------------------------------------------------
+# Author(s)	:	Bill Atkins
+# Title		:	Net-OSCAR initialization file
+# Date		:	12.21.02
+# Desc		:	initializes the Net-OSCAR plugin
+# Notes		:	for more information see the plugin documentation
+# License	:	it's on our TODO list...
+# -----------------------------------------------------------------------------
+
+package NetOSCAR;	
+
+use Net::OSCAR qw(:all);
+use Milkbone;
+use Carp qw(longmess);
+
+use strict;
+use warnings;
+
+my $signed_in = 0;
+my $tick_count = 0;
+my $i = 0;
+my $should_die = 0;
+my $is_away = 0;
+my ($oscar, $away, $prof, $away_templ, $prof_templ, $user_prof, $user, $password, $waiting);
+my (%away_sent, %prof_names, %away_names, %buddies, %chats);
+
+my $tick_interval = 1;
+
+register_hook("protocol_add_buddy",		sub { $oscar->add_buddy($ARGS{-group}, $ARGS{-buddy}); } );
+register_hook("protocol_add_buddy_group",		sub { $oscar->add_buddy($ARGS{-group}); } );
+register_hook("protocol_away_status",	sub { $is_away; } );
+register_hook("protocol_chat_accept",		sub { $oscar->chat_accept($chats{$ARGS{-chat}}) });
+register_hook("protocol_chat_decline",		sub { $oscar->chat_decline($chats{$ARGS{-chat}}); undef $chats{$ARGS{-chat}}; });
+register_hook("protocol_chat_invite",		sub { $chats{$ARGS{-chat}}->invite(@ARGS{-user, -msg}) });
+register_hook("protocol_chat_join",		sub { $oscar->chat_join($ARGS{-chat}) });
+register_hook("protocol_chat_part",		sub { $chats{$ARGS{-chat}}->part; });
+register_hook("protocol_chat_send",		sub { $chats{$ARGS{-chat}}->chat_send($ARGS{-msg}, !($ARGS{-reflect} or 1)) });
+register_hook("protocol_commit_blist",	sub { $oscar->commit_buddylist; } );
+register_hook("protocol_commit_info", \&commit_info);
+register_hook("protocol_get_away",		sub { $oscar->{away}; } );
+register_hook("protocol_get_groups",	sub { [ $oscar->groups ]; } );
+register_hook("protocol_get_prof",		sub { $oscar->{profile} } );
+register_hook("protocol_get_realname",	\&get_realname );
+register_hook("protocol_go_away",		sub { $is_away = 1; $oscar->set_away($away) if $is_away; } );
+register_hook("protocol_idle_since",	sub { $oscar->buddy($ARGS{-who})->{idle}; } );
+register_hook("protocol_is_away",		sub { return $oscar->buddy($ARGS{-user})->{away}; } );
+register_hook("protocol_is_mobile",		sub { return $oscar->buddy($ARGS{-user})->{mobile}; } );
+register_hook("protocol_is_on",			sub { $oscar->buddy($ARGS{-who})->{online} } );
+register_hook("protocol_mod_away",		\&mod_away );
+register_hook("protocol_mod_prof",		\&mod_prof );
+register_hook("protocol_on_since",		sub { $oscar->buddy($ARGS{-who})->{onsince}; } );
+register_hook("protocol_remove_buddy",	sub { $oscar->remove_buddy($ARGS{-group}, $oscar->buddy($ARGS{-buddy})->{screenname}); } );
+register_hook("protocol_request_info",	sub { request_info($ARGS{-user}); });
+register_hook("protocol_request_away",	sub { request_away($ARGS{-user}); });
+register_hook("protocol_return",		sub { $oscar->set_away(''); %away_sent = (); $is_away = 0; } );
+register_hook("protocol_send_im",		\&send_im );
+register_hook("protocol_set_away",		\&set_away );
+register_hook("protocol_set_typing_status",		sub { $oscar->set_typing($ARGS{-user}, $ARGS{-status}) });
+register_hook("protocol_set_comment",		sub { $oscar->set_buddy_comment(@ARGS{-group, -user, -comment}); $oscar->commit_buddylist; });
+register_hook("protocol_set_prof",		\&set_prof );
+register_hook("protocol_signon",		\&signon);
+register_hook("protocol_signed_in",		sub { $signed_in; } );
+register_hook("protocol_signoff",		sub { $oscar->signoff; } );
+
+register_hook("request_mod", sub{
+		hook("protocol_mod_away", -name => "%v", -value => $Milkbone::VERSION);
+		hook("protocol_mod_prof", -name => "%v", -value => $Milkbone::VERSION);
+	} );
+
+
+
+sub signon
+{
+	$oscar = new Net::OSCAR;
+	$oscar->timeout(0.00001);
+	$signed_in = 0;
+	set_interval(0);
+	$oscar->loglevel(OSCAR_DBG_PACKETS) if option("HeavyLogging");
+
+	$oscar->set_callback_error(
+	sub {
+		my (undef, undef, $err, $desc, $fatal)= @_;
+		hook("error", -short => $desc, -long => longmess($desc), -fatal => $fatal);
+                $should_die = 1 if $fatal;
+       	} );
+
+	$oscar->set_callback_buddy_in(
+	sub {
+		if(!$buddies{$_[1]})
+		{
+			hook("buddy_in", -buddy => $_[1], -group => $_[2]);
+			$buddies{$_[1]} = 1;
+		}
+		else
+		{
+			hook("buddy_info_changed", -buddy => $_[1], -group => $_[2]);
+		}
+	} );
+
+	$oscar->set_callback_buddy_out(
+	sub {
+		hook("buddy_out", -buddy => $_[1], -group => $_[2]); 
+		$buddies{$_[1]} = 0;
+	} );
+
+	$oscar->set_callback_im_in(
+	sub {
+		hook("msg_in", -user => $_[1], -msg => $_[2], -away => $_[3]) if $_[1]; 
+		hook("msg_in_$_[1]", -user => $_[1], -msg => $_[2], -away => $_[3]);
+		send_away($_[1]) if $is_away;
+	} );
+
+	$oscar->set_callback_typing_status(
+	sub {
+		# hook("protocol_typing_status_changed", -user => $_[1], -status => $_[2]); 
+		hook("protocol_typing_status_changed_$_[1]", -status => $_[2]);
+	} );
+
+	$oscar->set_callback_signon_done(
+	sub {
+
+		hook("signed_in", -me => $user);
+
+		$signed_in = 1;
+	} );
+
+	$oscar->set_callback_rate_alert(
+	sub {
+		hook("error", 
+			-short => "You've exceeded one of AOL's rate limits.  Profiles and outgoing IM's may not work for a few seconds")
+			if $_[1] == RATE_LIMIT;
+		hook("rate_alert") if $_[1] == RATE_LIMIT;
+	} );
+
+	$oscar->set_callback_buddy_info(
+	sub {
+		my $prof = $_[2]->{profile};
+		$prof = "Sorry, Milkbone users cannot see AOL profiles." if $_[2]->{aol} && !$prof;
+		$_[1] =~ s/ //g;
+		$_[1] =~ tr/A-Z/a-z/;
+		hook("protocol_info_received_$_[1]", -profile => $prof, -away => $_[2]->{awaymsg}); 
+		if($_[2]->{awaymsg})
+		{
+			$waiting = 0;
+		}
+		elsif(!$_[2]->{away})
+		{
+			$waiting = 0;
+		}
+	} );
+
+	$oscar->set_callback_chat_im_in(
+	sub {
+		hook("protocol_chat_msg_in", -user => $_[1], -msg => $_[3], -chat => $_[2]->name);
+		hook("protocol_chat_msg_in_" . $_[2]->name, -user => $_[1], -msg => $_[3]);
+	} );
+
+	$oscar->set_callback_chat_invite(
+	sub {
+		hook("protocol_chat_invited", -user => $_[1], -msg => $_[2], -url => $_[4]);
+		$chats{$_[3]->{name}} = $_[3];
+	} );
+
+	$oscar->set_callback_chat_joined(
+	sub {
+		hook("protocol_chat_joined");
+	} );
+
+	$oscar->set_callback_chat_closed(
+	sub {
+		hook("protocol_chat_closed");
+	} );
+
+	$oscar->set_callback_chat_buddy_in(
+	sub {
+		hook("protocol_chat_buddy_in", -user => $_[1], -chat => $_[2]->name);
+		print $oscar->buddy($_[1])->{comment};
+	} );
+
+	$oscar->set_callback_chat_buddy_out(
+	sub {
+		hook("protocol_chat_buddy_out", -user => $_[1], -chat => $_[2]->name);
+	} );
+
+	hook("tk_getmain")->after(30, \&tick);
+
+        $should_die = 0;
+
+	$oscar->signon(screenname => $ARGS{-user}, password => $ARGS{-pass}, port => option("Port"));
+	($user, $password) = @ARGS{-user, -pass};
+}
+
+sub send_im
+{
+	$oscar->send_im(@ARGS{-dest, -msg, -away});
+	hook("msg_sent_$ARGS{-dest}", -msg => $ARGS{-msg}, -away => $ARGS{-away});
+}
+
+sub tick
+{
+	return unless $oscar;
+	$oscar->do_one_loop;
+	hook("tk_getmain")->after(30, \&tick) unless $should_die;
+}
+
+sub request_info
+{
+	my ($other_user) = @_;
+
+	$oscar->get_info($other_user);
+	$waiting = 1;
+}
+
+sub request_away
+{
+	my ($other_user) = @_;
+
+	$oscar->get_away($other_user);
+	$waiting = 1;
+}
+
+sub send_away
+{
+	my $user = shift;
+        my $timeout = option("AwayTimeout") || 60;
+	$away_sent{$user} ||= 1;
+	if (time - $away_sent{$user} > option("AwayTimeout"))
+	{
+		$oscar->send_im($user, $away, 1);
+		$away_sent{$user} = time;
+	}
+}
+
+sub set_away
+{
+	$away_templ = $ARGS{-data};
+	$away = $away_templ;
+
+	hook("request_mod");
+	$away =~ s/\n/<br>/g;
+	$oscar->set_away($away) if $is_away;
+}
+
+sub set_prof
+{
+	$prof_templ = $ARGS{-data};
+	$prof = $prof_templ;
+
+	hook("request_mod");
+	$prof =~ s/\n/<br>/g;
+	$oscar->set_info($prof);
+}
+
+sub mod_away
+{
+	$away_names{$ARGS{-name}} = $ARGS{-value};
+	$away = $away_templ;
+
+	$away =~ s/$_/$away_names{$_}/g for keys(%away_names);
+}
+
+sub mod_prof
+{
+	$prof_names{$ARGS{-name}} = $ARGS{-value};
+	$prof = $prof_templ;
+
+	$prof =~ s/$_/$prof_names{$_}/g for keys(%prof_names);
+}
+
+sub get_realname
+{
+ 	return $oscar->buddy($ARGS{-user})->{screenname} 
+	if defined($oscar->buddy($ARGS{-user})) and $oscar->buddy($ARGS{-user}) ne "";
+	return $ARGS{-user};
+}
+
+sub commit_info
+{
+    $oscar->set_away($away) if $is_away; 
+    $oscar->set_info($prof);
+}
+
+1;

plugins/Net-OSCAR/Net/OSCAR/Buddylist.pm

@@ -0,0 +1,103 @@
+package Net::OSCAR::Buddylist;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw($VERSION);
+
+use Carp;
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::Screenname;
+use Net::OSCAR::OldPerl;
+
+sub new {
+	my $pkg = shift;
+	$pkg->{nonorm} = 0;
+	$pkg->{nonorm} = shift if @_;
+	$pkg->TIEHASH(@_);
+}
+
+sub setorder {
+	my $self = shift;
+
+	# Anything not specified gets shoved at the end
+	my @end = grep { my $inbud = $_; not grep { $_ eq $inbud } @_ } @{$self->{ORDERFORM}};
+
+	@{$self->{ORDERFORM}} = @_;
+	push @{$self->{ORDERFORM}}, @end;
+}
+
+sub TIEHASH {
+	my $class = shift;
+	my $self = { DATA => {}, ORDERFORM => [], CURRKEY => -1};
+	return bless $self, $class;
+}
+
+sub FETCH {
+	my($self, $key) = @_;
+	confess "\$self was undefined!" unless defined($self);
+	return undef unless $key;
+	$self->{DATA}->{$self->{nonorm} ? $key : normalize($key)};
+}
+
+sub STORE {
+	my($self, $key, $value) = @_;
+	if(exists $self->{DATA}->{$self->{nonorm} ? $key : normalize($key)}) {
+		my $foo = 0;
+		for(my $i = 0; $i < scalar @{$self->{ORDERFORM}}; $i++) {
+			next unless $key eq $self->{ORDERFORM}->[$i];
+			$foo = 1;
+			$self->{ORDERFORM}->[$i] = $self->{nonorm} ? $key : Net::OSCAR::Screenname->new($key);
+			last;
+		}
+	} else {
+		push @{$self->{ORDERFORM}}, $self->{nonorm} ? $key : Net::OSCAR::Screenname->new($key);
+	}
+	$self->{DATA}->{$self->{nonorm} ? $key : normalize($key)} = $value;
+}
+
+sub DELETE {
+	my($self, $key) = @_;
+	my $retval = delete $self->{DATA}->{$self->{nonorm} ? $key : normalize($key)};
+	my $foo = 0;
+	for(my $i = 0; $i < scalar @{$self->{ORDERFORM}}; $i++) {
+		next unless $key eq $self->{ORDERFORM}->[$i];
+		$foo = 1;
+		splice(@{$self->{ORDERFORM}}, $i, 1);
+		last;
+	}
+	return $retval;
+}
+
+sub CLEAR {
+	my $self = shift;
+	$self->{DATA} = {};
+	$self->{ORDERFORM} = [];
+	$self->{CURRKEY} = -1;
+	return $self;
+}
+
+sub EXISTS {
+	my($self, $key) = @_;
+	return exists $self->{DATA}->{$self->{nonorm} ? $key : normalize($key)};
+}
+
+sub FIRSTKEY {
+	$_[0]->{CURRKEY} = -1;
+	goto &NEXTKEY;
+}
+
+sub NEXTKEY {
+	my ($self, $currkey) = @_;
+	$currkey = ++$self->{CURRKEY};
+
+	if($currkey >= scalar @{$self->{ORDERFORM}}) {
+		return wantarray ? () : undef;
+	} else {
+		my $key = $self->{ORDERFORM}->[$currkey];
+		my $normalkey = $self->{nonorm} ? $key : normalize($key);
+		return wantarray ? ($key, $self->{DATA}->{$normalkey}) : $key;
+	}
+}
+
+1;

plugins/Net-OSCAR/Net/OSCAR/Callbacks.pm

@@ -0,0 +1,526 @@
+package Net::OSCAR::Callbacks;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::TLV;
+use Net::OSCAR::Buddylist;
+use Net::OSCAR::_BLInternal;
+use Net::OSCAR::OldPerl;
+
+sub capabilities() {
+	my $caps;
+
+	#AIM_CAPS_CHAT
+	$caps .= pack("C*", map{hex($_)} split(/[ \t\n]+/, "0x74 0x8F 0x24 0x20 0x62 0x87 0x11 0xD1 0x82 0x22 0x44 0x45 0x53 0x54 0x00 0x00"));
+
+	return $caps;
+}
+
+sub process_snac($$) {
+	my($connection, $snac) = @_;
+	my($conntype, $family, $subtype, $data, $reqid) = ($connection->{conntype}, $snac->{family}, $snac->{subtype}, $snac->{data}, $snac->{reqid});
+	my $reqdata = delete $connection->{reqdata}->[$family]->{pack("N", $reqid)};
+	my $session = $connection->{session};
+
+	my %tlv;
+
+	tie %tlv, "Net::OSCAR::TLV";
+
+	$connection->log_printf(OSCAR_DBG_DEBUG, "Got SNAC 0x%04X/0x%04X", $snac->{family}, $snac->{subtype});
+
+	if($conntype == CONNTYPE_LOGIN and $family == 0x17 and $subtype == 0x7) {
+		$connection->log_print(OSCAR_DBG_SIGNON, "Got authentication key.");
+		my($key) = unpack("n/a*", $data);
+
+		if(defined($connection->{auth})) {
+			$connection->log_print(OSCAR_DBG_SIGNON, "Sending password.");
+
+			%tlv = signon_tlv($session, $connection->{auth}, $key);
+
+			$connection->snac_put(family => 0x17, subtype => 0x2, data => tlv_encode(\%tlv));
+		} else {
+			$connection->log_print(OSCAR_DBG_SIGNON, "Giving client authentication challenge.");
+			$session->callback_auth_challenge($key, "AOL Instant Messenger (SM)");
+		}
+	} elsif($conntype == CONNTYPE_LOGIN and $family == 0x17 and $subtype == 0x3) {
+		$connection->log_print(OSCAR_DBG_SIGNON, "Got authorization response.");
+
+		%tlv = %{tlv_decode($data)};
+		if($tlv{0x08}) {
+			my($error) = unpack("n", $tlv{0x08});
+			$session->crapout($connection, "Invalid screenname.") if $error == 0x01;
+			$session->crapout($connection, "Invalid password.") if $error == 0x05;
+			$session->crapout($connection, "You've been connecting too frequently.") if $error == 0x18;
+			my($errstr) = ((ERRORS)[$error]) || "unknown error";
+			$errstr .= " ($tlv{0x04})" if $tlv{0x04};
+			$session->crapout($connection, $errstr, $error);
+			return 0;
+		} else {
+			$connection->log_print(OSCAR_DBG_SIGNON, "Login OK - connecting to BOS");
+			$connection->{closing} = 1;
+			$connection->disconnect;
+			$session->{screenname} = $tlv{0x01};
+			$session->{email} = $tlv{0x11};
+			$session->addconn(
+				$tlv{0x6},
+				CONNTYPE_BOS,
+				"BOS",
+				$tlv{0x05}
+			);
+		}
+	} elsif($family == 0x1 and $subtype == 0x7) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got Rate Info Resp.");
+		$connection->log_print(OSCAR_DBG_NOTICE, "Sending Rate Ack.");
+		$connection->snac_put(family => 0x01, subtype => 0x08, data => pack("nnnnn", 1, 2, 3, 4, 5));
+		$connection->log_print(OSCAR_DBG_NOTICE, "BOS handshake complete!");
+
+		if($conntype == CONNTYPE_BOS) {
+			$connection->log_print(OSCAR_DBG_SIGNON, "Signon BOS handshake complete!");
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting personal info.");
+			$connection->snac_put(family => 0x1, subtype => 0xE);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Doing buddylist unknown 0x2.");
+			$connection->snac_put(family => 0x13, subtype => 0x2);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting buddylist.");
+			$connection->snac_put(family => 0x13, subtype => 0x5, data => chr(0)x6);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting locate rights.");
+			$connection->snac_put(family => 0x2, subtype => 0x2);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting buddy rights");
+			$connection->snac_put(family => 0x3, subtype => 0x2);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting ICBM param info.");
+			$connection->snac_put(family => 0x4, subtype => 0x4);
+
+			$connection->log_print(OSCAR_DBG_DEBUG, "Requesting BOS rights.");
+			$connection->snac_put(family => 0x9, subtype => 0x2);
+		} elsif($conntype == CONNTYPE_CHATNAV) {
+			$connection->ready();
+			$session->{chatnav} = $connection;
+
+			if($session->{chatnav_queue}) {
+				foreach my $snac(@{$session->{chatnav_queue}}) {
+					$connection->log_print(OSCAR_DBG_DEBUG, "Putting SNAC.");
+					$connection->snac_put(%$snac);
+				}
+			}
+			delete $session->{chatnav_queue};
+
+		} elsif($conntype == CONNTYPE_ADMIN) {
+			$session->{admin} = $connection;
+			if($session->{admin_queue}) {
+				foreach my $snac(@{$session->{admin_queue}}) {
+					$connection->log_print(OSCAR_DBG_DEBUG, "Putting SNAC.");
+					$connection->snac_put(%$snac);
+				}
+			}
+
+			$connection->ready();
+			delete $session->{admin_queue};
+		} elsif($conntype == CONNTYPE_CHAT) {
+			$connection->ready();
+
+			$session->callback_chat_joined($connection->name, $connection) unless $connection->{sent_joined}++;
+		}
+	} elsif($subtype == 0x1) {
+		$subtype = $reqid >> 16;
+		my $error = "";
+		if($family == 0x4) {
+			$error = "Your message to could not be sent for the following reason: ";
+			delete $session->{cookies}->{$reqid};
+		} else {
+			$error = "Error in ".$connection->{description}.": ";
+		}
+		my($errno) = unpack("n", substr($data, 0, 2, ""));
+		$session->log_printf(OSCAR_DBG_DEBUG, "Got error %d on req 0x%04X/0x%08X.", $errno, $family, $reqid);
+		return if $errno == 0;
+		my $tlv = tlv_decode($data) if $data;
+		$error .= (ERRORS)[$errno] || "unknown error";
+		$error .= " (".$tlv->{4}.")." if $tlv and $tlv->{4};
+		send_error($session, $connection, $errno, $error, 0, $reqdata);
+	} elsif($family == 0x1 and $subtype == 0xf) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got user information response.");
+	} elsif($family == 0x9 and $subtype == 0x3) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got BOS rights.");
+	} elsif($family == 0x3 and $subtype == 0x3) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got buddylist rights.");
+	} elsif($family == 0x2 and $subtype == 0x3) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got locate rights.");
+	} elsif($family == 0x4 and $subtype == 0x5) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got ICBM parameters - warheads armed.");
+	} elsif($family == 0x3 and $subtype == 0xB) {
+		my $buddy = $session->extract_userinfo($data);
+		my $screenname = $buddy->{screenname};
+		$connection->log_print(OSCAR_DBG_DEBUG, "Incoming bogey - er, I mean buddy - $screenname");
+
+		my $group = $session->findbuddy($screenname);
+		return unless $group; # Without this, remove_buddy screws things up until signoff/signon
+		$buddy->{buddyid} = $session->{buddies}->{$group}->{members}->{$screenname}->{buddyid};
+		$buddy->{online} = 1;
+		foreach my $key(keys %$buddy) {
+			$session->{buddies}->{$group}->{members}->{$screenname}->{$key} = $buddy->{$key};
+		}
+
+		$session->callback_buddy_in($screenname, $group, $session->{buddies}->{$group}->{members}->{$screenname});
+	} elsif($family == 0x3 and $subtype == 0xC) {
+		my ($buddy) = new Net::OSCAR::Screenname(unpack("C/a*", $data));
+		my $group = $session->findbuddy($buddy);
+		$session->{buddies}->{$group}->{members}->{$buddy}->{online} = 0;
+		$connection->log_print(OSCAR_DBG_DEBUG, "And so, another former ally has abandoned us.  Curse you, $buddy!");
+		$session->callback_buddy_out($buddy, $group);
+	} elsif($family == 0x1 and $subtype == 0x5) {
+		my $tlv = tlv_decode($data);
+		my($svctype) = unpack("n", $tlv->{0xD});
+		my $conntype;
+		my %chatdata;
+
+		if($svctype == CONNTYPE_LOGIN) {
+			$conntype = "authorizer";
+		} elsif($svctype == CONNTYPE_CHATNAV) {
+			$conntype = "chatnav";
+		} elsif($svctype == CONNTYPE_CHAT) {
+			%chatdata = %{$session->{chats}->{$reqid}};
+			$conntype = "chat $chatdata{name}";
+		} elsif($svctype == CONNTYPE_ADMIN) {
+			$conntype = "admin";
+		} elsif($svctype == CONNTYPE_BOS) {
+			$conntype = "BOS";
+		} else {
+			$svctype = sprintf "unknown (0x%04X)", $svctype;
+		}
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got redirect for $svctype.");
+
+		$session->{chats}->{$reqid} = $session->addconn($tlv->{0x6}, $svctype, $conntype, $tlv->{0x5});
+		if($svctype == CONNTYPE_CHAT) {
+			my($key, $val);
+			while(($key, $val) = each(%chatdata)) { $session->{chats}->{$reqid}->{$key} = $val; }
+		}
+	} elsif($family == 0xB and $subtype == 0x2) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got minimum report interval.");
+	} elsif($family == 0x1 and $subtype == 0x13) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got MOTD.");
+	} elsif($family == 0x1 and $subtype == 0x3) {
+		$connection->log_print($connection->{conntype} == CONNTYPE_BOS ? OSCAR_DBG_SIGNON : OSCAR_DBG_NOTICE, "Got server ready.  Sending set versions.");
+
+		if($connection->{conntype} != CONNTYPE_BOS) {
+			$connection->snac_put(family => 0x1, subtype => 0x17, data =>
+				pack("n*", 1, 3, $connection->{conntype}, 1)
+			);
+		} else {
+			$connection->snac_put(family => 0x1, subtype => 0x17, data =>
+				pack("n*", 1, 3, 0x13, 1, 2, 1, 3, 1, 4, 1, 6, 1, 8, 1, 9, 1, 0xA, 1, 0xB, 1, 0xC, 1)
+			);
+		}
+
+		$connection->log_print(OSCAR_DBG_NOTICE, "Sending Rate Info Req.");
+		$connection->snac_put(family => 0x01, subtype => 0x06);
+	} elsif($family == 0x4 and $subtype == 0x7) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got incoming IM.");
+		my($from, $msg, $away, $chat, $chaturl) = $session->im_parse($data);
+		if($from) {
+			# Ignore invites for chats that we're already in
+			if($chat and not
+				grep { $_->{url} eq $chaturl }
+					 grep { $_->{conntype} == CONNTYPE_CHAT }
+						@{$session->{connections}}
+			) {
+				$session->callback_chat_invite($from, $msg, $chat, $chaturl);
+			} elsif(!$chat) {
+				$session->callback_im_in($from, $msg, $away);
+			}
+		}
+	} elsif($family == 0x4 and $subtype == 0x14) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got typing notification.");
+		
+		my ($unknown1, $unknown2, $type1, $sn, $type2 ) = unpack("N2nC/a*n", $data);
+		$session->callback_typing_status($sn, $type2);
+
+	} elsif($family == 0x1 and $subtype == 0xA) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got rate change.");
+
+		my($group, $window, $clear, $alert, $limit, $disconnect, $current, $max) = unpack("xx n N*", $data);
+		my($rate, $worrisome);
+
+		if($current <= $disconnect) {
+			$rate = RATE_DISCONNECT;
+			$worrisome = 1;
+		} elsif($current <= $limit) {
+			$rate = RATE_LIMIT;
+			$worrisome = 1;
+		} elsif($current <= $alert) {
+			$rate = RATE_ALERT;
+			if($current - $limit < 500) {
+				$worrisome = 1;
+			} else {
+				$worrisome = 0;
+			}
+		} else { # We're clear
+			$rate = RATE_CLEAR;
+			$worrisome = 0;
+		}
+
+		$session->callback_rate_alert($rate, $clear, $window, $worrisome);
+	} elsif($family == 0x1 and $subtype == 0x10) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got evil.");
+		my $enemy = undef;
+
+		my($newevil) = unpack("n", substr($data, 0, 2, ""));
+		$newevil /= 10;
+		$enemy = $session->extract_userinfo($data) if $data;
+
+		$session->callback_evil($newevil, $enemy->{screenname});
+	} elsif($family == 0x4 and $subtype == 0xC) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got IM ack $reqid.");
+		my($reqid) = unpack("xxxx N", $data);
+		delete $session->{cookies}->{$reqid};
+		$session->callback_im_ok($reqdata, $reqid);
+	} elsif($family == 0x1 and $subtype == 0x1F) {
+		$connection->log_print(OSCAR_DBG_SIGNON, "Got memory request.");
+	} elsif($family == 0x13 and $subtype == 0x3) {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Got buddylist 0x0003.");	
+		$session->{gotbl} = 1;
+		#$connection->snac_put(family => 0x13, subtype => 0x7);
+	} elsif($family == 0x13 and $subtype == 0x6) {
+		$connection->log_print(OSCAR_DBG_SIGNON, "Got buddylist.");
+
+		$session->{blarray} = [] unless exists($session->{blarray});
+		substr($data, 0, 3) = "";
+		substr($data, -4, 4) = "" if $snac->{flags2};
+		$session->{blarray}->[$snac->{flags2}] = $data;
+
+		if($snac->{flags2}) {
+			$connection->log_print(OSCAR_DBG_SIGNON, "Got buddylist part - need $snac->{flags2} more parts.");
+		} else {
+			delete $session->{gotbl};
+
+			return unless Net::OSCAR::_BLInternal::blparse($session, join("", reverse @{$session->{blarray}}));
+			delete $session->{blarray};
+			$connection->snac_put(family => 0x13, subtype => 0x7);
+			got_buddylist($session, $connection);
+		}
+	} elsif($family == 0x13 and $subtype == 0x0E) {
+		$session->{budmods}--;
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got blmod ack ($session->{budmods} left).");
+		my(@errors) = unpack("n*", $data);
+
+		# If this is the last packet and there are/were no problems, send bl_ok
+		$session->callback_buddylist_ok() unless $session->{budmods} > 0 or $session->{buderrors} or grep { $_ } @errors;
+
+		my @reqdata = @$reqdata;
+		foreach my $error(@errors) {
+			my($errdata) = shift @reqdata;
+			if($error != 0) {
+				$session->{buderrors} = 1;
+				my($type, $gid, $bid) = ($errdata->{type}, $errdata->{gid}, $errdata->{bid});
+				if(exists($session->{blold}->{$type}) and exists($session->{blold}->{$type}->{$gid}) and exists($session->{blold}->{$type}->{$gid}->{$bid})) {
+					$session->{blinternal}->{$type}->{$gid}->{$bid} = $session->{blold}->{$type}->{$gid}->{$bid};
+				} else {
+					delete $session->{blinternal}->{$type} unless exists($session->{blold}->{$type});
+					delete $session->{blinternal}->{$type}->{$gid} unless exists($session->{blold}->{$type}) and exists($session->{blold}->{$type}->{$gid});
+					delete $session->{blinternal}->{$type}->{$gid}->{$bid} unless exists($session->{blold}->{$type}) and exists($session->{blold}->{$type}->{$gid}) and exists($session->{blold}->{$type}->{$gid}->{$bid});
+				}
+				$session->callback_buddylist_error($error, $errdata->{desc});
+			}
+		}
+
+		if($session->{budmods} == 0) {
+			Net::OSCAR::_BLInternal::BLI_to_NO($session) if $session->{buderrors};
+			delete $session->{qw(blold buderrors)};
+		}
+	} elsif($family == 0x13 and $subtype == 0x0F) {
+		if($session->{gotbl}) {
+			delete $session->{gotbl};
+			$connection->log_print(OSCAR_DBG_WARN, "Couldn't get your buddylist - probably because you don't have one.");
+			got_buddylist($session, $connection);			
+		} else {
+			$connection->log_print(OSCAR_DBG_INFO, "Buddylist error:", hexdump($data));
+		}
+	} elsif($family == 0x1 and $subtype == 0x18) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got hostversions.");
+	} elsif($family == 0x1 and $subtype == 0x1F) {
+		croak "GOT SENDMEMBLK REQUEST!!";
+	} elsif($family == 0x2 and $subtype == 0x6) {
+		my $buddy = $session->extract_userinfo($data);
+		my $screenname = $buddy->{screenname};
+		$connection->log_print(OSCAR_DBG_DEBUG, "Incoming buddy info - $screenname");
+
+		$session->callback_buddy_info($screenname, $buddy);
+	} elsif($family == 0x1 and $subtype == 0x10) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Somebody thinks you're evil!");
+
+		my($evil) = unpack("n", substr($data, 0, 2, ""));
+		$evil /= 10;
+		my $eviller = "";
+		if($data) {
+			$eviller = $session->extract_userinfo($data);
+		}
+		$session->callback_evil($evil, $eviller);
+	} elsif($family == 0xD and $subtype == 9) {
+		my $chat;
+		substr($data, 0, 4) = "";
+		($chat->{exchange}) = unpack("n", substr($data, 0, 2, ""));
+		my($namelen) = unpack("C", substr($data, 0, 1, ""));
+		$chat->{url} = substr($data, 0, $namelen, "");
+
+		substr($data, 0, 21) = ""; # 0 2 15 66 2 0 68 4 0 0 6A
+		($chat->{name}) = unpack("n/a*", $data);
+		substr($data, 0, length($chat->{name})+2) = "";
+
+		$session->log_print(OSCAR_DBG_DEBUG, "ChatNav told us where to find $chat->{name}");
+
+		# Generate a random request ID
+		my($reqid) = "";
+		$reqid = pack("n", 4);
+		$reqid .= randchars(2);
+		($reqid) = unpack("N", $reqid);
+
+		# We can ignore the rest of this packet.
+		$session->{chats}->{$reqid} = $chat;
+
+		# And now, on a very special Chat Request...
+		$session->{bos}->snac_put(family => 0x01, subtype => 0x04, reqid => $reqid, data =>
+			pack("nnn nCa*n",
+				CONNTYPE_CHAT, 1, 5+length($chat->{url}),
+				$chat->{exchange}, length($chat->{url}), $chat->{url}, 0
+			)
+		);
+	} elsif($family == 0x04 and $subtype == 0x0C) {
+		$session->log_print(OSCAR_DBG_DEBUG, "Acknowledged.");
+	} elsif($family == 0x0E and $subtype == 0x02) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Got update on room info.");
+
+		my($namelen) = unpack("xx C", substr($data, 0, 4, ""));
+		substr($data, 0, $namelen - 1, "");
+
+		substr($data, 0, 2) = "";
+		my($detaillevel) = unpack("C", substr($data, 0, 1, ""));
+
+		my($tlvcount) = unpack("n", substr($data, 0, 2, ""));
+		my $tlv = tlv_decode($data);
+
+		$session->callback_chat_joined($connection->{name}, $connection) unless $connection->{sent_joined}++;
+
+		my $occupants = 0;
+		($occupants) = unpack("n", $tlv->{0x6F}) if $tlv->{0x6F};
+		for(my $i = 0; $i < $occupants; $i++) {
+			my($occupant, $occlen) = $session->extract_userinfo($tlv->{0x73});
+			substr($data, 0, $occlen) = "";
+			$session->callback_chat_buddy_in($occupant->{screenname}, $connection);
+		}
+	} elsif($family == 0x0E and $subtype == 0x03) {
+		while($data) {
+			my($occupant, $chainlen) = $session->extract_userinfo($data);
+			substr($data, 0, $chainlen) = "";
+			$session->callback_chat_buddy_in($occupant->{screenname}, $connection, $occupant);
+		}
+	} elsif($family == 0x0E and $subtype == 0x04) {
+		while(substr($data, 0, 1) ne chr(0)) {
+			my($emigree) = unpack("C/a*", $data);
+			substr($data, 0, 1+length($emigree)) = "";
+			$session->callback_chat_buddy_out($emigree, $connection);
+		}
+	} elsif($family == 0x0E and $subtype == 0x06) {
+		substr($data, 0, 10) = "";
+		my $tlv = tlv_decode($data);
+		my ($sender) = unpack("C/a*", $tlv->{0x03});
+		my $mtlv = tlv_decode($tlv->{0x05});
+		my $message = $mtlv->{0x01};
+		$session->callback_chat_im_in($sender, $connection, $message);
+	} elsif($family == 0x07 and $subtype == 0x05) {
+		$connection->log_print(OSCAR_DBG_DEBUG, "Admin request successful!");
+
+		my($reqtype) = unpack("n", substr($data, 0, 2, ""));
+		my $tlv = tlv_decode(substr($data, 0, 6, ""));
+		my $reqdesc = "";
+		my($subreq) = unpack("n", $tlv->{0x3}) if $tlv->{0x3};
+		$subreq ||= 0;
+		if($reqtype == 2) {
+			$reqdesc = ADMIN_TYPE_PASSWORD_CHANGE;
+		} elsif($reqtype == 3) {
+			if($subreq == 0x11) {
+				$reqdesc = ADMIN_TYPE_EMAIL_CHANGE;
+			} else {
+				$reqdesc = ADMIN_TYPE_SCREENNAME_FORMAT;
+			}
+		} elsif($reqtype == 0x1E) {
+			$reqdesc = ADMIN_TYPE_ACCOUNT_CONFIRM;
+		}
+		delete $session->{adminreq}->{$reqdesc} if $reqdesc;
+		$reqdesc ||= sprintf "unknown admin reply type 0x%04X/0x%04X", $reqtype, $subreq;
+
+		my $errdesc = "";
+		if(!exists($tlv->{1})) {
+			my $tlv = tlv_decode($data);
+			if($reqdesc eq "account confirm") {
+				$errdesc = "Your account is already confirmed.";
+			} else {
+				my($result) = unpack("n", $tlv->{0x08});
+				if($result == 2) {
+					$errdesc = ADMIN_ERROR_BADPASS;
+				} elsif($result == 6) {
+					$errdesc = ADMIN_ERROR_BADINPUT;
+				} elsif($result == 0xB or $result == 0xC) {
+					$errdesc = ADMIN_ERROR_BADLENGTH;
+				} elsif($result == 0x13) {
+					$errdesc = ADMIN_ERROR_TRYLATER;
+				} elsif($result == 0x1D) {
+					$errdesc = ADMIN_ERROR_REQPENDING;
+				} else {
+					$errdesc = sprintf "Unknown error 0x%04X.", $result;
+				}
+			}
+			$session->callback_admin_error($reqdesc, $errdesc, $tlv->{4});
+		} else {
+			if($reqdesc eq "screenname format") {
+				$session->{screenname} = $data;
+			}
+			$session->callback_admin_ok($reqdesc);
+		}
+	} elsif($family == 0x07 and $subtype == 0x05) {
+		$session->log_print(OSCAR_DBG_DEBUG, "Account confirmed.");
+		$session->callback_admin_ok(ADMIN_TYPE_ACCOUNT_CONFIRM);
+	} elsif($family == 0x09 and $subtype == 0x02) {
+		$session->crapout($connection, "A session using this screenname has been opened in another location.");
+	} else {
+		$connection->log_print(OSCAR_DBG_NOTICE, "Unknown SNAC: ".hexdump($snac->{data}));
+	}
+
+	return 1;
+}
+
+sub got_buddylist($$) {
+	my($session, $connection) = @_;
+
+	$session->set_info("") unless $session->profile;
+
+	$connection->log_print(OSCAR_DBG_DEBUG, "Adding ICBM parameters.");
+	$connection->snac_put(family => 0x4, subtype => 0x2, data =>
+		pack("n*", 0, 0, 0x3 | 0xb, 8000, 0x3E7, 0x3E7, 0, 0)
+	);
+
+	$connection->log_print(OSCAR_DBG_DEBUG, "Setting idle.");
+	$connection->snac_put(family => 0x1, subtype => 0x11, data => pack("N", 0));
+
+	$connection->ready();
+
+	$session->{is_on} = 1;
+	$session->callback_signon_done() unless $session->{sent_done}++;
+
+	$connection->snac_put(family => 0x2, subtype => 0xB, data => pack("Ca*", length(normalize($session->screenname)), normalize($session->screenname)));
+
+	$connection->log_print(OSCAR_DBG_DEBUG, "Setting directory info.");
+	$connection->snac_put(family => 0x02, subtype => 0x09);
+
+	$connection->snac_put(family => 0x02, subtype => 0x0F);
+}
+
+1;
+

plugins/Net-OSCAR/Net/OSCAR/Chat.pm

@@ -0,0 +1,75 @@
+package Net::OSCAR::Chat;
+
+
+$VERSION = '0.62';
+
+use strict;
+use Carp;
+
+use Net::OSCAR::TLV;
+use Net::OSCAR::Callbacks;
+use vars qw(@ISA $VERSION);
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::OldPerl;
+@ISA = qw(Net::OSCAR::Connection);
+
+sub invite($$;$) {
+	my($self, $who, $message) = @_;
+	my $packet = "";
+	$message ||= "Join me in this Buddy Chat";
+
+	$self->log_print(OSCAR_DBG_DEBUG, "Inviting $who to join us.");
+
+	$packet .= randchars(8);
+	$packet .= pack("nCa*", 2, length($who), $who);
+
+	my %tlv;
+	tie %tlv, "Net::OSCAR::TLV";
+
+	%tlv = (
+		0x5 => pack("n18 a* n2 a* n5 C a* n3",
+				0, 0x7EAF, 0x3A00, 0xB23A, 0, 0x748F, 0x2420, 0x6287,
+				0x11D1, 0x8222, 0x4445, 0x5354, 0, 0xA, 2, 1, 0xD,
+				length("us-ascii"), "us-ascii", 0xC, length($message), $message,
+				0xF, 0, 0x2711, 9+length($self->{url}),
+				$self->{exchange}, length($self->{url}),
+				$self->{url}, 0, 3, 0
+		)
+	);
+	$packet .= tlv_encode(\%tlv);
+
+	$self->{session}->{bos}->snac_put(family => 0x04, subtype => 0x06, data => $packet);
+}
+
+sub chat_send($$;$$) {
+	my($self, $msg, $noreflect, $away) = @_;
+	my $packet = "";
+
+	my %tlv;
+	my %mtlv;
+	tie %tlv, "Net::OSCAR::TLV";
+	tie %mtlv, "Net::OSCAR::TLV";
+
+	$packet .= randchars(8);
+	$packet .= pack("n", 3); # channel
+
+	%mtlv = (
+		0x02 => "us-ascii",
+		0x03 => "",
+		0x01 => $msg
+	);
+	%tlv = (0x01 => "");
+	$tlv{0x06} = "" unless $noreflect;
+	$tlv{0x07} = "" if $away;
+	$tlv{0x05} = tlv_encode(\%mtlv);
+	$packet .= tlv_encode(\%tlv);
+
+	$self->snac_put(family => 0x0E, subtype => 0x05, data => $packet);
+}
+
+sub part($) { shift->disconnect(); }	
+sub url($) { shift->{url}; }
+sub name($) { shift->{name}; }
+sub exchange($) { shift->{exchange}; }
+
+1;

plugins/Net-OSCAR/Net/OSCAR/Common.pm

@@ -0,0 +1,395 @@
+package Net::OSCAR::Common;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION);
+use Scalar::Util;
+use Net::OSCAR::TLV;
+use Carp;
+require Exporter;
+@ISA = qw(Exporter);
+
+%EXPORT_TAGS = (
+	standard => [qw(
+		ADMIN_TYPE_PASSWORD_CHANGE
+		ADMIN_TYPE_EMAIL_CHANGE
+		ADMIN_TYPE_SCREENNAME_FORMAT
+		ADMIN_TYPE_ACCOUNT_CONFIRM
+		ADMIN_ERROR_UNKNOWN
+		ADMIN_ERROR_BADPASS
+		ADMIN_ERROR_BADINPUT
+		ADMIN_ERROR_BADLENGTH
+		ADMIN_ERROR_TRYLATER
+		ADMIN_ERROR_REQPENDING
+		ADMIN_ERROR_CONNREF
+		VISMODE_PERMITALL
+		VISMODE_DENYALL
+		VISMODE_PERMITSOME
+		VISMODE_DENYSOME
+		VISMODE_PERMITBUDS
+		RATE_CLEAR
+		RATE_ALERT
+		RATE_LIMIT
+		RATE_DISCONNECT
+		GROUPPERM_OSCAR
+		GROUPPERM_AOL
+		OSCAR_SVC_AIM
+		OSCAR_SVC_ICQ
+		MTN_TYPING_DONE 
+		MTN_TEXT_TYPED 
+		MTN_TYPING_BEGUN
+	)],
+	loglevels => [qw(
+		OSCAR_DBG_NONE
+		OSCAR_DBG_WARN
+		OSCAR_DBG_INFO
+		OSCAR_DBG_SIGNON
+		OSCAR_DBG_NOTICE
+		OSCAR_DBG_DEBUG
+		OSCAR_DBG_PACKETS
+	)],
+	all => [qw(
+		OSCAR_DBG_NONE OSCAR_DBG_WARN OSCAR_DBG_INFO OSCAR_DBG_SIGNON OSCAR_DBG_NOTICE OSCAR_DBG_DEBUG OSCAR_DBG_PACKETS
+		ADMIN_TYPE_PASSWORD_CHANGE ADMIN_TYPE_EMAIL_CHANGE ADMIN_TYPE_SCREENNAME_FORMAT ADMIN_TYPE_ACCOUNT_CONFIRM
+		ADMIN_ERROR_UNKNOWN ADMIN_ERROR_BADPASS ADMIN_ERROR_BADINPUT ADMIN_ERROR_BADLENGTH ADMIN_ERROR_TRYLATER ADMIN_ERROR_REQPENDING ADMIN_ERROR_CONNREF
+		VISMODE_PERMITALL VISMODE_DENYALL VISMODE_PERMITSOME VISMODE_DENYSOME VISMODE_PERMITBUDS RATE_CLEAR RATE_ALERT RATE_LIMIT RATE_DISCONNECT
+		FLAP_CHAN_NEWCONN FLAP_CHAN_SNAC FLAP_CHAN_ERR FLAP_CHAN_CLOSE
+		CONNTYPE_LOGIN CONNTYPE_BOS CONNTYPE_ADMIN CONNTYPE_CHAT CONNTYPE_CHATNAV
+		MODBL_ACTION_ADD MODBL_ACTION_DEL MODBL_WHAT_BUDDY MODBL_WHAT_GROUP MODBL_WHAT_PERMIT MODBL_WHAT_DENY
+		GROUPPERM_OSCAR GROUPPERM_AOL OSCAR_SVC_AIM OSCAR_SVC_ICQ		
+		MTN_TYPING_DONE MTN_TEXT_TYPED MTN_TYPING_BEGUN
+		BUDTYPES
+		ENCODING
+		ERRORS
+		randchars log_print log_printf hexdump normalize tlv_decode tlv_encode tlv send_error tlvtie bltie signon_tlv encode_password
+	)]
+);
+@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+
+use constant OSCAR_DBG_NONE => 0;
+use constant OSCAR_DBG_WARN => 1;
+use constant OSCAR_DBG_INFO => 2;
+use constant OSCAR_DBG_SIGNON => 3;
+use constant OSCAR_DBG_NOTICE => 4;
+use constant OSCAR_DBG_DEBUG => 6;
+use constant OSCAR_DBG_PACKETS => 10;
+
+use constant ADMIN_TYPE_PASSWORD_CHANGE => 1;
+use constant ADMIN_TYPE_EMAIL_CHANGE => 2;
+use constant ADMIN_TYPE_SCREENNAME_FORMAT => 3;
+use constant ADMIN_TYPE_ACCOUNT_CONFIRM => 4;
+
+use constant ADMIN_ERROR_UNKNOWN => 0;
+use constant ADMIN_ERROR_BADPASS => 1;
+use constant ADMIN_ERROR_BADINPUT => 2;
+use constant ADMIN_ERROR_BADLENGTH => 3;
+use constant ADMIN_ERROR_TRYLATER => 4;
+use constant ADMIN_ERROR_REQPENDING => 5;
+use constant ADMIN_ERROR_CONNREF => 6;
+
+use constant FLAP_CHAN_NEWCONN => 0x01;
+use constant FLAP_CHAN_SNAC => 0x02;
+use constant FLAP_CHAN_ERR => 0x03;
+use constant FLAP_CHAN_CLOSE => 0x04;
+
+use constant CONNTYPE_LOGIN => 0;
+use constant CONNTYPE_BOS => 0x2;
+use constant CONNTYPE_ADMIN => 0x7;
+use constant CONNTYPE_CHAT => 0xE;
+use constant CONNTYPE_CHATNAV => 0xD;
+
+use constant MODBL_ACTION_ADD => 0x1;
+use constant MODBL_ACTION_DEL => 0x2;
+
+use constant MODBL_WHAT_BUDDY => 0x1;
+use constant MODBL_WHAT_GROUP => 0x2;
+use constant MODBL_WHAT_PERMIT => 0x3;
+use constant MODBL_WHAT_DENY => 0x4;
+
+use constant VISMODE_PERMITALL  => 0x1;
+use constant VISMODE_DENYALL    => 0x2;
+use constant VISMODE_PERMITSOME => 0x3;
+use constant VISMODE_DENYSOME   => 0x4;
+use constant VISMODE_PERMITBUDS => 0x5;
+
+use constant GROUP_PERMIT => 0x0002;
+use constant GROUP_DENY   => 0x0003;
+
+use constant MTN_TYPING_DONE => 0x00;
+use constant MTN_TEXT_TYPED => 0x01;
+use constant MTN_TYPING_BEGUN => 0x02;
+
+use constant RATE_CLEAR => 1;
+use constant RATE_ALERT => 2;
+use constant RATE_LIMIT => 3;
+use constant RATE_DISCONNECT => 4;
+
+use constant GROUPPERM_OSCAR => 0x18;
+use constant GROUPPERM_AOL => 0x04;
+
+use constant OSCAR_SVC_AIM => (
+	host => 'login.oscar.aol.com',
+	port => 5190,
+	supermajor => 0x0109,
+	major => 5,
+	minor => 0,
+	subminor => 0,
+	build => 2938,
+	subbuild => 0x9F,
+	clistr => "AOL Instant Messenger (SM), version 5.0.2938/WIN32",
+	hashlogin => 1,
+);
+use constant OSCAR_SVC_ICQ => ( # Courtesy of SDiZ Cheng
+	host => 'login.icq.com',
+	port => 5190,
+	supermajor => 266,
+	major => 4,
+	minor => 63,
+	subminor => 1,
+	build => 3279,
+	subbuild => 85,
+	clistr => "ICQ Inc. - Product of ICQ (TM).200b.4.63.1.3279.85",
+	hashlogin => 1,
+);
+
+use constant BUDTYPES => ("buddy", "group", "permit entry", "deny entry", "visibility/misc. data", "presence");
+
+use constant ENCODING => 'text/aolrtf; charset="us-ascii"';
+
+# I'm not 100% sure about error 29
+use constant ERRORS => split(/\n/, <<EOF);
+Invalid error
+Invalid SNAC
+Sending too fast to host
+Sending too fast to client
+%s is not logged in, so the attempted operation (sending an IM, getting user information) was unsuccessful
+Service unavailable
+Service not defined
+Obsolete SNAC
+Not supported by host
+Not supported by client
+Refused by client
+Reply too big
+Responses lost
+Request denied
+Busted SNAC payload
+Insufficient rights
+%s is in your permit or deny list
+Too evil (sender)
+Too evil (receiver)
+User temporarily unavailable
+No match
+List overflow
+Request ambiguous
+Queue full
+Not while on AOL
+Unknown error 25
+Unknown error 26
+Unknown error 27
+Unknown error 28
+There have been too many recent signons from this address.  Please wait a few minutes and try again.
+EOF
+
+sub randchars($) {
+	my $count = shift;
+	my $retval = "";
+	for(my $i = 0; $i < $count; $i++) { $retval .= chr(int(rand(256))); }
+	return $retval;
+}
+
+sub log_print($$@) {
+	my($obj, $level) = (shift, shift);
+	my $session = exists($obj->{session}) ? $obj->{session} : $obj;
+	return unless defined($session->{LOGLEVEL}) and $session->{LOGLEVEL} >= $level;
+
+	my $message = "";
+	$message .= $obj->{description}. ": " if $obj->{description};
+	$message .= join("", @_). "\n";
+
+	if($session->{callbacks}->{log}) {
+		$session->callback_log($level, $message);
+	} else {
+		$message = "(".$session->{screenname}.") $message" if $session->{SNDEBUG};
+		print STDERR $message;
+	}
+}
+
+sub log_printf($$$@) {
+	my($obj, $level, $fmtstr) = (shift, shift, shift);
+
+	$obj->log_print($level, sprintf($fmtstr, @_));
+}
+
+sub hexdump($) {
+	my $stuff = shift;
+	my $retbuff = "";
+	my @stuff;
+
+	for(my $i = 0; $i < length($stuff); $i++) {
+		push @stuff, substr($stuff, $i, 1);
+	}
+
+	return $stuff unless grep { $_ lt chr(0x20) or $_ gt chr(0x7E) } @stuff;
+	while(@stuff) {
+		my $i = 0;
+		$retbuff .= "\n\t";
+		my @currstuff = splice(@stuff, 0, 16);
+
+		foreach my $currstuff(@currstuff) {
+			$retbuff .= " " unless $i % 4;
+			$retbuff .= " " unless $i % 8;
+			$retbuff .= sprintf "%02X ", ord($currstuff);
+			$i++;
+		}
+		for(; $i < 16; $i++) {
+			$retbuff .= " " unless $i % 4;
+			$retbuff .= " " unless $i % 8;
+			$retbuff .= "   ";
+		}
+
+		$retbuff .= "  ";
+		$i = 0;
+		foreach my $currstuff(@currstuff) {
+			$retbuff .= " " unless $i % 4;
+			$retbuff .= " " unless $i % 8;
+			if($currstuff ge chr(0x20) and $currstuff le chr(0x7E)) {
+				$retbuff .= $currstuff;
+			} else {
+				$retbuff .= ".";
+			}
+			$i++;
+		}
+	}
+	return $retbuff;
+}
+
+sub normalize($) {
+	my $temp = shift;
+	$temp =~ tr/ //d if $temp;
+	return $temp ? lc($temp) : "";
+}
+
+sub tlv_decode($;$) {
+	my($tlv, $tlvcnt) = @_;
+	my($type, $len, $value, %retval);
+	my $currtlv = 0;
+	my $strpos = 0;
+
+	tie %retval, "Net::OSCAR::TLV";
+
+	$tlvcnt = 0 unless $tlvcnt;
+	while(length($tlv) >= 4 and (!$tlvcnt or $currtlv < $tlvcnt)) {
+		($type, $len) = unpack("nn", $tlv);
+		$len = 0x2 if $type == 0x13;
+		$strpos += 4;
+		substr($tlv, 0, 4) = "";
+		if($len) {
+			($value) = substr($tlv, 0, $len, "");
+		} else {
+			$value = "";
+		}
+		$strpos += $len;
+		$currtlv++ unless $type == 0;
+		$retval{$type} = $value;
+	}
+
+	return $tlvcnt ? (\%retval, $strpos) : \%retval;
+}
+
+sub tlv(@) {
+	my %tlv = ();
+	tie %tlv, "Net::OSCAR::TLV";
+	while(@_) { my($key, $value) = (shift, shift); $tlv{$key} = $value; }
+	return tlv_encode(\%tlv);
+}
+
+sub tlv_encode($) {
+	my $tlv = shift;
+	my($buffer, $type, $value) = ("", 0, "");
+
+	confess "You must use a tied Net::OSCAR::TLV hash!" unless defined($tlv) and ref($tlv) eq "HASH" and defined(%$tlv) and tied(%$tlv)->isa("Net::OSCAR::TLV");
+	while (($type, $value) = each %$tlv) {
+		$value ||= "";
+		$buffer .= pack("nna*", $type, length($value), $value);
+
+	}
+	return $buffer;
+}
+
+sub send_error($$$$$;@) {
+	my($oscar, $connection, $error, $desc, $fatal, @reqdata) = @_;
+	$desc = sprintf $desc, @reqdata;
+	$oscar->callback_error($connection, $error, $desc, $fatal);
+}
+
+sub bltie(;$) {
+	my $retval = {};
+	tie %$retval, "Net::OSCAR::Buddylist", @_;
+	return $retval;
+}
+
+sub tlvtie(;$) {
+	my $retval = {};
+	tie %$retval, "Net::OSCAR::TLV", shift;
+	return $retval;
+}
+
+sub signon_tlv($;$$) {
+	my($session, $password, $key) = @_;
+
+	my %tlv = (
+		0x01 => $session->{screenname},
+		0x03 => $session->{svcdata}->{clistr},
+		0x16 => pack("n", $session->{svcdata}->{supermajor}),
+		0x17 => pack("n", $session->{svcdata}->{major}),
+		0x18 => pack("n", $session->{svcdata}->{minor}),
+		0x19 => pack("n", $session->{svcdata}->{subminor}),
+		0x1A => pack("n", $session->{svcdata}->{build}),
+		0x14 => pack("N", $session->{svcdata}->{subbuild}),
+		0x0F => "en", # lang
+		0x0E => "us", # country
+	);
+
+	if($session->{svcdata}->{hashlogin}) {
+		$tlv{0x02} = encode_password($session, $password);
+	} else {
+		if($session->{auth_response}) {
+			($tlv{0x25}) = delete $session->{auth_response};
+		} else {
+			$tlv{0x25} = encode_password($session, $password, $key);
+		}
+		$tlv{0x4A} = pack("C", 1);
+	}
+
+	return %tlv;
+}
+
+sub encode_password($$;$) {
+	my($session, $password, $key) = @_;
+
+	if(!$session->{svcdata}->{hashlogin}) { # Use new SNAC-based method
+		my $md5 = Digest::MD5->new;
+
+		$md5->add($key);
+		$md5->add($password);
+		$md5->add("AOL Instant Messenger (SM)");
+		return $md5->digest();
+	} else { # Use old roasting method.  Courtesy of SDiZ Cheng.
+		my $ret = "";
+		my @pass = map {ord($_)} split(//, $password);
+
+		my @encoding_table = map {hex($_)} qw(
+			F3 26 81 C4 39 86 DB 92 71 A3 B9 E6 53 7A 95 7C
+		);
+
+		for(my $i = 0; $i < length($password); $i++) {
+			$ret .= chr($pass[$i] ^ $encoding_table[$i]);
+		}
+
+		return $ret;
+	}
+}
+
+
+1;

plugins/Net-OSCAR/Net/OSCAR/Connection.pm

@@ -0,0 +1,368 @@
+package Net::OSCAR::Connection;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use Socket;
+use Symbol;
+use Digest::MD5;
+use Fcntl qw(:flock :mode :seek :DEFAULT);
+
+use constant EAGAIN => 11;
+use constant EINPROGRESS => undef;
+
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::TLV;
+use Net::OSCAR::Callbacks;
+use Net::OSCAR::OldPerl;
+
+sub new($$$$$$) { # Think you got enough parameters there, Chester?
+	my $class = ref($_[0]) || $_[0] || "Net::OSCAR::Connection";
+	shift;
+	my $self = { };
+	bless $self, $class;
+	$self->{seqno} = 0;
+	$self->{session} = shift;
+	$self->{auth} = shift;
+	$self->{conntype} = shift;
+	$self->{description} = shift;
+	$self->{paused} = 0;
+	$self->{outbuff} = "";
+	$self->connect(shift);
+
+	return $self;
+}
+
+sub fileno($) {
+	my $self = shift;
+	if(!$self->{socket}) {
+		$self->{sockerr} = 1;
+		$self->disconnect();
+		return undef;
+	}
+	return fileno $self->{socket};
+}
+
+sub flap_encode($$;$) {
+	my ($self, $msg, $channel) = @_;
+
+	$channel ||= FLAP_CHAN_SNAC;
+	return pack("CCnna*", 0x2A, $channel, ++$self->{seqno}, length($msg), $msg);
+}
+
+sub flap_put($;$$) {
+	my($self, $msg, $channel) = @_;
+	my $emsg;
+	my $had_outbuff = 0;
+
+	return unless $self->{socket} and CORE::fileno($self->{socket}) and getpeername($self->{socket}); # and !$self->{socket}->error;
+
+	$had_outbuff = 1 if $self->{outbuff};
+	if($msg) {
+		$emsg = $self->flap_encode($msg, $channel);
+		$self->{outbuff} .= $emsg;
+	}
+	my $nchars = syswrite($self->{socket}, $self->{outbuff}, length($self->{outbuff}));
+	if(!defined($nchars)) {
+		return "" if $! == EAGAIN;
+		$self->log_print(OSCAR_DBG_NOTICE, "Couldn't write to socket: $!");
+		$self->{sockerr} = 1;
+		$self->disconnect();
+		return undef;
+	} else {
+		$emsg = substr($self->{outbuff}, 0, $nchars, "");
+		if($self->{outbuff}) {
+			$self->log_print(OSCAR_DBG_NOTICE, "Couldn't do complete write - had to buffer ", length($self->{outbuff}), " bytes.");
+			$self->{session}->callback_connection_changed($self, "readwrite");
+		} elsif($had_outbuff) {
+			$self->{session}->callback_connection_changed($self, "read");
+		}
+		$self->log_print(OSCAR_DBG_PACKETS, "Put ", hexdump($emsg));
+	}
+}
+
+sub flap_get($) {
+	my $self = shift;
+	my $socket = $self->{socket};
+	my ($buffer, $channel, $len);
+	my $nchars;
+
+	if(!exists($self->{buff_gotflap})) {
+		$self->{buffsize} ||= 6;
+		$self->{buffer} ||= "";
+
+		$nchars = sysread($self->{socket}, $buffer, $self->{buffsize} - length($self->{buffer}));
+		if(!defined($nchars)) {
+			return "" if $! == EAGAIN;
+			$self->log_print(OSCAR_DBG_NOTICE, "Couldn't read from socket: $!");
+			$self->{sockerr} = 1;
+			$self->disconnect();
+			return undef;
+		} else {
+			$self->{buffer} .= $buffer;
+		}
+
+		if(length($self->{buffer}) == 6) {
+			$self->{buff_gotflap} = 1;
+			($buffer) = delete $self->{buffer};
+			(undef, $self->{channel}, undef, $self->{buffsize}) = unpack("CCnn", $buffer);
+			$self->{buffer} = "";
+		} else {
+			return "";
+		}
+	}
+
+	$nchars = sysread($self->{socket}, $buffer, $self->{buffsize} - length($self->{buffer}));
+	if(!defined($nchars)) {
+		return "" if $! == EAGAIN;
+		$self->log_print(OSCAR_DBG_NOTICE, "Couldn't read from socket: $!");
+		$self->{sockerr} = 1;
+		$self->disconnect();
+		return undef;
+	} else {
+		$self->{buffer} .= $buffer;
+	}
+
+	if(length($self->{buffer}) == $self->{buffsize}) {
+		$self->log_print(OSCAR_DBG_PACKETS, "Got ", hexdump($self->{buffer}));
+		$buffer = $self->{buffer};
+
+		delete $self->{buffer};
+		delete $self->{buff_gotflap};
+		delete $self->{buffsize};
+
+		return $buffer;
+	} else {
+		return "";
+	}
+}
+
+sub snac_encode($%) {
+	my($self, %snac) = @_;
+
+	$snac{family} ||= 0;
+	$snac{subtype} ||= 0;
+	$snac{flags1} ||= 0;
+	$snac{flags2} ||= 0;
+	$snac{data} ||= "";
+	$snac{reqdata} ||= "";
+	$snac{reqid} ||= ($snac{subtype}<<16) | (unpack("n", randchars(2)))[0];
+	$self->{reqdata}->[$snac{family}]->{pack("N", $snac{reqid})} = $snac{reqdata} if $snac{reqdata};
+
+	return pack("nnCCNa*", $snac{family}, $snac{subtype}, $snac{flags1}, $snac{flags2}, $snac{reqid}, $snac{data});
+}
+
+sub snac_put($%) {
+	my($self, %snac) = @_;
+	$snac{channel} ||= FLAP_CHAN_SNAC;
+	$self->flap_put($self->snac_encode(%snac), $snac{channel});
+}
+
+sub snac_get($) {
+	my($self) = shift;
+	my $snac = $self->flap_get() or return 0;
+	return $self->snac_decode($snac);
+}
+
+sub snac_decode($$) {
+	my($self, $snac) = @_;
+	my($family, $subtype, $flags1, $flags2, $reqid, $data) = (unpack("nnCCNa*", $snac));
+
+	return {
+		family => $family,
+		subtype => $subtype,
+		flags1 => $flags1,
+		flags2 => $flags2,
+		reqid => $reqid,
+		data => $data
+	};
+}
+
+sub snac_dump($$) {
+	my($self, $snac) = @_;
+	return "family=".$snac->{family}." subtype=".$snac->{subtype};
+}
+
+sub disconnect($) {
+	my($self) = @_;
+
+	$self->{session}->delconn($self);
+}
+
+sub set_blocking($$) {
+	my $self = shift;
+	my $blocking = shift;
+	my $flags = 0;
+
+=for unix
+	fcntl($self->{socket}, F_GETFL, $flags);
+	if($blocking) {
+		$flags &= ~O_NONBLOCK;
+	} else {
+		$flags |= O_NONBLOCK;
+	}
+	fcntl($self->{socket}, F_SETFL, $flags);
+=cut
+
+	return $self->{socket};
+}
+
+sub connect($$) {
+	my($self, $host) = @_;
+	my $temp;
+	my %tlv;
+	my $port;
+
+	tie %tlv, "Net::OSCAR::TLV";
+
+	return $self->{session}->crapout($self, "Empty host!") unless $host;
+	$host =~ s/:(.+)//;
+	if(!$1) {
+		if(exists($self->{session})) {
+			$port = $self->{session}->{port};
+		} else {
+			return $self->{session}->crapout($self, "No port!");
+		}
+	} else {
+		$port = $1;
+		if($port =~ /^[^0-9]/) {
+			$port = $self->{session}->{port};
+		}
+	}
+	$self->{host} = $host;
+	$self->{port} = $port;
+
+	$self->log_print(OSCAR_DBG_NOTICE, "Connecting to $host:$port.");
+	$self->{socket} = gensym;
+	socket($self->{socket}, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
+
+	$self->{ready} = 0;
+	$self->{connected} = 0;
+
+	$self->set_blocking(0);
+	my $addr = inet_aton($host) or return $self->{session}->crapout($self, "Couldn't resolve $host.");
+	if(!connect($self->{socket}, sockaddr_in($port, $addr))) {
+		return 1 if $! == EINPROGRESS;
+		return $self->{session}->crapout($self, "Couldn't connect to $host:$port: $!");
+	}
+
+	return 1;
+}
+
+sub get_filehandle($) { shift->{socket}; }
+
+# $read/$write tell us if select indicated readiness to read and/or write
+# Dittor for $error
+sub process_one($;$$$) {
+	my($self, $read, $write, $error) = @_;
+	my $snac;
+	my %tlv;
+
+	if($error) {
+		$self->{sockerr} = 1;
+		return $self->disconnect();
+	}
+
+	tie %tlv, "Net::OSCAR::TLV";
+
+	$read ||= 1;
+	$write ||= 1;
+
+	if($write && $self->{outbuff}) {
+		$self->log_print(OSCAR_DBG_DEBUG, "Flushing output buffer.");
+		$self->flap_put();
+	}
+
+	if($write && !$self->{connected}) {
+		$self->log_print(OSCAR_DBG_NOTICE, "Connected.");
+		$self->{connected} = 1;
+		$self->{session}->callback_connection_changed($self, "read");
+		return 1;
+	} elsif($read && !$self->{ready}) {
+		$self->log_print(OSCAR_DBG_DEBUG, "Getting connack.");
+		my $flap = $self->flap_get();
+		if(!defined($flap)) {
+			$self->log_print(OSCAR_DBG_NOTICE, "Couldn't connect.");
+			return 0;
+		} else {
+			$self->log_print(OSCAR_DBG_DEBUG, "Got connack.");
+		}
+		return $self->{session}->crapout($self, "Got bad connack from server") unless $self->{channel} == FLAP_CHAN_NEWCONN;
+
+		if($self->{conntype} == CONNTYPE_LOGIN) {
+			$self->log_print(OSCAR_DBG_DEBUG, "Got connack.  Sending connack.");
+			$self->flap_put(pack("N", 1), FLAP_CHAN_NEWCONN) unless $self->{session}->{svcdata}->{hashlogin};
+			$self->log_print(OSCAR_DBG_SIGNON, "Connected to login server.");
+			$self->{ready} = 1;
+
+			$self->log_print(OSCAR_DBG_SIGNON, "Sending screenname.");
+			if(!$self->{session}->{svcdata}->{hashlogin}) {
+				%tlv = (
+					0x17 => pack("C6", 0, 0, 0, 0, 0, 0),
+					0x01 => $self->{session}->{screenname}
+				);
+				$self->flap_put(tlv_encode(\%tlv));
+			} else {
+				%tlv = signon_tlv($self->{session}, $self->{auth});
+				$self->flap_put(pack("N", 1) . tlv_encode(\%tlv), FLAP_CHAN_NEWCONN);
+			}
+		} else {
+			$self->log_print(OSCAR_DBG_NOTICE, "Sending BOS-Signon.");
+			#%tlv = (0x06 =>$self->{auth});
+			#$self->flap_put(pack("N", 1) . tlv_encode(\%tlv), FLAP_CHAN_NEWCONN);
+			$self->snac_put(family => 0, subtype => 1,
+				flags2 => 0x6,
+				reqid => 0x01000000 | (unpack("n", substr($self->{auth}, 0, 2)))[0],
+				data => substr($self->{auth}, 2),
+				channel => FLAP_CHAN_NEWCONN);
+		}
+		$self->log_print(OSCAR_DBG_DEBUG, "SNAC time.");
+		return $self->{ready} = 1;
+	} elsif($read) {
+		if(!$self->{session}->{svcdata}->{hashlogin}) {
+			$snac = $self->snac_get() or return 0;
+			return Net::OSCAR::Callbacks::process_snac($self, $snac);
+		} else {
+			my $data = $self->flap_get() or return 0;
+			$snac = {data => $data, reqid => 0, family => 0x17, subtype => 0x3};
+			if($self->{channel} == FLAP_CHAN_CLOSE) {
+				$self->{conntype} = CONNTYPE_LOGIN;
+				$self->{family} = 0x17;
+				$self->{subtype} = 0x3;
+				$self->{data} = $data;
+				$self->{reqid} = 0;
+				$self->{reqdata}->[0x17]->{pack("N", 0)} = "";
+				return Net::OSCAR::Callbacks::process_snac($self, $snac);
+			} else {
+				return Net::OSCAR::Callbacks::process_snac($self, $self->snac_decode($data));
+			}
+		}
+	}
+}
+
+sub ready($) {
+	my($self) = shift;
+
+	return if $self->{sentready}++;
+	$self->log_print(OSCAR_DBG_DEBUG, "Sending client ready.");
+	if($self->{conntype} != CONNTYPE_BOS) {
+		$self->snac_put(family => 0x1, subtype => 0x2, data => pack("n*",
+			1, 3, 0x10, 0x47B, $self->{conntype}, 1, 0x10, 0x47B
+		));
+	} else {
+		$self->snac_put(family => 0x1, subtype => 0x2, data => pack("n*", 
+			1, 3, 0x110, 0x47B, 13, 1, 0x110, 0x47B,
+			2, 1, 0x101, 0x47B, 3, 1, 0x110, 0x47B,
+			4, 1, 0x110, 0x47B, 6, 1, 0x110, 0x47B,
+			8, 1, 0x104, 1, 9, 1, 0x110, 0x47B,
+			0xA, 1, 0x110, 0x47B, 0xB, 1, 0x104, 1,
+			0xC, 1, 0x104, 1
+		));
+	}
+}
+
+sub session($) { return shift->{session}; }
+
+1;

plugins/Net-OSCAR/Net/OSCAR/OldPerl.pm

@@ -0,0 +1,8 @@
+# Perl 5.005 apparently has a problem with 'use constant' subs not being
+# recognized properly, so we add some gunk to force perl to recognize them as subs.
+# Also, the n/a* template was added to unpack in 5.6, so we roll our own version of
+# that.  It also seems to have weird issues with four-argument substr.
+
+package Net::OSCAR::OldPerl;
+
+1;

plugins/Net-OSCAR/Net/OSCAR/Screenname.pm

@@ -0,0 +1,40 @@
+package Net::OSCAR::Screenname;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw($VERSION);
+
+use Net::OSCAR::Common qw(normalize);
+use Net::OSCAR::OldPerl;
+
+use overload
+	"cmp" => "compare",
+	'""' => "stringify",
+	"bool" => "boolify";
+
+sub new($$) {
+	return $_[1] if ref($_[0]) or UNIVERSAL::isa($_[1], "Net::OSCAR::Screenname");
+	my $class = ref($_[0]) || $_[0] || "Net::OSCAR::Screenname";
+	shift;
+	my $name = "$_[0]"; # Make doubleplus sure that name isn't one of us
+	my $self = \$name;
+	bless $self, $class;
+	return $self;
+}
+
+sub compare {
+	my($self, $comparand) = @_;
+
+	return normalize($$self) cmp normalize($comparand);
+}
+
+sub stringify { my $self = shift; return $$self; }
+
+sub boolify {
+	my $self = shift;
+	return 0 if !defined($$self) or $$self eq "" or $$self eq "0";
+	return 1;
+}
+
+1;

plugins/Net-OSCAR/Net/OSCAR/TLV.pm

@@ -0,0 +1,118 @@
+package Net::OSCAR::TLV;
+
+$VERSION = '0.62';
+
+use strict;
+use vars qw($VERSION);
+
+# Extra arguments: an optional scalar which modifies the behavior of $self->{foo}->{bar} = "baz"
+# Iff foo doesn't exist, the scalar will be evaluated and assigned as the value of foo.
+# So, instead of having foo be {bar => "baz"} , it could be another TLV.
+# It will be given the key bar.
+sub new {
+	my $pkg = shift;
+	my $self = $pkg->TIEHASH(@_);
+}
+
+
+sub getorder {
+	my $self = shift;
+	return map { (unpack("n", $_))[0] } @{$self->{ORDER}};
+}
+
+sub setorder {
+	my $self = shift;
+
+	# Anything not specified gets shoved at the end
+	my @end = grep { my $inbud = $_; not grep { $_ eq $inbud } @_ } @{$self->{ORDER}};
+
+	@{$self->{ORDER}} = map { pack("n", $_) } @_;
+	push @{$self->{ORDER}}, @end;
+}
+
+sub TIEHASH {
+	my $class = shift;
+	my $self = { DATA => {}, ORDER => [], CURRKEY => -1, AUTOVIVIFY => shift};
+	return bless $self, $class;
+}
+
+sub FETCH {
+	my($self, $key) = @_;
+	$self->{DATA}->{pack("n", $key)};
+}
+
+sub STORE {
+	my($self, $key, $value) = @_;
+	my($normalkey) = pack("n", $key);
+
+	#print STDERR "Storing: ", Data::Dumper->Dump([$value], ["${self}->{$key}"]);
+	if(!exists $self->{DATA}->{$normalkey}) {
+		if(
+			$self->{AUTOVIVIFY} and
+			ref($value) eq "HASH" and
+			!tied(%$value) and
+			scalar keys %$value == 0
+		) {
+			#print STDERR "Autovivifying $key: $self->{AUTOVIVIFY}\n";
+			eval $self->{AUTOVIVIFY};
+			#print STDERR "New value: ", Data::Dumper->Dump([$self->{DATA}->{$normalkey}], ["${self}->{$key}"]);
+		} else {
+			#print STDERR "Not autovivifying $key.\n";
+			#print STDERR "No autovivify.\n" unless $self->{AUTOVIVIFY};
+			#printf STDERR "ref(\$value) eq %s\n", ref($value) unless ref($value) eq "HASH";
+			#print STDERR "tied(\%\$value)\n" unless !tied(%$value);
+			#printf STDERR "scalar keys \%\$value == %d\n", scalar keys %$value unless scalar keys %$value == 0;
+		}
+		push @{$self->{ORDER}}, $normalkey;
+	} else {
+		#print STDERR "Not autovivifying $key: already exists\n";
+	}
+	$self->{DATA}->{$normalkey} = $value;
+	return $value;
+}
+
+sub DELETE {
+	my($self, $key) = @_;
+	my($packedkey) = pack("n", $key);
+	delete $self->{DATA}->{$packedkey};
+	for(my $i = 0; $i < scalar @{$self->{ORDER}}; $i++) {
+		next unless $packedkey eq $self->{ORDER}->[$i];
+		splice(@{$self->{ORDER}}, $i, 1);
+		last;
+	}
+}
+
+sub CLEAR {
+	my $self = shift;
+	$self->{DATA} = {};
+	$self->{ORDER} = [];
+	$self->{CURRKEY} = -1;
+	return $self;
+}
+
+sub EXISTS {
+	my($self, $key) = @_;
+	my($packedkey) = pack("n", $key);
+	return exists $self->{DATA}->{$packedkey};
+}
+
+sub FIRSTKEY {
+	$_[0]->{CURRKEY} = -1;
+	goto &NEXTKEY;
+}
+
+sub NEXTKEY {
+	my ($self, $currkey) = @_;
+	$currkey = ++$self->{CURRKEY};
+	my ($packedkey) = pack("n", $currkey);
+
+	if($currkey >= scalar @{$self->{ORDER}}) {
+		return wantarray ? () : undef;
+	} else {
+		my $packedkey = $self->{ORDER}->[$currkey];
+		($currkey) = unpack("n", $packedkey);
+		return wantarray ? ($currkey, $self->{DATA}->{$packedkey}) : $currkey;
+	}
+}
+
+1;

plugins/Net-OSCAR/Net/OSCAR/_BLInternal.pm

@@ -0,0 +1,377 @@
+package Net::OSCAR::_BLInternal;
+
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::OldPerl;
+
+# Heh, this is fun.
+# This is what we use as the first arg to Net::OSCAR::TLV when creating a new BLI.
+# What this does is make it so that the hashref-keys (keys whose values are hashrefs)
+# of the root BLI will be Net::OSCAR::TLVs.  Hashref-keys of those N::O::TLVs will also
+# be N::O::TLVs.  Same for the next level.  The level after that gets a hashref
+# with two keys: name is the empty string and data is a N::O::TLV.
+# 
+# Here's a better way to picture it:
+#    $bli = Net::OSCAR::TLV->new(BLI_AUTOVIV);
+#    $bli->{$type}->{$gid}->{$bid}->{data}->{0xABCD} = "foo";
+#          ^^^^^^^  ^^^^^^  ^^^^^^  ^^^^^^
+#          TLV      TLV     {name,  TLV
+#                            data}      
+#
+# The subkeys are automagically TLV-ified.
+#
+use constant BLI_AUTOVIV =>
+	q!
+		tie %$value, ref($self), q#
+			tie %$value, ref($self), q^
+				$value->{name} = ""; $value->{data} = Net::OSCAR::Common::tlvtie;
+			^
+		#
+	!;
+
+sub blparse($$) {
+	my($session, $data) = @_;
+
+	# This stuff was figured out more through sheer perversity
+	# than by actually understanding what all the random bits do.
+
+	$session->{visibility} = VISMODE_PERMITALL; # If we don't have p/d data, this is default.
+
+	delete $session->{blinternal};
+	$session->{blinternal} = tlvtie BLI_AUTOVIV;
+
+	while(length($data) > 4) {
+		my($name) = unpack("n/a*", $data);
+		substr($data, 0, 2+length($name)) = "";
+		my($gid, $bid, $type, $sublen) = unpack("n4", substr($data, 0, 8, ""));
+		my $typedata = tlv_decode(substr($data, 0, $sublen, ""));
+
+		$session->{blinternal}->{$type}->{$gid}->{$bid}->{name} = $name if $name;
+		while(my($key, $value) = each %$typedata) {
+			$session->{blinternal}->{$type}->{$gid}->{$bid}->{data}->{$key} = $value;
+		}
+		$session->log_printf(OSCAR_DBG_DEBUG, "Got BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $name, $type, $gid, $bid, $sublen, hexdump(tlv_encode($typedata)));
+	}
+
+	return BLI_to_NO($session);
+}
+
+# Buddylist-Internal -> Net::OSCAR
+# Sets various $session hashkeys from blinternal.
+# That's what Brian Bli-to-no'd do. ;)
+sub BLI_to_NO($) {
+	my($session) = @_;
+	my $bli = $session->{blinternal};
+
+	delete $session->{buddies};
+	delete $session->{permit};
+	delete $session->{deny};
+	delete $session->{visibility};
+	delete $session->{groupperms};
+	delete $session->{profile};
+	delete $session->{appdata};
+	delete $session->{showidle};
+
+	$session->{buddies} = bltie(1);
+	$session->{permit} = bltie;
+	$session->{deny} = bltie;
+
+
+	if(exists $bli->{2}) {
+		foreach my $bid(keys(%{$bli->{2}->{0}})) {
+			$session->{permit}->{$bli->{2}->{0}->{$bid}->{name}} = {buddyid => $bid};
+		}
+	}
+
+	if(exists $bli->{3}) {
+		foreach my $bid(keys(%{$bli->{3}->{0}})) {
+			$session->{deny}->{$bli->{3}->{0}->{$bid}->{name}} = {buddyid => $bid};
+		}
+	}
+
+	if(exists $bli->{4} and (my($visbid) = keys %{$bli->{4}->{0}})) {
+		my $typedata = $bli->{4}->{0}->{$visbid}->{data};
+		($session->{visibility}) = unpack("C", $typedata->{0xCA}) if $typedata->{0xCA};
+
+		my $groupperms = $typedata->{0xCB};
+		($session->{groupperms}) = unpack("N", $groupperms) if $groupperms;
+		$session->{profile} = $typedata->{0x0100} if exists($typedata->{0x0100});
+
+		delete $typedata->{0xCB};
+		delete $typedata->{0xCA};
+		delete $typedata->{0x0100};
+		$session->{appdata} = $typedata;
+
+		$session->set_info($session->{profile}) if exists($session->{profile});
+	} else {
+		# No permit info - we permit everyone
+		$session->{visibility} = VISMODE_PERMITALL;
+		$session->{groupperms} = 0xFFFFFFFF;
+	}
+
+	if(exists $bli->{5}) {
+		# Not yet implemented
+		($session->{showidle}) = unpack("N", $bli->{5}->{0}->{19719}->{data}->{0xC9} || pack("N", 1));
+	}
+
+	my @gids = unpack("n*", (exists($bli->{1}) and exists($bli->{1}->{0}) and exists($bli->{1}->{0}->{0}) and exists($bli->{1}->{0}->{0}->{data}->{0xC8})) ? $bli->{1}->{0}->{0}->{data}->{0xC8} : "");
+	push @gids, grep { # Find everything...
+		my $ingrp = $_;
+		not grep { # That's not in the 0xC8 GID list...
+			$_ == $ingrp
+		} @gids
+	} grep { # Other than GID 0...
+		$_ != 0
+	} keys %{exists($bli->{1}) ? $bli->{1} : {}}; # That we have a type 1 entry for
+
+	foreach my $gid(@gids) {
+		next unless exists($bli->{1}->{$gid});
+		my $group = $bli->{1}->{$gid}->{0}->{name};
+
+		if(!$group) {
+			$bli->{1}->{$gid}->{0}->{name} = $group = sprintf "Group 0x%04X", $gid;
+			$session->log_printf(OSCAR_DBG_WARN, "Couldn't get group name for group 0x%04X", $gid);
+		}
+		$session->{buddies}->{$group} ||= {};
+		my $entry = $session->{buddies}->{$group};
+
+		$entry->{groupid} = $gid;
+		$entry->{members} = bltie unless $entry->{members};
+		$entry->{data} = $bli->{1}->{$gid}->{0}->{data};
+
+		my @bids = unpack("n*", $bli->{1}->{$gid}->{0}->{data}->{0xC8} || "");
+		delete $bli->{1}->{$gid}->{0}->{data}->{0xC8};
+
+		push @bids, grep { # Find everything...
+			my $inbud = $_;
+			not grep { # That's not in the 0xC8 BID list...
+				$_ == $inbud
+			} @bids
+		} keys %{exists($bli->{0}->{$gid}) ? $bli->{0}->{$gid} : {}}; # That we have a type 0 entry for in this GID
+
+		foreach my $bid(@bids) {
+			# Yeah, this next condition seems impossible, but I've seen it happen
+			next unless exists($bli->{0}->{$gid}) and exists($bli->{0}->{$gid}->{$bid});
+
+			my $buddy = $bli->{0}->{$gid}->{$bid};
+
+			my $comment = undef;
+			$comment = $buddy->{data}->{0x13C} if exists($buddy->{data}->{0x13C});
+			delete $buddy->{data}->{0x13C};
+
+			$session->{buddies}->{$group}->{members}->{$buddy->{name}} ||= {};
+			my $entry = $session->{buddies}->{$group}->{members}->{$buddy->{name}};
+			$entry->{buddyid} = $bid;
+			$entry->{online} = 0 unless exists($entry->{online});
+			$entry->{comment} = $comment;
+			$entry->{data} = $buddy->{data};
+		}
+	}
+
+	return 1;
+}
+
+# Gee, guess what this does?  Hint: see sub BLI_to_NO.
+sub NO_to_BLI($) {
+	my $session = shift;
+
+	my $bli = tlvtie BLI_AUTOVIV;
+
+	foreach my $permit (keys %{$session->{permit}}) {
+		$bli->{2}->{0}->{$session->{permit}->{$permit}->{buddyid}}->{name} = $permit;
+	}
+
+	foreach my $deny (keys %{$session->{deny}}) {
+		$bli->{3}->{0}->{$session->{deny}->{$deny}->{buddyid}}->{name} = $deny;
+	}
+
+	my $vistype;
+	$vistype = (keys %{$session->{blinternal}->{4}->{0}})[0] if exists($session->{blinternal}->{4}) and exists($session->{blinternal}->{4}->{0}) and scalar keys %{$session->{blinternal}->{4}->{0}};
+	$vistype ||= int(rand(30000)) + 1;
+	$bli->{4}->{0}->{$vistype}->{data}->{0xCA} = pack("C", $session->{visibility} || VISMODE_PERMITALL);
+	$bli->{4}->{0}->{$vistype}->{data}->{0xCB} = pack("N", $session->{groupperms} || 0xFFFFFFFF);
+	$bli->{4}->{0}->{$vistype}->{data}->{0x0100} = $session->{profile} if $session->{profile};
+	foreach my $appdata(keys %{$session->{appdata}}) {
+		$bli->{4}->{0}->{$vistype}->{data}->{$appdata} = $session->{appdata}->{$appdata};
+	}
+
+	if(exists($session->{showidle})) {
+		$bli->{5}->{0}->{0x4D07}->{data}->{0xC9} = pack("N", $session->{showidle});
+	}
+
+	$bli->{1}->{0}->{0}->{data}->{0xC8} = pack("n*", map { $_->{groupid} } values %{$session->{buddies}});
+	foreach my $group(keys %{$session->{buddies}}) {
+		my $gid = $session->{buddies}->{$group}->{groupid};
+		$bli->{1}->{$gid}->{0}->{name} = $group;
+		$bli->{1}->{$gid}->{0}->{data}->{0xC8} = pack("n*",
+			map { $_->{buddyid} }
+			values %{$session->{buddies}->{$group}->{members}});
+
+		foreach my $buddy(keys %{$session->{buddies}->{$group}->{members}}) {
+			my $bid = $session->{buddies}->{$group}->{members}->{$buddy}->{buddyid};
+			next unless $bid;
+			$bli->{0}->{$gid}->{$bid}->{name} = $buddy;
+			while(my ($key, $value) = each(%{$session->{buddies}->{$group}->{members}->{$buddy}->{data}})) {
+				$bli->{0}->{$gid}->{$bid}->{data}->{$key} = $value;
+			}
+			$bli->{0}->{$gid}->{$bid}->{data}->{0x13C} = $session->{buddies}->{$group}->{members}->{$buddy}->{comment} if defined $session->{buddies}->{$group}->{members}->{$buddy}->{comment};
+		}
+	}
+
+	BLI_to_OSCAR($session, $bli);
+}
+
+# Send changes to BLI over to OSCAR
+sub BLI_to_OSCAR($$) {
+	my($session, $newbli) = @_;
+	my $oldbli = $session->{blinternal};
+	my $oscar = $session->{bos};
+	my $modcount = 0;
+	my (@adds, @modifies, @deletes);
+
+	$oscar->snac_put(family => 0x13, subtype => 0x11); # Begin BL mods
+
+	# First, delete stuff that we no longer use and modify everything else
+	foreach my $type(keys %$oldbli) {
+		foreach my $gid(keys %{$oldbli->{$type}}) {
+			foreach my $bid(keys %{$oldbli->{$type}->{$gid}}) {
+				my $oldentry = $oldbli->{$type}->{$gid}->{$bid};
+				my $olddata = tlv_encode($oldentry->{data});
+				$session->log_printf(OSCAR_DBG_DEBUG, "Old BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $oldentry->{name}, $type, $gid, $bid, length($olddata), hexdump($olddata));
+				my $delete = 0;
+				if(exists($newbli->{$type}) and exists($newbli->{$type}->{$gid}) and exists($newbli->{$type}->{$gid}->{$bid})) {
+					my $newentry = $newbli->{$type}->{$gid}->{$bid};
+					my $newdata = tlv_encode($newentry->{data});
+					$session->log_printf(OSCAR_DBG_DEBUG, "New BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $newentry->{name}, $type, $gid, $bid, length($newdata), hexdump($newdata));
+
+					next if
+						$newentry->{name} eq $oldentry->{name}
+					  and	$newdata eq $olddata;
+
+					# Apparently, we can't modify the name of a buddylist entry?
+					if($newentry->{name} ne $oldentry->{name}) {
+						$delete = 1;
+					} else {
+						$session->log_print(OSCAR_DBG_DEBUG, "Modifying.");
+
+						push @modifies, {
+							reqdata => {desc => "modifying ".(BUDTYPES)[$type]." $newentry->{name}", type => $type, gid => $gid, bid => $bid},
+							data =>
+								pack("na* nnn na*",
+									length($newentry->{name}),
+									$newentry->{name},
+									$gid,
+									$bid,
+									$type,
+									length($newdata),
+									$newdata
+								)
+						};
+					}
+				} else {
+					$delete = 1;
+				}
+
+				if($delete) {
+					$session->log_print(OSCAR_DBG_DEBUG, "Deleting.");
+
+					push @deletes, {
+						reqdata => {desc => "deleting ".(BUDTYPES)[$type]." $oldentry->{name}", type => $type, gid => $gid, bid => $bid},
+						data => 
+							pack("na* nnn na*",
+								length($oldentry->{name}),
+								$oldentry->{name},
+								$gid,
+								$bid,
+								$type,
+								length($olddata),
+								$olddata
+							)
+					};
+				}
+			}
+		}
+	}
+
+	# Now, add the new stuff
+	foreach my $type(keys %$newbli) {
+		foreach my $gid(keys %{$newbli->{$type}}) {
+			foreach my $bid(keys %{$newbli->{$type}->{$gid}}) {
+				next if exists($oldbli->{$type}) and exists($oldbli->{$type}->{$gid}) and exists($oldbli->{$type}->{$gid}->{$bid}) and $oldbli->{$type}->{$gid}->{$bid}->{name} eq $newbli->{$type}->{$gid}->{$bid}->{name};
+				my $entry = $newbli->{$type}->{$gid}->{$bid};
+				my $data = tlv_encode($entry->{data});
+
+				$session->log_printf(OSCAR_DBG_DEBUG, "New BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $entry->{name}, $type, $gid, $bid, length($data), hexdump($data));
+
+				push @adds, {
+					reqdata => {desc => "adding ".(BUDTYPES)[$type]." $entry->{name}", type => $type, gid => $gid, bid => $bid},
+					data =>
+						pack("na* nnn na*",
+							length($entry->{name}),
+							$entry->{name},
+							$gid,
+							$bid,
+							$type,
+							length($data),
+							$data
+						)
+				};
+			}
+		}
+	}
+
+	# Actually send the changes.  Don't send more than 7K in a single SNAC.
+	# FLAP size limit is 8K, but that includes headers - good to have a safety margin
+	foreach my $type(0xA, 0x8, 0x9) {
+		my $changelist;
+		if($type == 0x8) {
+			$changelist = \@adds;
+		} elsif($type == 0x9) {
+			$changelist = \@modifies;
+		} else {
+			$changelist = \@deletes;
+		}
+
+		my($packet, @reqdata, @packets);
+		foreach my $change(@$changelist) {
+			$packet .= $change->{data};
+			push @reqdata, $change->{reqdata};
+
+			if(length($packet) > 7*1024) {
+				push @packets, {
+					data => $packet,
+					reqdata => [@reqdata],
+				};
+				$packet = "";
+				@reqdata = ();
+			}
+		}
+		if($packet) {
+			push @packets, {
+				data => $packet,
+				reqdata => [@reqdata],
+			};
+		}
+		$modcount += @packets;
+
+		foreach my $packet(@packets) {
+			$oscar->snac_put(
+				family => 0x13,
+				subtype => $type,
+				reqdata => $packet->{reqdata},
+				data => $packet->{data}
+			);
+		}
+	}
+
+	$oscar->snac_put(family => 0x13, subtype => 0x12); # End BL mods
+
+	$session->{blold} = $oldbli;
+	$session->{blinternal} = $newbli;
+
+	# OSCAR doesn't send an 0x13/0xE if we don't actually modify anything.
+	$session->callback_buddylist_ok() unless $modcount;
+
+	$session->{budmods} = $modcount;
+}
+
+1;

plugins/Sound.pl

@@ -0,0 +1,34 @@
+package Sound;
+
+use warnings;
+use Milkbone;
+eval "use Win32::Sound" if $^O =~ /Win32/;
+
+register_hook("signed_in", sub { play_sound("signed_in"); });
+register_hook("protocol_go_away", sub { play_sound("go_away"); });
+register_hook("protocol_return", sub { play_sound("return"); });
+register_hook("msg_in", sub { play_sound("msg_in"); });
+register_hook("protocol_send_im", sub { play_sound("send_im"); });
+register_hook("buddy_in", sub { play_sound("buddy_in"); });
+register_hook("buddy_out", sub { play_sound("buddy_out"); });
+register_hook("error", sub { play_sound("error"); });
+register_hook("protocol_signoff", sub { play_sound("signoff"); });
+
+sub play_sound
+{
+	return if hook("protocol_away_status") and !option("SoundsWhileAway") and $_[0] ne "go_away";
+
+	my ($name) = @_;
+	my $path = "sounds/$name.wav";
+
+	return unless -e $path;
+
+	if($^O =~ m/Win32/)
+	{
+	    Win32::Sound::Play($path, 0x0001 | 0x0010);
+	}
+	else
+	{
+	    exec 'play', $path unless fork();
+	}
+}

plugins/Templog.pl

@@ -0,0 +1,27 @@
+package Templog;
+
+use Milkbone;
+
+# print `pwd`;
+
+register_hook("buddy_in", sub {
+    return unless $ARGS{-buddy} =~ /tiff/i;
+
+    open(LOG, "log.txt");
+
+    print LOG "$ARGS{-buddy} logged in at " . time . "\n\n";
+});
+
+register_hook("buddy_out", sub {
+    return unless $ARGS{-buddy} =~ /tiff/i;
+
+    open(LOG, "log.txt");
+
+    print LOG "$ARGS{-buddy} logged out at " . time . "\n\n";
+});
+
+register_hook("msg_in", sub {
+    open(LOG, "log.txt");
+
+    print LOG "$ARGS{-user} sent this at " . time . ": $ARGS{-msg}\n\n";
+});

plugins/Tk-About/Milkbone/About.pm

@@ -0,0 +1,41 @@
+# milkbone - about box
+
+package Milkbone::About;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBAbout';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	my $text = $self->Text(-font => "arial 8", -bg => "white")->pack(-expand => 1, -fill => 'both');
+	$self->bind("<Escape>", [$self, "destroy"]);
+	$text->insert('end', <<"END");
+milkbone $Milkbone::VERSION is a super-suave AIM client written in Perl and utilizing a wickedly structured internal architecture.  milkbone was begun with a dream of making the greatest IM system ever.  And we've done it.  Here it is.  The greatest ever.
+
+milkbone makes people happy.  You don't believe me?
+
+	Gym Hero84: i feel happy
+
+how's that?
+END
+	$self->Button(-text => "dismiss", -command => [ $self, "destroy"])->pack(-pady => 3)->focus;
+}
+
+1;

plugins/Tk-About/Tk-About.pl

@@ -0,0 +1,8 @@
+package TkAbout;
+
+use Milkbone;
+use Milkbone::About;
+
+my $mw = hook("tk_getmain");
+
+register_hook "show_about", sub { $mw->MBAbout->focus; };

plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm

@@ -0,0 +1,77 @@
+package Milkbone::AddBuddy;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBAddBuddy';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+}
+
+sub on_add {
+    my ($self) = @_;
+
+    my $name = $self->{entry}->get();
+	my $group = $self->{group};
+    hook("protocol_add_buddy", -group => $group, -buddy => $name);    
+    hook("protocol_commit_blist");
+	$self->destroy;
+}
+
+sub init
+{
+	my ($self) = @_;
+
+	$self->withdraw;
+
+	my $groups = hook("protocol_get_groups");
+	$self->configure(-title => "Add Buddy");
+	$self->{group} = "";
+	$self->focus();
+	$self->Frame->pack(-expand => 1, -fill => 'both');
+	$self->Frame->pack(-expand => 1, -fill => 'both');
+	$self->{buttons} = $self->Frame;
+
+	$self->Label(-text => 'Screen name:', -anchor=>'w')->pack();
+	$self->{entry} = $self->Entry( 
+		-background => 'white', -width => 16, -takefocus => 1)->pack(-expand => 1, -fill => 'both', -padx => 4);
+
+	$self->Label(-text => 'Group:', -anchor=>'w')->pack();
+	$self->{list} = $self->JBrowseEntry(-width => 16, -takefocus => 1, -variable => \$self->{group},
+		-choices => $groups)->pack(-expand => 1, -fill => 'both');
+	
+	$self->{buttons}->Button(-text => "Cancel", -command => [ $self, "destroy"])->pack(-pady => 6,  -padx=>6, -side=>'right');
+	$self->{buttons}->Button(-text => "Add", -command => [ $self, "on_add"])->pack(-pady => 6,  -padx=>6, -side=>'right');
+	$self->{buttons}->pack;
+	
+	$self->bind('<Return>' => [$self, 'on_add']);
+	$self->bind("<Escape>" => [$self, "destroy"]);
+	hook("tk_seticon", -wnd => $self);
+
+	$self->{group} = $groups->[0];
+
+	$self->update;
+	$self->geometry("+" . int(($self->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($self->screenheight() / 2) - int($self->height() / 2)) );
+	$self->deiconify;
+	$self->resizable(0, 0);
+
+	$self->update();
+	$self->{entry}->focus;
+}
+
+1;

plugins/Tk-AddBuddy/Milkbone/AddBuddyGroup.pm

@@ -0,0 +1,64 @@
+package Milkbone::AddBuddyGroup;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBAddBuddyGroup';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+}
+
+sub on_add {
+    my ($self) = @_;
+
+    my $group = $self->{entry}->get();
+    hook("protocol_add_buddy_group", -group => $group);    
+    hook("protocol_commit_blist");
+	$self->destroy;
+}
+
+sub init
+{
+	my ($self) = @_;
+
+	$self->withdraw;
+
+	$self->configure(-title => "Add Group");
+	$self->focus();
+
+	$self->Label(-text => 'Group name:', -anchor=>'w')->pack();
+	$self->{entry} = $self->Entry( 
+		-background => 'white', -width => 16, -takefocus => 1)->pack(-expand => 1, -fill => 'both', -padx => 4);
+	
+	$self->Button(-text => "Cancel", -command => [ $self, "destroy"])->pack(-pady => 6,  -padx=>6, -side=>'right');
+	$self->Button(-text => "Add", -command => [ $self, "on_add"])->pack(-pady => 6,  -padx=>6, -side=>'right');
+	
+	$self->bind('<Return>' => [$self, 'on_add']);
+	$self->bind("<Escape>" => [$self, "destroy"]);
+	hook("tk_seticon", -wnd => $self);
+
+	$self->update;
+	$self->geometry("+" . int(($self->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($self->screenheight() / 2) - int($self->height() / 2)) );
+	$self->deiconify;
+	$self->resizable(0, 0);
+
+	$self->update();
+	$self->{entry}->focus;
+}
+
+1;

plugins/Tk-AddBuddy/Tk-AddBuddy.pl

@@ -0,0 +1,22 @@
+package TkAddBuddy;
+
+use warnings;
+use strict;
+
+use Milkbone;
+use Milkbone::AddBuddy;
+use Milkbone::AddBuddyGroup;
+
+register_hook("dlg_add_buddy", sub {
+	my $parent = $ARGS{-parent};
+
+	$parent->MBAddBuddy->init;
+});
+
+register_hook("dlg_add_buddy_group", sub {
+	my $parent = $ARGS{-parent};
+
+	$parent->MBAddBuddyGroup->init;
+});
+
+1;

plugins/Tk-BList/HTTP/Lite.pm

@@ -0,0 +1,693 @@
+
+#
+# HTTP::Lite.pm
+#
+# $Id$
+#
+# $Log$
+# Revision 1.1  2003/07/11 20:17:31  milkbone57
+# Initial revision
+#
+# Revision 1.1.1.1  2003/04/15 20:09:27  milkbone57
+# Initial Checkin
+#
+# Revision 1.1.1.1  2003/04/10 22:51:45  milkbone57
+# no message
+#
+# Revision 1.7  2000/12/21 18:05:09  rhooper
+# FIxed post form MIME-Type -- was application/x-www-urlencoded should
+# have been x-www-form-urlencoded.
+#
+# Revision 1.6  2000/11/02 01:47:58  rhooper
+# Fixed a greedy regular expression in the URL decoder.  URLs with :// embedded now work.
+#
+# Revision 1.5  2000/10/31 01:27:03  rhooper
+# added proxy port support.
+#
+# Revision 1.4  2000/09/29 03:47:53  rhooper
+# Requests without a terminating CR or LF are now properly handled.
+# HTTP/1.1 chunked mode transfers are now supported
+# Host: headers are properly added to all requests
+# Proxy support has been added
+# Significant test code updates
+#
+# Revision 1.3  2000/09/09 18:06:55  rhooper
+# Revision 1.2  2000/08/28 02:46:05  rhooper
+# Revision 1.1  2000/08/28 02:43:57  rhooper
+# Initial revision
+#
+
+package HTTP::Lite;
+
+use vars qw($VERSION);
+use strict qw(vars);
+
+$VERSION = "1.0.0";
+my $CRLF = "\r\n";
+
+# Required modules for Network I/O
+use Socket 1.3;
+use Fcntl;
+use Errno qw(EAGAIN);
+
+# Forward declarations
+sub prepare_post;
+sub http_writeline;
+sub http_readline;
+
+sub new 
+{
+  my $self = {};
+  bless $self;
+  $self->initialize();
+  return $self;
+}
+
+sub initialize
+{
+  my $self = shift;
+  foreach my $var ("body", "request", "content", "status", "proxy",
+    "proxyport", "resp-protocol", "error-message", "response", 
+    "resp-headers")
+  {
+    $self->{$var} = undef;
+  }
+  $self->{method} = "GET";
+  $self->{timeout} = 120;
+  $self->{headers} = { 'User-Agent' => "HTTP::Lite/$VERSION" };
+  $self->{HTTPReadBuffer} = "";
+}
+
+sub reset
+{
+  my $self = shift;
+  $self->initialize;
+}
+
+
+# URL-encode data
+sub escape {
+  my $toencode = shift;
+  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+  return $toencode;
+}
+
+sub request
+{
+  my ($self, $url) = @_;
+  
+  my $method = $self->{method};
+
+  # Parse URL 
+  my ($protocol,$host,$junk,$port,$object) = 
+    $url =~ m{^([^:/]+)://([^/:]*)(:(\d+))?(/.*)$};
+
+  # Only HTTP is supported here
+  if ($protocol ne "http")
+  {
+    warn "Only http is supported by HTTP::Lite";
+    return undef;
+  }
+  
+  # Setup the connection
+  my $proto = getprotobyname('tcp');
+  my $fhname = $url . localtime;
+  my $fh = *$fhname;
+  socket($fh, PF_INET, SOCK_STREAM, $proto);
+  $port = 80 if !$port;
+
+  my $connecthost = $self->{'proxy'} || $host;
+  $connecthost = $connecthost ? $connecthost : $host;
+  my $connectport = $self->{'proxyport'} || $port;
+  $connectport = $connectport ? $connectport : $port;
+  my $addr = inet_aton($connecthost);
+  if (!$addr) {
+    close($fh);
+    return undef;
+  }
+  if ($connecthost ne $host)
+  {
+    # if proxy active, use full URL as object to request
+    $object = "$url";
+  }
+
+  my $sin = sockaddr_in($connectport,$addr);
+  connect($fh, $sin) || return undef;
+  # Set nonblocking IO on the handle to allow timeouts
+  if ( $^O ne "MSWin32" ) {
+    fcntl($fh, F_SETFL, O_NONBLOCK);
+  }
+
+  # Start the request (HTTP/1.1 mode)
+  http_writeline($fh, "$method $object HTTP/1.1$CRLF");
+
+  # Add some required headers
+  # we only support a single transaction per request in this version.
+  $self->add_req_header("Connection", "close");    
+  $self->add_req_header("Host", $host);
+  $self->add_req_header("Accept", "*/*");
+    
+  # Output headers
+  my $headerref = $self->{headers};
+  foreach my $header (keys %$headerref)
+  {
+    http_writeline($fh, $header.": ".$$headerref{$header}."$CRLF");
+  }
+  
+  # Handle Content-type and Content-Length seperately
+  if (defined($self->{content}))
+  {
+    http_writeline($fh, "Content-Length: ".length($self->{content})."$CRLF");
+  }
+  http_writeline($fh, "$CRLF");
+  
+  # Output content, if any
+  if (defined($self->{content}))
+  {
+    http_writeline($fh, $self->{content});
+  }
+  
+  # Read response from server
+  my $headmode=1;
+  my $chunkmode=undef;
+  my $chunksize=0;
+  my $chunklength=0;
+  my $chunk;
+  my $line = 0;
+  while ($_ = $self->http_readline($fh))
+  {
+    #print "reading: $chunkmode, $chunksize, $chunklength, $headmode, ".
+    #	length($self->{body}).": //$_//\n";
+    $line++;
+    if ($line == 1)
+    {
+      my ($proto,$status,$message) = split(' ', $_, 3);
+      $self->{status}=$status;
+      $self->{'resp-protocol'}=$proto;
+      $self->{'error-message'}=$message;
+      next;
+    } 
+    $self->{response} .= $_;
+    if ($_ =~ /^[\r\n]*$/ && ($headmode || $chunkmode eq "entity-header"))
+    {
+      if ($chunkmode)
+      {
+        undef $chunkmode;
+      }
+      $headmode = 0;
+      
+      # Check for Transfer-Encoding
+      my $header = join(' ',@{$self->get_header("Transfer-Encoding")});
+      if ($header =~ /chunked/i)
+      {
+        $chunkmode = "chunksize";
+      }
+      next;
+    }
+    if ($headmode || $chunkmode eq "entity-header")
+    {
+      my ($var,$data) = $_ =~ /^([^:]*):\s*(.*)$/;
+      if (defined($var))
+      {
+        $data =~s/[\r\n]$//g;
+        $var = lc($var);
+        $var =~ s/^(.)|(-.)/&upper($1,$2)/ge;
+        my $hr = ${$self->{'resp-headers'}}{$var};
+        if (!ref($hr))
+        {
+          $hr = [ $data ];
+        }
+        else 
+        {
+          push @{ $hr }, $data;
+        }
+        ${$self->{'resp-headers'}}{$var} = $hr;
+      }
+    } elsif ($chunkmode)
+    {
+      if ($chunkmode eq "chunksize")
+      {
+        $chunksize = $_;
+        $chunksize =~ s/^\s*|;.*$//g;
+        $chunksize =~ s/\s*$//g;
+        $chunksize = hex($chunksize);
+        if ($chunksize == 0)
+        {
+          $chunkmode = "entity-header";
+        } else {
+          $chunkmode = "chunk";
+          $chunklength = 0;
+        }
+      } elsif ($chunkmode eq "chunk")
+      {
+        $chunk .= $_;
+        $chunklength += length($_);
+        if ($chunklength >= $chunksize)
+        {
+          $chunkmode = "chunksize";
+          if ($chunklength > $chunksize)
+          {
+            $chunk = substr($chunk,0,$chunksize);
+          } 
+          elsif ($chunklength == $chunksize && $chunk !~ /$CRLF$/) 
+          {
+            # chunk data is exactly chunksize -- need CRLF still
+            $chunkmode = "ignorecrlf";
+          }
+          $self->{'body'} .= $chunk;
+          $chunk="";
+          $chunklength = 0;
+          $chunksize = "";
+        } 
+      } elsif ($chunkmode eq "ignorecrlf")
+      {
+        $chunkmode = "chunksize";
+      }
+    } else {
+      $self->{body}.=$_;
+    }
+  }
+  close($fh);
+  return $self->{status};
+}
+
+sub add_req_header
+{
+  my $self = shift;
+  my ($header, $value) = @_;
+  
+  ${$self->{headers}}{$header} = $value;
+}
+
+sub get_req_header
+{
+  my $self = shift;
+  my ($header) = @_;
+  
+  return $self->{headers}{$header};
+}
+
+sub delete_req_header
+{
+  my $self = shift;
+  my ($header) = @_;
+  
+  my $exists;
+  if ($exists=defined(${$self->{headers}}{$header}))
+  {
+    delete ${$self->{headers}}{$header};
+  }
+  return $exists;
+}
+
+sub body
+{
+  my $self = shift;
+  return $self->{body};
+}
+
+sub response
+{
+  my $self = shift;
+  return $self->{response};
+}
+
+sub status
+{
+  my $self = shift;
+  return $self->{status};
+}
+
+sub protocol
+{
+  my $self = shift;
+  return $self->{'resp-protocol'};
+}
+
+sub status_message
+{
+  my $self = shift;
+  return $self->{'error-message'};
+}
+
+sub proxy
+{
+  my $self = shift;
+  my ($value) = @_;
+  
+  # Parse URL 
+  my ($protocol,$host,$junk,$port,$object) = 
+    $value =~ m{^(\S+)://([^/:]*)(:(\d+))?(/.*)$};
+  if (!$host)
+  {
+    ($host,$port) = $value =~ /^([^:]+):(.*)$/;
+  }
+
+  $self->{'proxy'} = $host || $value;
+  $self->{'proxyport'} = $port || 80;
+}
+
+sub headers_array
+{
+  my $self = shift;
+  
+  my @array = ();
+  
+  foreach my $header (keys %{$self->{'resp-headers'}})
+  {
+    my $aref = ${$self->{'resp-headers'}}{$header};
+    foreach my $value (@$aref)
+    {
+      push @array, "$header: $value";
+    }
+  }
+  return @array;
+}
+
+sub headers_string
+{
+  my $self = shift;
+  
+  my $string = "";
+  
+  foreach my $header (keys %{$self->{'resp-headers'}})
+  {
+    my $aref = ${$self->{'resp-headers'}}{$header};
+    foreach my $value (@$aref)
+    {
+      $string .= "$header: $value\n";
+    }
+  }
+  return $string;
+}
+
+sub get_header
+{
+  my $self = shift;
+  my $header = shift;
+
+  return $self->{'resp-headers'}{$header};
+}
+
+
+sub prepare_post
+{
+  my $self = shift;
+  my $varref = shift;
+  
+  my $body = "";
+  while (my ($var,$value) = map { escape($_) } each %$varref)
+  {
+    if ($body)
+    {
+      $body .= "&$var=$value";
+    } else {
+      $body = "$var=$value";
+    }
+  }
+  $self->{content} = $body;
+  $self->{headers}{'Content-Type'} = "application/x-www-form-urlencoded"
+    unless defined ($self->{headers}{'Content-Type'}) and 
+    $self->{headers}{'Content-Type'};
+  $self->{method} = "POST";
+}
+
+sub http_writeline
+{
+  my ($fh,$line) = @_;
+  syswrite($fh, $line, length($line));
+}
+
+
+sub http_readline
+{
+  my $self = shift;
+  my ($fh, $timeout) = @_;
+  my $EOL = "\n";
+  
+  # is there a line in the buffer yet?
+  while ($self->{HTTPReadBuffer} !~ /$EOL/)
+  {
+    # nope -- wait for incoming data
+    my ($inbuf,$bits,$chars) = ("","",0);
+    vec($bits,fileno($fh),1)=1;
+    my $nfound = select($bits, undef, $bits, $timeout);
+    if ($nfound == 0)
+    {
+      # Timed out
+      return undef;
+    } else {
+      # Get the data
+      $chars = sysread($fh, $inbuf, 256);
+    }
+    # End of stream?
+    if ($chars <= 0 && !$!{EAGAIN})
+    {
+      last;
+    }
+    # tag data onto end of buffer
+    $self->{HTTPReadBuffer}.=$inbuf;
+  }
+  # get a single line from the buffer
+  my $nlat = index($self->{HTTPReadBuffer}, $EOL);
+  my $newline;
+  my $oldline;
+  if ($nlat > -1)
+  {
+    $newline = substr($self->{HTTPReadBuffer},0,$nlat+1);
+    $oldline = substr($self->{HTTPReadBuffer},$nlat+1);
+  } else {
+    $newline = substr($self->{HTTPReadBuffer},0);
+    $oldline = "";
+  }
+  # and update the buffer
+  $self->{HTTPReadBuffer}=$oldline;
+  # Put the linefeed back on the line and return it
+  return $newline;
+}
+
+sub upper
+{
+  return uc(join("",@_));
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+HTTP::Lite - Lightweight HTTP implementation
+
+=head1 SYNOPSIS
+
+    use HTTP::Lite;
+    $http = new HTTP::Lite;
+    $req = $http->request("http://www.cpan.org/")
+        or die "Unable to get document: $!";
+    print $http->body();
+
+=head1 DESCRIPTION
+
+    HTTP::Lite is a stand-alone lightweight HTTP/1.1
+    implementation for perl.  It is not intended to replace LWP,
+    but rather is intended for use in situations where it is
+    desirable to install the minimal number of modules to
+    achieve HTTP support, or where LWP is not a good candidate
+    due to CPU overhead, such as slower processors.
+
+    HTTP::Lite is ideal for CGI (or mod_perl) programs or for
+    bundling for redistribution with larger packages where only
+    HTTP GET and POST functionality are necessary.
+
+    HTTP::Lite supports basic POST and GET operations only.  As
+    of 0.2.1, HTTP::Lite supports HTTP/1.1 and is compliant with
+    the Host header, necessary for name based virtual hosting.
+    Additionally, HTTP::Live now supports Proxies.
+
+    If you require more functionality, such as FTP or HTTPS,
+    please see libwwwperl (LWP).  LWP is a significantly better
+    and more comprehensive package than HTTP::Lite, and should
+    be used instead of HTTP::Lite whenever possible.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new
+
+This is the constructor for HTTP::Lite.  It presently takes no
+arguments.  A future version of HTTP::Lite might accept
+parameters.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item request ( URL )
+
+Initiates a request to the specified URL.
+
+Returns undef if an I/O error is encountered, otherwise the HTTP
+status code will be returned.  200 series status codes represent
+success, 300 represent temporary errors, 400 represent permanent
+errors, and 500 represent server errors.
+
+See F<http://www.w3.org/Protocols/HTTP/HTRESP.html> for detailled
+information about HTTP status codes.
+
+=item prepare_post
+
+=item add_req_header ( $header, $value )
+
+=item get_req_header ( $header )
+
+=item delete_req_header ( $header )
+
+Add, Delete, or a HTTP header(s) for the request.  These
+functions allow you to override any header.  Presently, Host,
+User-Agent, Content-Type, Accept, and Connection are pre-defined
+by the HTTP::Lite module.  You may not override Host,
+Connection, or Accept.
+
+To provide (proxy) authentication or authorization, you would use:
+
+    use HTTP::Lite;
+    use MIME::Base64;
+    $http = new HTTP::Lite;
+    $encoded = encode_base64('username:password');
+    $http->add_req_header("Authorization", $encoded);
+
+B<NOTE>: The present implementation limits you to one instance
+of each header.
+
+=item body
+
+Returns the body of the document retured by the remote server.
+
+=item headers_array
+
+Returns an array of the HTTP headers returned by the remote
+server.
+
+=item headers_string
+
+Returns a string representation of the HTTP headers returned by
+the remote server.
+
+=item get_header ( $header )
+
+Returns an array of values for the requested header.
+
+B<NOTE>: HTTP requests are not limited to a single instance of
+each header.  As a result, there may be more than one entry for
+every header.
+
+=item protocol
+
+Returns the HTTP protocol identifier, as reported by the remote
+server.  This will generally be either HTTP/1.0 or HTTP/1.1.
+
+=item proxy ( $proxy_server )
+
+The URL or hostname of the proxy to use for the next request.
+
+=item status
+
+Returns the HTTP status code returned by the server.  This is
+also reported as the return value of I<request()>.
+
+=item status_message
+
+Returns the textual description of the status code as returned
+by the server.  The status string is not required to adhere to
+any particular format, although most HTTP servers use a standard
+set of descriptions.
+
+=item response
+
+Returns the entire unparsed HTTP response as returned by the
+server.
+
+=item reset
+
+You must call this prior to re-using an HTTP::Lite handle,
+otherwise the results are undefined.
+
+=head1 EXAMPLES
+
+    # Get and print out the headers and body of the CPAN homepage
+    use HTTP::Lite;
+    $http = new HTTP::Lite;
+    $req = $http->request("http://www.cpan.org/")
+        or die "Unable to get document: $!";
+    die "Request failed ($req): ".$http->status_message()
+      if $req ne "200";
+    @headers = $http->headers_array();
+    $body = $http->body();
+    foreach $header (@headers)
+    {
+      print "$header$CRLF";
+    }
+    print "$CRLF";
+    print "$body$CRLF";
+
+    # POST a query to the dejanews USENET search engine
+    use HTTP::Lite;
+    $http = new HTTP::Lite;
+    %vars = (
+             "QRY" => "perl",
+             "ST" => "MS",
+             "svcclass" => "dncurrent",
+             "DBS" => "2"
+            );
+    $http->prepare_post(\%vars);
+    $req = $http->request("http://www.deja.com/dnquery.xp")
+      or die "Unable to get document: $!";
+    print "req: $req\n";
+    print $http->body();
+
+=head1 UNIMPLEMENTED
+
+    - FTP
+    - HTTPS (SSL)
+    - Authenitcation/Authorizaton/Proxy-Authorization
+      are not directly supported, and require MIME::Base64.
+    - Redirects (Location) are not automatically followed
+    - multipart/form-data POSTs are not supported (necessary for
+      File uploads).
+
+=head1 BUGS
+
+    Some bugs likely still exist.  This is a beta version.
+
+    Large requests are stored in ram, potentially more than once
+    due to HTTP/1.1 chunked transfer mode support.  A future
+    version of this module may support writing requests to a
+    filehandle to avoid excessive disk use.
+
+=head1 ACKNOWLEDGEMENTS
+
+	Marcus I. Ryan	shad@cce-7.cce.iastate.edu
+	michael.kloss@de.adp.com
+
+=head1 AUTHOR
+
+Roy Hooper <rhooper@thetoybox.org>
+
+=head1 SEE ALSO
+
+L<LWP>
+RFC 2068 - HTTP/1.1 -http://www.w3.org/
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Roy Hooper.  All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut

plugins/Tk-BList/Milkbone/BList.pm

@@ -0,0 +1,373 @@
+# milkbone - buddy list toplevel mega-widget
+
+package Milkbone::BList;
+
+use Milkbone;
+
+use warnings;
+use strict;
+
+use HTTP::Lite;
+
+use Tk;
+use Carp;
+use Milkbone::Tree;
+use Milkbone::AddBuddy;
+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 => path("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("160x450+$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 => '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');
+
+	$self->{tree} = $self->Scrolled("MBTree" =>
+		-scrollbars => 'oe',
+		-background => 'white', -font => 'arial 9', -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 => 'arial 9 bold', -fg => 'black', 
+		-selectbackground => "white", -selectforeground => "white", -stylename => 'group');
+	$self->{changed_style} = $self->{tree}->ItemStyle('imagetext', 
+		-background => 'white', -font => 'arial 9', -fg => 'red', 
+		-selectbackground => "darkblue", -selectforeground => "white", -stylename => 'changed');
+	$self->{normal_style} = $self->{tree}->ItemStyle('imagetext', 
+		-background => 'white', -font => 'arial 9', -fg => 'black', 
+		-selectbackground => "darkblue", -selectforeground => "white", -stylename => 'changed');
+
+	$self->{away_button} = "Away Message";
+
+	$self->{away} = $self->Button(-command => [$self, "on_away"], -text => 'Away Message', -font => $self->Font(-family => 'arial', -weight => 'normal'), -border => 1);
+	$self->{away}->pack(-side => 'bottom');
+
+	hook("tk_seticon", -wnd => $self);
+	$away = $self->Photo(-file => path("images/away.bmp"));
+	$blank = $self->Photo(-file => path("images/blank.gif"));
+	$cell = $self->Photo(-file => path("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;

plugins/Tk-BList/Tk-BList.pl

@@ -0,0 +1,67 @@
+package TkBList;
+
+use Tk;
+
+use Milkbone::BList;
+use Milkbone::Tree;
+use Milkbone;
+
+use strict;
+use warnings;
+
+my $mw = hook("tk_getmain");
+
+register_hook("signed_in", sub { 
+
+	my $blist = $mw->MBBList;
+	
+	$blist->init($mw);
+
+	register_hook("buddy_in", sub { Milkbone::BList::on_buddy_in } , {-self => $blist});
+	register_hook("buddy_info_changed", sub { Milkbone::BList::on_buddy_info_changed } , {-self => $blist});
+	register_hook("buddy_out", \&Milkbone::BList::on_buddy_out, {-self => $blist});
+	register_hook("add_blist_menu_item", \&Milkbone::BList::add_blist_menu_item, {-self => $blist});
+	
+	register_hook("protocol_go_away", sub { 
+		my $self = $ARGS{-self};
+		$self->{tree}->configure(-bg => 'gray');
+		$self->{group_style}->configure(-bg => 'gray');
+	}, {-self => $blist});
+
+	register_hook("protocol_return", sub { 
+		my $self = $ARGS{-self};
+		$self->{tree}->configure(-bg => 'white');
+		$self->{group_style}->configure(-bg => 'white');
+		$self->{waiting_msgs} = 0;
+	}, {-self => $blist});
+
+	register_hook("error_fatal", sub {
+		$ARGS{-self}->on_destroy;
+	}, {-self => $blist});
+
+	register_hook("msg_in", sub {
+		$ARGS{-self}->on_msg_in;
+	}, {-self => $blist});
+
+	register_hook("protocol_add_buddy_group", sub {
+		$ARGS{-self}->on_new_group($ARGS{-group});
+	}, {-self => $blist});
+
+	$blist->load_groups;
+
+	register_hook("goodbye", sub { hook("tk_getmain")->after(300, sub { hook("protocol_signoff"); abort }); });
+
+	# $mw->after(30000, [$blist, "on_check_updates"]);
+});
+
+sub reg_change_hook
+{
+	my ($blist) = @_;
+
+	register_hook("get_profile", sub {
+		my ($self, $user, $group) = @ARGS{-self, -user, -group};
+		$self->on_check_info($user, $group);
+	}, {-self => $blist});
+}
+
+1;

plugins/Tk-Chat/Milkbone/Chat.pm

@@ -0,0 +1,58 @@
+package Milkbone::Chat;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBChat';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+}
+
+sub on_msg_in
+{
+}
+
+sub on_buddy_in
+{
+}
+
+sub on_buddy_out
+{
+}
+
+sub init
+{
+	my ($self, $name) = @_;
+
+	$self->withdraw;
+
+	$self->configure(-title => "Chat Room $name");
+	
+	# $self->bind('<Return>' => [$self, 'on_send']);
+	# $self->bind("<Escape>" => [$self, "destroy"]);
+	hook("tk_seticon", -wnd => $self);
+
+	$self->update;
+	$self->geometry("+" . int(($self->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($self->screenheight() / 2) - int($self->height() / 2)) );
+	$self->deiconify;
+	$self->resizable(0, 0);
+
+	$self->update();
+}
+
+1;

plugins/Tk-Chat/Tk-Chat.pl

@@ -0,0 +1,39 @@
+package TkChat;
+
+use warnings;
+use strict;
+
+use Milkbone;
+use Milkbone::Chat;
+
+register_hook("protocol_chat_invited", sub {
+	if($self->messageBox(-title => "Join Chat?", 
+		-message => "$ARGS{-user} has invited you to join a chat.  Would you like to accept?", -type => 'YesNo',
+		-icon => 'question', -default => 'no') =~ m/yes/i)
+	{
+		hook("protocol_chat_accept", -url => $ARGS{-url});
+	}
+});
+
+register_hook("protocol_chat_joined", sub {
+	my $chat = hook("tk_getmain")->MBChat;
+	$chat->init($ARGS{-chat});
+
+	register_hook("protocol_chat_buddy_in_$ARGS{-chat}", sub {
+		$ARGS{-self}->on_buddy_in($ARGS{-user});
+	}, {-self => $chat});
+
+	register_hook("protocol_chat_buddy_out_$ARGS{-chat}", sub {
+		$ARGS{-self}->on_buddy_out($ARGS{-user});
+	}, {-self => $chat});
+
+	register_hook("protocol_chat_msg_in_$ARGS{-chat}", sub {
+		$ARGS{-self}->on_msg_in($ARGS{-user});
+	}, {-self => $chat});
+
+	register_hook("protocol_chat_closed_$ARGS{-chat}", sub {
+		$ARGS{-self}->destroy;
+	}, {-self => $chat});
+});
+
+1;

plugins/Tk-Convo/Milkbone/Convo.pm

@@ -0,0 +1,246 @@
+# milkbone - conversation window
+
+package Milkbone::Convo;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk(Ev);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBConvo';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	$self->ConfigSpecs('DEFAULT' => ['SELF']);
+}
+
+sub on_send
+{
+	my $self = shift;
+	my $msg = $self->{bottom}->to_html('0.0', 'end');
+
+	$msg =~ s/\n*//g;
+        $msg =~ s/\n/<br>/g;
+
+	return if($msg eq "");
+
+	$msg =~ s/&amp;/&/g;
+	$msg =~ s/&quot;/\"/g;
+	$msg =~ s/%ignore%//gi;
+	$self->{bottom}->delete('0.0', 'end');
+	# $self->{bottom}->ResetUndo;
+
+	hook("protocol_send_im", -dest => $self->{buddy}, -msg => $msg, -away => 0);
+	$self->{typing_status} = 0;
+	$self->{text_entered} = 0;
+	$self->{typing_empty} = 0;
+	hook("protocol_set_typing_status", -user => $self->{buddy}, -status => 0);
+}
+
+sub msg_sent
+{
+	my ($self, $msg, $away) = @_;
+	my $nl = $self->{empty} ? "" : "\n";
+
+	$self->{top}->insert('end', $nl . data("me"), 'self');
+	$self->{top}->insert('end', $self->make_timestamp, 'self_stamp');
+	$self->{top}->insert('end', ": ", 'self');
+	$self->{top}->insertHTML('end',  $msg);
+	$self->{top}->yview($self->{top}->index('end'));
+	$self->{empty} = 0;
+}
+
+sub on_receive
+{	
+	my ($self) = @_;
+	my $nl = $self->{empty} ? "" : "\n";
+
+	$self->{top}->insert('end', "${nl}$ARGS{-user}", 'buddy');
+	$self->{top}->insert('end', $self->make_timestamp, 'buddy_stamp');
+	$self->{top}->insert('end', ": ", 'buddy');
+	$self->{top}->insertHTML('end', "$ARGS{-msg}");
+	$self->{top}->yview($self->{top}->index('end'));
+	$self->{empty} = 0;
+	$self->typing_status(0);
+}
+
+sub on_destroy
+{
+	my ($self) = @_;
+	hook("remove_convo", -user => shift->{buddy});
+	$self->{rep_id}->cancel;
+}
+
+sub on_prof
+{
+	hook("get_profile", -user => shift->{buddy});
+}
+
+sub on_buddy_in
+{
+	my ($self) = @_;
+
+	$self->{top}->insert('end', "\n" . $self->{buddy} . " has signed in.", "buddy") if $self->{out};
+	$self->{out} = 0 if(defined($self->{out}) and $self->{out} == 1);
+	$self->{top}->yview($self->{top}->index('end'));
+}
+
+sub on_buddy_out
+{
+	my ($self) = @_;
+
+	$self->{top}->insert('end', "\n" . $self->{buddy} . " has signed out.", "buddy");
+	$self->{out} = 1;
+	$self->{top}->yview($self->{top}->index('end'));
+}
+
+sub make_timestamp
+{
+	my ($self) = @_;
+
+	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
+
+	$sec = sprintf("%02d", $sec);
+	my $pm = ($hour > 12) ? 'PM' : 'AM';
+	$hour = $hour % 12;
+	$year += 1900;
+	$year %= 100;
+
+	return " (" . $mon . "/" . $mday . "/" . $year . " " . $hour . ":" . $min . ":" . $sec . " " . $pm . ") ";
+}
+
+sub toggle_stamps
+{
+	my ($self) = @_;
+	$self->{hide_stamps} = !$self->{hide_stamps};
+
+	$self->{top}->tagConfigure('self_stamp', -elide => $self->{hide_stamps});
+	$self->{top}->tagConfigure('buddy_stamp', -elide => $self->{hide_stamps});
+}
+
+sub typing_status
+{
+	my ($self, $status) = @_;
+
+	my @msgs = ("", $self->{buddy} . " has typed text.", $self->{buddy} . " is typing...");
+	$self->{typing}->configure(-text => $msgs[$status]);
+}
+
+sub on_key
+{
+	my ($self) = @_;
+
+	if($self->{typing_status} == 0)
+	{
+		hook("protocol_set_typing_status", -user => $self->{buddy}, -status => 2);
+		$self->{typing_status} = 2;
+	}
+	$self->{last_typed} = time;
+}
+
+sub update_status
+{
+	my ($self) = @_;
+
+	if($self->{bottom}->get('0.0', 'end') =~ /^\s*$/ && $self->{typing_status})
+	{
+		hook("protocol_set_typing_status", -user => $self->{buddy}, -status => 0);
+		$self->{typing_status} = 0;
+		return;
+	}
+
+	if((time - $self->{last_typed}) >= 5 && $self->{typing_status} == 2)
+	{
+		hook("protocol_set_typing_status", -user => $self->{buddy}, -status => 1);
+		$self->{typing_status} = 1;
+	}
+}
+
+sub init
+{
+	my ($self, $mw, $buddy) = @_;
+	
+	$self->withdraw();
+
+	$self->title("$buddy - Conversation");
+	$self->update;
+	
+	# WIDGET CREATION BEGIN
+
+	$self->{menu} = $self->Menu;
+
+	$self->{menu_file} = $self->{menu}->cascade(-label => "File", -tearoff => 0);
+	$self->{menu_file}->command(-label => "Close", -command => [$self, "destroy"]);
+
+	$self->configure(-menu => $self->{menu});
+
+	$self->{frame} = $self->Frame(-borderwidth => 0)->pack(-expand => 1, -fill => 'both');
+
+	$self->{off} = 0;
+	$self->{hide_stamps} = 1;
+
+	$self->{top} = $self->{frame}->Scrolled("Browser", -background => 'white', 
+		-height => 6, -font => "times 12", -scrollbars => 'oe', -wrap => 'word', -takefocus => 0)->
+		pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 5);
+	$self->{bottom} = $self->{frame}->Scrolled("BrowseEdit",
+		-height => 6, -font => "times 12", -scrollbars => 'oe', -wrap => 'word',
+		-spacing1 => 0, -spacing2 => 0, -spacing3 => 0)->
+		pack(-expand => 1, -fill => 'both', -padx => 5);
+	$self->{typing} = $self->{frame}->Label->pack(-anchor => 'w');
+	$self->{frame}->Button(-text => "Send", -command => [$self, "on_send"])->
+		pack(-pady => 3, -side => 'right', -anchor => 'center');
+	$self->{frame}->Button(-text => "Get Profile", -command => [$self, "on_prof"])->
+		pack(-pady => 3, -side => 'left', -anchor => 'center');
+
+	# WIDGET CREATION END
+
+	$self->{top}->tagConfigure('self', -foreground => 'red', -font => 'times 12 bold');
+	$self->{top}->tagConfigure('buddy', -foreground => 'blue', -font => 'times 12 bold');
+	$self->{top}->tagConfigure('self_stamp', -foreground => 'red', -elide => 1, -font => 'times 9 bold');
+	$self->{top}->tagConfigure('buddy_stamp', -foreground => 'blue', -elide => 1, -font => 'times 9 bold');
+
+	$self->{bottom}->bind("<Return>", [$self, "on_send"]);
+	$self->{bottom}->bind("<Control-Return>", [sub { $self->{bottom}->insert('insert', "\n")}, $self]);
+	$self->{bottom}->bind("<Escape>", [$self, "destroy"]);	
+	$self->{bottom}->bind("<KeyPress>", [$self, "on_key"]);	
+	$self->bind("<F2>", [$self, "toggle_stamps"]);	
+
+	hook("tk_bindwheel", -window => $self->{bottom});
+	hook("tk_bindwheel", -window => $self->{top});
+
+	# $self->bind('<Configure>', [sub {
+	#	 my ($width, $height) = @_;
+	#	 set_option('ConvoHeight', $height);
+	#	 set_option('ConvoWidth', $width);
+	# }, Ev('w'), Ev('h')]);
+
+	$self->{bottom}->configure(-background => 'white');
+	$self->{me} = data("me");
+	$self->{buddy} = $buddy;
+	$self->{empty} = 1;
+	$self->{last_typed} = time;
+	$self->{typing_status} = 0;
+
+	$self->update;
+	$self->geometry("480x320");
+	$self->deiconify;
+	hook("tk_seticon", -wnd => $self);
+	$self->OnDestroy([$self, "on_destroy"]);
+	$self->{bottom}->focus;
+	$self->{rep_id} = $self->repeat(1000, [$self, "update_status"]);
+}
+
+1;

plugins/Tk-Convo/Tk-Convo.pl

@@ -0,0 +1,101 @@
+package TkConvo;
+
+use Milkbone::Convo;
+use Tk::Browser;
+use Tk::BrowseEdit;
+use Milkbone;
+
+use strict;
+use warnings;
+
+my $mw = hook("tk_getmain");
+my %convos;
+
+register_hook("create_convo", sub {
+	my $buddy = $ARGS{-user};
+	my $convo;
+	
+ 	return if(exists $convos{$buddy});
+        $convos{$buddy} = 1;
+
+        print " is new";
+        print %convos;
+
+	$convo = $mw->MBConvo;
+	$convo->init($mw, hook("protocol_get_realname", -user => $buddy) || $buddy);
+
+	$convos{$buddy} = $convo;
+
+	register_hook("msg_in_$buddy", sub {
+		if(!$convos{$ARGS{-user}})
+		{
+			hook("create_convo", -user => hook("protocol_get_realname", -user => $ARGS{-user}));
+		}
+		$convos{$ARGS{-user}}->on_receive(@ARGS{-from, -msg, -away});
+		hook("flash_window", -wnd => $convo);
+	});
+
+	register_hook("protocol_typing_status_changed_$buddy", sub {
+		$ARGS{-self}->typing_status($ARGS{-status});
+	}, {-self => $convo});
+
+	register_hook("msg_sent_$buddy", sub {
+		$ARGS{-self}->msg_sent(@ARGS{-msg, -away});
+	}, {-self => $convo});
+
+	register_hook("buddy_in_$buddy", sub {
+		$ARGS{-self}->on_buddy_in();
+	}, {-self => $convo});
+
+	register_hook("buddy_out_$buddy", sub {
+		$ARGS{-self}->on_buddy_out();
+	}, {-self => $convo});
+
+	$convo->focus;
+	$convo->{bottom}->focus;
+
+	$convo->withdraw if hook("protocol_away_status") != 0;
+	$convo->update;
+	hook("flash_window", -wnd => $convo) unless $ARGS{-fabricated};
+});
+
+register_hook("remove_convo", sub {
+	deregister_hook("msg_in_$ARGS{-user}");
+	deregister_hook("buddy_in_$ARGS{-user}");
+	deregister_hook("buddy_out_$ARGS{-user}");
+
+	$convos{$ARGS{-user}}->destroy;
+	delete $convos{$ARGS{-user}};
+});
+
+register_hook("msg_in", sub {
+	hook("create_convo", -user => hook("protocol_get_realname", -user => $ARGS{-user}));
+});
+
+register_hook("get_convo", sub {
+	return $convos{$ARGS{-user}};
+});
+
+register_hook("protocol_go_away", sub {
+	$_->withdraw for values(%convos);
+});
+
+register_hook("protocol_return", sub {
+	$_->deiconify && $_->focus for values(%convos);
+});
+
+register_hook("goodbye", sub {
+	my $goodbye = join(' ', option("Goodbye"));
+
+	hook("protocol_send_im", -dest => $_, -msg => $goodbye, -away => 0) for(keys(%convos));
+});
+
+register_hook("buddy_in", sub {
+	hook("buddy_in_$ARGS{-buddy}", -group => $ARGS{-group}) if $convos{$ARGS{-buddy}};
+});
+
+register_hook("buddy_out", sub {
+	hook("buddy_out_$ARGS{-buddy}", -group => $ARGS{-group}) if $convos{$ARGS{-buddy}};
+});
+
+1;

plugins/Tk-File/Milkbone/File.pm

@@ -0,0 +1,85 @@
+# milkbone - profile dialog
+
+package Milkbone::File;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBFile';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub init
+{
+	my ($self, $mw, $data, $file, $type) = @_;
+
+	$self->{text} = $self->Frame->pack(-expand => 1, -fill => 'both')->Scrolled(
+		"Text", -scrollbars => 'oe', -background => 'white', -wrap => 'word', -font => "times 12")->
+		pack(-expand => 1, -fill => 'both');
+	
+	$self->Button(-text => "Close", -command => [$self, "destroy"])->pack(-side => 'right');
+	$self->Button(-text => "Save", -command => [$self, "on_save"])->pack(-side => 'right');
+
+	$self->{text}->bind('<MouseWheel>', 
+		[ sub { $_[0]->yview('scroll', -($_[1] / 120), 'units') }, Tk::Ev('D')]);
+
+	$self->{text}->insert('0.0', $data);
+
+	$self->{type} = $type;
+	$self->{file} = $file;
+
+	if($type eq "profile")
+	{
+		$self->configure(-title => "Edit Profile");
+	}
+	else
+	{
+		$self->configure(-title => "Edit Away Message");
+	}
+
+	$self->{text}->focus;
+	hook("tk_seticon", -wnd => $self);
+}
+
+sub on_save
+{
+	my ($self) = @_;
+	my $text = $self->{text}->get('0.0', 'end');
+
+	$text = pre_save($text);
+
+	open(OUT, ">" . $self->{file}) or die "couldn't open: $! " . $self->{file};
+	print OUT $text;
+	close(OUT);
+
+	if($self->{type} eq "profile")
+	{
+		hook("protocol_set_prof", -data => $text);
+	}
+	elsif($self->{type} eq "away")
+	{
+		hook("protocol_set_away", -data => $text);
+	}
+
+	$self->destroy;
+}
+
+sub pre_save
+{
+	my ($text) = @_;
+
+	$text =~ s/\n*$//g;
+	$text =~ s/\n/<br>/gi;
+	
+	return $text;
+}

plugins/Tk-File/Tk-File.pl

@@ -0,0 +1,73 @@
+package TkFile;
+
+use Milkbone;
+use Milkbone::File;
+use Tk;
+
+use warnings;
+use strict;
+
+my $mw = hook("tk_getmain");
+
+register_hook "edit_file", sub {
+	my $file = $mw->MBFile;
+	my $type = $ARGS{-type};
+	my ($prof_file, $away_file, $prof, $away) = get_all();
+
+	if($type eq "profile")
+	{
+		$file->init($mw, $prof, $prof_file, $type);
+	}
+	else
+	{
+		$file->init($mw, $away, $away_file, $type);
+	}
+
+	$file->focus;
+};
+
+register_hook "on_set_profile", sub {
+	hook("edit_file", -type => "profile");
+};
+
+register_hook "on_set_away", sub {
+	hook("edit_file", -type => "away");
+};
+
+register_hook "signed_in", sub {
+	$ARGS{-type} = 'profile';
+	&get_all;
+	$ARGS{-type} = 'away';
+	&get_all;
+};
+
+sub get_all{
+	my $away_file = user_file("away.txt");
+	my $prof_file = user_file("profile.txt");
+
+	my $away = pre_read(slurp($away_file, 1));
+	my $prof = pre_read(slurp($prof_file, 1));
+
+	if($prof eq "FAILED")
+	{
+		$prof = "<b>Milkbone %v(<a href=\"http://milkbone.batkins.com\">milkbone.batkins.com</a>)</b><br><br>A recent survey has concluded that 100% of all milkbone users would rather use milkbone than nothing at all.<br><br>I'm listening to %a - %s";
+	}
+	if($away eq "FAILED")
+	{
+		$away = "I cannot be bothered at this time.";
+	}
+
+	hook("protocol_set_prof", -data => $prof);
+	hook("protocol_set_away", -data => $away);
+
+	return ($prof_file, $away_file, $prof, $away);
+}
+
+sub pre_read
+{
+	my ($text) = @_;
+
+	$text =~ s/<br>/\n/gi;
+
+	return $text;
+}

plugins/Tk-GUI/Milkbone/BrowseEntry.pm

@@ -0,0 +1,353 @@
+#
+# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
+
+package Milkbone::BrowseEntry;
+
+use vars qw($VERSION);
+$VERSION = '3.030'; # $Id$
+
+use Tk qw(Ev);
+use Carp;
+use strict;
+
+require Tk::Frame;
+require Tk::LabEntry;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'MBCombo';
+
+sub Populate {
+    my ($w, $args) = @_;
+
+    $w->SUPER::Populate($args);
+
+    # entry widget and arrow button
+    my $lpack = delete $args->{-labelPack};
+    if (not defined $lpack) {
+	$lpack = [-side => 'left', -anchor => 'e'];
+    }
+    my $var = "";
+    my $e = $w->LabEntry(-labelPack => $lpack,
+			 -label => delete $args->{-label},
+			 -textvariable => \$var, -background => "white");
+    my $b = $w->Button(-bitmap => '@' . Tk->findINC('cbxarrow.xbm'));
+    $w->Advertise('entry' => $e);
+    $w->Advertise('arrow' => $b);
+    $b->pack(-side => 'right', -padx => 1);
+    $e->pack(-side => 'right', -fill => 'x', -expand => 1, -padx => 1);
+
+    # popup shell for listbox with values.
+    my $c = $w->Toplevel(-bd => 2, -relief => 'raised');
+    $c->overrideredirect(1);
+    $c->withdraw;
+    my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ );
+    $w->Advertise('choices' => $c);
+    $w->Advertise('slistbox' => $sl);
+    $sl->pack(-expand => 1, -fill => 'both');
+
+    # other initializations
+    $w->SetBindings;
+    $w->{'popped'} = 0;
+    $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e);
+    $w->ConfigSpecs(
+        -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
+        -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
+        -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
+        -choices     => [qw/METHOD   choices     Choices/,     undef],
+        -state       => [qw/METHOD   state       State         normal/],
+        -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
+        -variable    => '-textvariable',
+	-colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
+        -command     => '-browsecmd',
+        -options     => '-choices',
+        DEFAULT      => [$e] );
+}
+
+sub SetBindings {
+    my ($w) = @_;
+
+    my $e = $w->Subwidget('entry');
+    my $b = $w->Subwidget('arrow');
+
+    # set bind tags
+    $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
+    $e->bindtags([$e, $e->toplevel, 'all']);
+
+    # bindings for the button and entry
+    $b->bind('<1>',[$w,'BtnDown']);
+    $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
+    $b->bind('<space>',[$w,'space']);
+
+    # bindings for listbox
+    my $sl = $w->Subwidget('slistbox');
+    my $l = $sl->Subwidget('listbox');
+    $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
+    $l->bind('<Escape>' => [$w,'LbClose']);
+    $l->bind('<Return>' => [$w,'Return',$l]);
+
+    # allow click outside the popped up listbox to pop it down.
+    $w->bind('<1>','BtnDown');
+}
+
+sub space
+{
+ my $w = shift;
+ $w->BtnDown;
+ $w->{'savefocus'} = $w->focusCurrent;
+ $w->Subwidget('slistbox')->focus;
+}
+
+
+sub ListboxRelease
+{
+ my ($w,$x,$y) = @_;
+ $w->ButtonHack;
+ $w->LbChoose($x, $y);
+}
+
+sub Return
+{
+ my ($w,$l) = @_;
+ my($x, $y) = $l->bbox($l->curselection);
+ $w->LbChoose($x, $y)
+}
+
+
+sub BtnDown {
+    my ($w) = @_;
+    return if $w->cget( '-state' ) eq 'disabled';
+
+    if ($w->{'popped'}) {
+	$w->Popdown;
+	$w->{'buttonHack'} = 0;
+    } else {
+	$w->PopupChoices;
+	$w->{'buttonHack'} = 1;
+    }
+}
+
+sub PopupChoices {
+    my ($w) = @_;
+
+    if (!$w->{'popped'}) {
+       $w->Callback(-listcmd => $w);
+	my $e = $w->Subwidget('entry');
+	my $c = $w->Subwidget('choices');
+	my $s = $w->Subwidget('slistbox');
+	my $a = $w->Subwidget('arrow');
+	my $y1 = $e->rooty + $e->height + 3;
+	my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
+	my $ht = $s->reqheight + 2 * $bd;
+	my $x1 = $e->rootx;
+	my ($width, $x2);
+	if (defined $w->cget(-listwidth)) {
+	    $width = $w->cget(-listwidth);
+	    $x2 = $x1 + $width;
+	} else {
+	    $x2 = $a->rootx + $a->width;
+	    $width = $x2 - $x1;
+	}
+	my $rw = $c->reqwidth;
+	if ($rw < $width) {
+	    $rw = $width
+	} else {
+	    if ($rw > $width * 3) {
+		$rw = $width * 3;
+	    }
+	    if ($rw > $w->vrootwidth) {
+		$rw = $w->vrootwidth;
+	    }
+	}
+	$width = $rw;
+
+	# if listbox is too far right, pull it back to the left
+	#
+	if ($x2 > $w->vrootwidth) {
+	    $x1 = $w->vrootwidth - $width;
+	}
+
+	# if listbox is too far left, pull it back to the right
+	#
+	if ($x1 < 0) {
+	    $x1 = 0;
+	}
+
+	# if listbox is below bottom of screen, pull it up.
+	my $y2 = $y1 + $ht;
+	if ($y2 > $w->vrootheight) {
+	    $y1 = $y1 - $ht - ($e->height - 5);
+	}
+
+	$c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
+	$c->deiconify;
+	$c->raise;
+	$e->focus;
+	$w->{'popped'} = 1;
+
+	$c->configure(-cursor => 'arrow');
+	$w->grabGlobal;
+    }
+}
+
+# choose value from listbox if appropriate
+sub LbChoose {
+    my ($w, $x, $y) = @_;
+    my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+    if ((($x < 0) || ($x > $l->Width)) ||
+	(($y < 0) || ($y > $l->Height))) {
+	# mouse was clicked outside the listbox... close the listbox
+	$w->LbClose;
+    } else {
+	# select appropriate entry and close the listbox
+	$w->LbCopySelection;
+       $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get);
+    }
+}
+
+# close the listbox after clearing selection
+sub LbClose {
+    my ($w) = @_;
+    my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+    $l->selection('clear', 0, 'end');
+    $w->Popdown;
+}
+
+# copy the selection to the entry and close listbox
+sub LbCopySelection {
+    my ($w) = @_;
+    my $index = $w->LbIndex;
+    if (defined $index) {
+	$w->{'curIndex'} = $index;
+	my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+        my $var_ref = $w->cget( '-textvariable' );
+        $$var_ref = $l->get($index);
+	if ($w->{'popped'}) {
+	    $w->Popdown;
+	}
+    }
+    $w->Popdown;
+}
+
+sub LbIndex {
+    my ($w, $flag) = @_;
+    my $sel = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
+    if (defined $sel) {
+	return int($sel);
+    } else {
+	if (defined $flag && ($flag eq 'emptyOK')) {
+	    return undef;
+	} else {
+	    return 0;
+	}
+    }
+}
+
+# pop down the listbox
+sub Popdown {
+    my ($w) = @_;
+    if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'})) {
+	$w->{'savefocus'}->focus;
+	delete $w->{'savefocus'};
+    }
+    if ($w->{'popped'}) {
+	my $c = $w->Subwidget('choices');
+	$c->withdraw;
+	$w->grabRelease;
+	$w->{'popped'} = 0;
+    }
+}
+
+# This hack is to prevent the ugliness of the arrow being depressed.
+#
+sub ButtonHack {
+    my ($w) = @_;
+    my $b = $w->Subwidget('arrow');
+    if ($w->{'buttonHack'}) {
+	$b->butUp;
+    }
+}
+
+sub choices
+{
+ my ($w,$choices) = @_;
+ if (@_ > 1)
+  {
+   $w->delete( qw/0 end/ );
+   my %hash;
+   my $var = $w->cget('-textvariable');
+   my $old = $$var;
+   foreach my $val (@$choices)
+    {
+     $w->insert( 'end', $val);
+     $hash{$val} = 1;
+    }
+   $old = (@$choices) ? $choices->[0] : undef unless exists $hash{$old};
+   $$var = $old;
+  }
+ else
+  {
+   return( $w->get( qw/0 end/ ) );
+  }
+}
+
+sub _set_edit_state {
+    my( $w, $state ) = @_;
+
+    my $entry  = $w->Subwidget( 'entry' );
+    my $button = $w->Subwidget( 'arrow' );
+
+    if ($w->cget( '-colorstate' )) {
+	my $color;
+	if( $state eq 'normal' ) {                  # Editable
+	    $color = 'gray95';
+	} else {                                    # Not Editable
+	    $color = $w->cget( -background ) || 'lightgray';
+	}
+	$entry->Subwidget( 'entry' )->configure( -background => $color );
+    }
+
+    if( $state eq 'readonly' ) {
+        $entry->configure( -state => 'disabled' );
+        $button->configure( -state => 'normal' );
+    } else {
+        $entry->configure( -state => $state );
+        $button->configure( -state => $state );
+    }
+}
+
+sub state {
+    my $w = shift;
+    unless( @_ ) {
+        return( $w->{Configure}{-state} );
+    } else {
+        my $state = shift;
+        $w->{Configure}{-state} = $state;
+        $w->_set_edit_state( $state );
+    }
+}
+
+sub _max {
+    my $max = shift;
+    foreach my $val (@_) {
+        $max = $val if $max < $val;
+    }
+    return( $max );
+}
+
+sub shrinkwrap {
+    my( $w, $size ) = @_;
+
+    unless( defined $size ) {
+        $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
+    }
+
+    my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
+    $w->configure(  -width => $size );
+    $lb->configure( -width => $size );
+}
+
+
+1;
+
+__END__
+

plugins/Tk-GUI/Milkbone/Tree.pm

@@ -0,0 +1,29 @@
+package Milkbone::Tree;
+
+use Tk::Tree;
+use base qw(Tk::Tree);
+use Milkbone;
+
+Construct Tk::Widget "MBTree";
+
+# we don't need no stinkin' anchors!
+
+sub anchorSet 
+{ 
+
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	$self->bind('<ButtonPress-1>', [\&on_lclick, $self]);
+}
+
+sub on_lclick
+{
+	my ($self) = @_;
+
+
+}

plugins/Tk-GUI/Tk-GUI.pl

@@ -0,0 +1,89 @@
+# -----------------------------------------------------------------------------
+# Author(s)	:	Bill Atkins
+# Title		:	Tk-Win32 initialization file
+# Date		:	1.22.02
+# Desc		:	initializes the Tk-GUI plugin
+# Notes		:	for more information see the plugin documentation
+# License	:	it's on our TODO list...
+# -----------------------------------------------------------------------------
+
+package TkGUI;
+
+use warnings;
+
+use Tk;
+use Tk::ItemStyle;
+use Milkbone;
+
+my $mw = MainWindow->new();
+$mw->withdraw();
+$mw->OnDestroy(\&on_destroy);
+
+$mw->optionAdd("*font", "-*-arial-norma-r-*-*-*-120-*-*-*-*-*-*");
+$mw->optionAdd("*borderWidth", 1);
+$mw->optionAdd("*highlightThickness", 0);
+$mw->optionAdd("*background", "lightblue");
+
+my $icon = $mw->Photo(-file => path("images/icon.bmp"));
+
+register_hook("tk_seticon", sub { $ARGS{-wnd}->Icon(-image => $icon); });
+
+register_hook("tick", \&tick);
+register_hook("tk_getmain", sub {
+	return $mw;
+});
+
+register_hook("tk_bindwheel", sub {
+    if($^O =~ /win32/i)
+    {
+	$ARGS{-window}->bind('<MouseWheel>', 
+	    [ sub { $_[0]->yview('scroll', -($_[1] / 120), 'units') }, Tk::Ev('D')]);
+    }
+    else
+    {
+	$ARGS{-window}->bind('<4>' => sub { $_[0]->yview('scroll', -1, 'units') unless $Tk::strictMotif;
+	});
+
+	$ARGS{-window}->bind('<5>' => sub { $_[0]->yview('scroll', 1, 'units') unless $Tk::strictMotif;
+	});
+    }
+});
+
+register_hook("after", sub {
+	$mw->after($ARGS{-time}, $ARGS{-code});
+});
+
+
+sub tick
+{
+	return unless $mw;
+
+	$mw->DoOneEvent(Tk::ALL_EVENTS);
+}
+
+sub on_destroy
+{
+	abort();
+}
+
+register_hook("error", sub {
+	my $text = $ARGS{-short};
+	($text) = $text =~ m/^(.*?)\n/;
+	my $error_box = $mw->Toplevel(-title => "Milkbone Error");
+	$error_box->Label(-text => $ARGS{-short})->pack;
+	$error_box->Button(-text => "OK", -command => [sub {
+		my ($self, $fatal) = @_;
+		$self->destroy;
+		hook("protocol_signoff") if $fatal;
+		$mw->destroy if $fatal  && hook("protocol_signed_in");
+	}, $error_box, $ARGS{-fatal}])->pack->focus;
+	hook("tk_seticon", -wnd => $error_box);
+	$error_box->withdraw;
+	$error_box->geometry("+" . int(($mw->screenwidth() / 2) - int($error_box->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($error_box->height() / 2)) );
+	$error_box->deiconify;
+	$error_box->update;
+        $error_box->focus;
+});
+
+
+1;

plugins/Tk-GUI/Tk/BrowseEdit.pm

@@ -0,0 +1,186 @@
+package Tk::BrowseEdit;
+
+use Tk;
+use Tk::Font;
+use base 'Tk::Frame';
+
+use strict;
+use warnings;
+
+Construct Tk::Widget 'BrowseEdit';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	$self->{panel} = $self->Frame(-borderwidth => 0)->pack(-fill => 'both');
+	$self->{text} = $self->Text(-background => 'white')->pack(-expand => 1, -fill => 'both');
+
+	$self->{'<b>'} = $self->{panel}->Button(-text => 'B', -relief => 'flat',
+		-font => $self->Font(-family => 'times', -weight => 'bold', -size => '8'),
+		-command => [sub {
+			my ($self) = @_;
+			$self->toggleTag('<b>');
+		}, $self]
+		)->pack(-pady => 0, -side => 'left', -fill => 'both');
+	$self->{text}->tagConfigure('<b>', -font => $self->Font(-family => 'times', -weight => 'bold'));
+	$self->{text}->bind('<Control-B>', [sub { shift->{'<b>'}->invoke; }, $self]);
+
+	$self->{'<i>'} = $self->{panel}->Button(-text => 'I', -relief => 'flat',
+		-font => $self->Font(-family => 'times', -slant => 'italic', -size => '8'),
+		-command => [sub {
+			my ($self) = @_;
+			$self->toggleTag('<i>');
+		}, $self]
+		)->pack(-pady => 0, -side => 'left', -fill => 'both');
+	$self->{text}->tagConfigure('<i>', -font => $self->Font(-family => 'times', -slant => 'italic'));
+	$self->bind('<Control-I>', [sub { shift->{'<b>'}->invoke; }, $self]);
+
+	$self->{'<u>'} = $self->{panel}->Button(-text => 'U', -relief => 'flat',
+		-font => $self->Font(-family => 'times', -underline => 1, -size => '8'),
+		-command => [sub {
+			my ($self) = @_;
+			$self->toggleTag('<u>');
+		}, $self]
+		)->pack(-pady => 0, -side => 'left', -fill => 'both');
+	$self->{text}->tagConfigure('<u>', -font => $self->Font(-family => 'times', -underline => 1));
+        
+	$self->{text}->tagConfigure('elide', -elide => 1);
+	$self->bind('<Control-U>', [sub { shift->{'<b>'}->invoke; }, $self]);
+
+	$self->ConfigSpecs(
+		'DEFAULT' => [$self->{text}],
+		-background => [$self]
+	);
+
+	$self->Delegates(
+		'DEFAULT' => $self->{text},
+		'to_html' => $self,
+	);
+
+	$self->after(200, [$self, "init"]);
+}
+
+sub toggleTag
+{
+	my ($self, $tag) = @_;
+
+	if(!defined($self->{text}->tagRanges('sel')))
+	{
+		if(!$self->{tags}->{$tag})
+		{
+			$self->{text}->insert('insert', '%ignore%', [$tag, 'elide']);
+			$self->{text}->tagAdd($tag, 'insert');
+			$self->{tags}->{$tag} = 1;
+			$self->{$tag}->configure(-relief => 'groove');
+		}
+		else
+		{
+			$self->{text}->insert('insert', '%ignore%', ['elide']);
+			$self->{text}->tagRemove($tag, 'insert');
+			$self->{tags}->{$tag} = 0;
+			$self->{$tag}->configure(-relief => 'flat');
+		}
+	}
+	else
+	{
+		my ($selstart, $selend) = $self->{text}->tagRanges('sel');
+		my @tags = $self->{text}->tagRanges($tag);
+		my (@starts, @ends);
+
+		for(my $i = 0; $i < @tags; $i += 2)
+		{
+			push @starts, $tags[$i];
+			push @ends, $tags[$i + 1];
+		}
+
+		for my $start (@starts)
+		{
+			for my $end (@ends)
+			{
+				if($selstart >= $start and $selend <= $end)
+				{
+					$self->{text}->tagRemove($tag, $self->{text}->tagRanges('sel'));
+				$self->{$tag}->configure(-relief => 'raised');
+					return;
+				}
+			}
+		}
+
+		$self->{text}->tagAdd($tag, $self->{text}->tagRanges('sel'));
+		$self->{$tag}->configure(-relief => 'sunken');
+	}
+}
+
+sub to_html
+{
+	my ($self, $start, $end) = @_;
+
+	$start ||= '0.0';
+	$end ||= 'end';
+
+	my @tags = $self->{text}->tagNames;
+
+	my $res;
+
+	my $pos = '1.0';
+	my $chars;
+	my %curtags;
+	my %chartags;
+	my (@addtags, @deltags);
+
+	while($self->{text}->index($pos) != $self->{text}->index('end'))
+	{
+		%chartags = ();
+		$chartags{$_} = 1 for $self->{text}->tagNames($pos);
+		delete $chartags{'elide'};
+		delete $chartags{'sel'};
+
+
+		for (keys %chartags)
+		{
+			push @addtags, $_ unless $curtags{$_}
+		}
+		
+		for (keys %curtags)
+		{
+			push @deltags, $_ if !$chartags{$_};
+		}
+		
+		%curtags = ();
+		$curtags{$_} = 1 for keys %chartags;
+
+		$res .= $_ for @addtags;
+		$res .= end_tag($_) for @deltags;
+
+		@deltags = @addtags = ();
+
+		$res .= $self->{text}->get($pos);
+		$pos = $self->{text}->index('0.0 + ' . ++$chars . " chars");
+	}
+
+	return $res;
+}
+
+sub end_tag
+{
+	my ($tag) = @_;
+	$tag =~ s/^</<\//;
+	return $tag;
+}
+
+sub init
+{
+	my ($self) = @_;
+
+	$self->{text}->configure(-background => 'white');
+}
+
+1;

plugins/Tk-GUI/Tk/Browser.pm

@@ -0,0 +1,205 @@
+package Tk::Browser;
+
+use Tk;
+use Tk::Font;
+use base 'Tk::ROText';
+
+use strict;
+use warnings;
+
+Construct Tk::Widget 'Browser';
+
+sub insertHTML
+{
+	my ($self, $pos, $html) = @_;
+	my @insert;
+
+	$self->configure(-selectforeground => 'white', -selectbackground => 'black');
+
+	$html =~ s/<br>/\n/gi;
+	$html =~ s/<body bgcolor=/<font back=/gi;
+
+	my (@items) = grep { $_ ne "" } split /(<.*?>)/, $html;
+
+	my $data = {};
+	my $font = {-family => 'times'};
+
+	$self->begin($font);
+
+	for(@items)
+	{
+		if(!/^</)
+		{ 
+		        s/&amp;/&/gi;
+		        s/&gt;/>/gi;
+		        s/&lt;/</gi;
+		        s/&quot;/\"/gi;
+			push @insert, $_, [keys %{$data->{tags}}];
+		}
+		else
+		{
+			my ($tagname) = /^<\/?(\w*)/;
+			my $func = /^<\// ? lc $tagname . "_end" :
+				lc $tagname . "_begin";
+			$_ =~ s/^<\///;
+			$self->$func($_, $data, $font);
+		}
+	}
+
+	$self->end;
+
+	$self->insert($pos, @insert);
+}
+
+sub begin
+{
+	my ($self, $font) = @_;
+	$self->configure(-font => $self->Font(%{$font})->Pattern);
+}
+
+sub end
+{
+	my ($self) = @_;
+}
+
+sub b_begin
+{
+	my ($self, $tag, $data, $font) = @_;
+	$font->{-weight} = 'bold';
+	$data->{tags}->{'<b>'} = 1;
+	$self->tagConfigure('<b>', -font => $self->Font(%{$font})->Pattern);
+}
+
+sub b_end
+{
+	my ($self, $tag, $data, $font) = @_;
+	$font->{-weight} = 'normal';
+
+	delete $data->{tags}->{'<b>'};
+}
+
+sub i_begin
+{
+	my ($self, $tag, $data, $font) = @_;
+	$font->{-slant} = 'italic';
+	$data->{tags}->{'<i>'} = 1;
+	$self->tagConfigure('<i>', -font => $self->Font(%{$font})->Pattern);
+}
+
+sub i_end
+{
+	my ($self, $tag, $data, $font) = @_;
+	$font->{-slant} = 'roman';
+
+	delete $data->{tags}->{'<i>'};
+}
+
+sub u_begin
+{
+	my ($self, $tag, $data, $font) = @_;
+
+	$data->{tags}->{'<u>'} = 1;
+	$self->tagConfigure('<u>', -underline => 1, -font => $self->Font(%{$font})->Pattern);
+}
+
+sub u_end
+{
+	my ($self, $tag, $data, $font) = @_;
+
+	delete $data->{tags}->{'<u>'};
+}
+
+sub a_begin
+{
+	# this assumes that no one will nest anchor tags ( a silly thing to do anyway )
+
+	my ($self, $tag, $data, $font) = @_;
+
+	my ($href) = ($tag =~ m/href=\"(.*?)\"/i);
+	
+	$data->{tags}->{$tag} = 1;
+	$self->tagConfigure($tag, -foreground => "blue", -underline => 1, -font => $self->Font(%{$font})->Pattern);
+
+	$self->tagBind($tag, '<ButtonPress-1>', [sub {
+		my $cmd;
+		$cmd = "\"c:\\program files\\internet explorer\\iexplore.exe\"" if $^O =~ m/Win32/;
+		$cmd = "opera" if $^O !~ m/Win32/;
+		if($^O !~ m/Win32/)
+		{
+			exec("$cmd $_[1]") unless fork;
+		}
+		else
+		{
+			system("$cmd $_[1]");
+		}
+	}, $href]);
+
+	$self->tagBind($tag, '<Enter>', [sub {
+		shift->configure(-cursor => 'hand2');
+	}, $self]);
+
+	$self->tagBind($tag, '<Leave>', [sub {
+		shift->configure(-cursor => 'xterm');
+	}, $self]);
+
+	push @{$data->{atags}}, $tag;
+}
+
+sub a_end
+{
+	my ($self, $tag, $data, $font) = @_;
+
+	$font->{-underline} = 0;
+
+	delete $data->{tags}->{pop @{$data->{atags}}};
+}
+
+sub font_begin
+{
+	my ($self, $tag, $data, $font) = @_;
+
+	my ($family) = ($tag =~ m/face=\"(.*?)\"/i);
+	my ($color) = ($tag =~ m/color=\"(.*?)\"/i);
+	my ($size) = ($tag =~ m/size=\"?([^> ]*)\"?/i);
+	my ($back) = ($tag =~ m/back=\"(.*?)\"/i);
+
+	$size ||= 2;
+
+	my $realsize;
+
+	# Begin klugey OS hacks
+
+	$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) + 2 if $size and $^O =~ /Win32/;
+
+	$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) if $size and $^O !~ /Win32/;
+
+	$font->{-family} = $family if $family;
+	$font->{-size} = $realsize if $size;
+
+	my %opts;
+	$opts{-foreground} = $color if $color;
+	$opts{-background} = $back if $back;
+	
+	$data->{tags}->{$tag} = 1;
+	$self->tagConfigure($tag, %opts, -font => $self->Font(%{$font})->Pattern);
+
+	push @{$data->{fonttags}}, $tag;
+}
+
+sub font_end
+{
+	my ($self, $tag, $data, $font) = @_;
+
+	delete $data->{tags}->{pop @{$data->{fonttags}}};
+}
+
+sub body_end
+{
+	my ($self, $tag, $data, $font) = @_;
+}
+
+sub AUTOLOAD
+{
+}
+
+1;

plugins/Tk-GUI/edit_test.pl

@@ -0,0 +1,8 @@
+use Tk;
+
+$mw = MainWindow->new;
+$edit = $mw->BrowseEdit(-font => 'times 12 normal')->pack;
+
+$mw->Button(-command => sub { print $edit->to_html })->pack;
+
+MainLoop;

plugins/Tk-GUI/test.pl

@@ -0,0 +1,20 @@
+use Tk;
+use Tk::Text;
+
+$mw = MainWindow->new;
+
+$edit = $mw->TextUndo->pack;
+
+$edit->insert('end', 't');
+
+$edit->tagConfigure('<b>', -font => $mw->Font(-family => 'times', -weight => 'bold'));
+$edit->tagConfigure('elide',  -elide => 1);
+
+$tag = "<b>";
+
+$mw->Button(-text => 'bold', -command => sub {
+		$edit->insert('insert', 'de', [$tag, 'elide']);
+		$edit->tagAdd($tag, 'insert');
+})->pack;
+
+MainLoop;

plugins/Tk-Logon/Milkbone/Logon.pm

@@ -0,0 +1,152 @@
+# milkbone - sign-on toplevel mega-widget
+
+package Milkbone::Logon;
+
+use Milkbone;
+
+use Tk::widgets qw(Frame Label);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBLogon';
+
+my $mw = hook("tk_getmain");
+
+my $slogan = "surely this convenience entices you.  it's so easy to use, and the surgery to implant it in the base of your skull is so painless that it's no wonder i'm number one. (athf)";
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	$self->ConfigSpecs('DEFAULT' => ['SELF']);
+	$self->Delegates();
+}
+
+sub clear
+{
+	my ($self) = @_;
+	$self->{sname} = "";
+	$self->{pass} = "";
+	$self->{signed_on} = 0;
+}
+
+sub on_destroy
+{
+	my ($self) = @_;
+
+	hook("protocol_signoff") if $self->{signed_on};
+	$mw->destroy;
+}
+
+sub on_logon
+{
+	my ($self) = @_;
+
+	return if $self->{signed_on} == 1;
+
+	$self->{controls}->packForget;
+	$self->{status}->pack(-expand => 1, -fill => 'both');
+	$self->update;
+
+	hook("protocol_signon", -user => $self->{sname}, -pass => $self->{pass});
+
+	$self->{signed_on} = 1;
+	data("me") = $self->{sname};
+}
+
+sub on_cancel
+{
+	my ($self) = @_;
+
+	$self->{status}->packForget;
+	$self->{controls}->pack(-expand => 1, -fill => 'both');
+
+	hook("protocol_signoff");
+	$self->{signed_on} = 0;
+	$self->{status_label}->configure(-text => 'Connecting to the Evil Empire...');
+	$self->{sn_entry}->focus;
+        $self->update;
+}
+
+sub on_about
+{
+	my ($self) = @_;
+
+	$mw->MBAbout(-title => "About milkbone $Milkbone::VERSION")->focus;
+}
+
+sub init
+{
+	my ($self, $mw, %args) = @_;
+
+	$self->{sname} = "";
+	$self->{pass} = "";
+	$self->{signed_on} = 0;
+
+	$self->withdraw();
+	$self->resizable(0, 0);
+	$self->configure(-title => "milkbone logon $Milkbone::VERSION");
+	
+	# WIDGET CREATION BEGIN
+	my $image = $self->Photo(-file => path("images/logon.bmp"));
+	$self->Label(-image => $image)->pack(-side => 'top', -ipadx => 0, -ipady => 2);
+
+	# separate frames are used for the logon boxes and the status area
+	$self->{controls} = $self->Frame->pack(-expand => 1, -fill => 'both');
+	$self->{status} = $self->Frame;
+	
+	# create the screen name widget and focus it
+	$self->{controls}->Label(-text => 'Screen name:', -anchor => 'w',
+	  -borderwidth => 0)->
+    pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 7);
+
+	$self->{sn_entry} = $self->{controls}->Component('Entry' => 'sn', -background => 'white', -width => 16, -textvariable => \$self->{sname}, -insertwidth => 1)->
+		pack(-side => 'top',  -fill => 'x', -padx => 5);
+	$self->{sn_entry}->focus;
+	
+	# create the password widget
+	$self->{controls}->Label(-text => 'Password:', -anchor => 'w')->
+		pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 7);
+	$self->{pass_entry} = $self->{controls}->Component('Entry' => 'pass', -background => 'white', -width => 16, -textvariable => \$self->{pass}, -show => '*', -insertwidth => 1)->
+		pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 5);
+
+	$self->{controls}->Label(-text => $slogan, -anchor => 'c', -justify => 'center', -wraplength => 250)->pack(-expand =>1, -fill => 'both');
+
+	# create the status frame
+	$self->{status_label} = $self->{status}->Label(-text => "Connecting to the Evil Empire...")->pack;
+	$self->{status}->Button(-text => "Cancel", -command => [$self, "on_cancel"])->pack(-pady => 5);
+
+	$self->{logon_button} = $self->{controls}->Button(-text => 'log on', -command => [$self, "on_logon"], 
+		-height => 0.5, -borderwidth => 1)->
+		pack(-pady => 7, -padx => 3, -expand => 0, -side => 'left');
+	$self->{controls}->Button(-text => 'about', -command => sub { hook("show_about") }, 
+		-height => 0.5)->
+		pack(-pady => 7, -padx => 3, -expand => 0, -side => 'right');
+	# WIDGET CREATION END
+
+	$self->update;
+	$self->geometry("+" . int(($mw->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($self->height() / 2)) ) unless $^O =~ /linux/i;
+	$self->deiconify;
+	
+	$self->bind('<Return>' => [$self, 'on_logon']);
+	$self->bind("<Escape>" => [$self, "on_destroy"]);	
+	$self->OnDestroy([sub { abort unless $_[0]->{signed_on} }, $self]);
+	hook("tk_seticon", -wnd => $self);
+}
+
+sub on_signed_in
+{
+	my ($self) = @_;
+
+	$self->withdraw;
+}
+
+1;

plugins/Tk-Logon/Tk-Logon.pl

@@ -0,0 +1,30 @@
+package TkLogon;
+
+use Milkbone::Logon;
+use Milkbone;
+
+use strict;
+use warnings;
+
+my $mw = hook("tk_getmain");
+my $logged = 0;
+
+register_hook("create_logon_prompt", sub {
+	my $log = $mw->MBLogon;
+	$log->init($mw);
+
+	register_hook("signed_in", sub { 
+		Milkbone::Logon::on_signed_in($ARGS{-self});
+		$logged = 1;
+	} , {-self => $log});
+
+	register_hook("protocol_signoff", sub {
+		return unless $ARGS{-fatal};
+		my ($self) = $ARGS{-self};
+		return if $logged;
+			
+		$self->on_cancel;
+	}, {-self => $log});
+});
+
+1;

plugins/Tk-PluginsConf/Milkbone/PluginLoad.pm

@@ -0,0 +1,78 @@
+package Milkbone::PluginLoad;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk;
+use Tk::BrowseEntry;
+use Tk::JBrowseEntry;
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBPluginLoad';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+}
+
+sub on_load
+{
+	my ($self) = @_;
+        print $self->{plugin};
+	load_plugin($self->{plugin});
+	init_plugin($self->{plugin});
+        $self->{parent}->{list}->insert('end', $self->{plugin});
+	$self->destroy;
+}
+
+sub init
+{
+	my ($self, $parent) = @_;
+	$self->withdraw;
+	$self->configure(-title => "Load Plugin");
+	$self->focus();
+	$self->{plugin} = "";
+        $self->{parent} = $parent;
+
+	my %mods;
+	$mods{(m/plugins\/(.*)/)[0]} = 1 while glob("plugins/*");
+	$mods{(m/plugins\/(.*)/)[0]} = 1 while glob("plugins/*.pl");
+	$mods{(m/plugins\/(.*)/)[0]} = 1 while glob("plugins/*.zip");
+
+	my @entries = sort keys %mods;
+	s/\.pl//g for @entries;
+	s/\.zip//g for @entries;
+        delete $mods{$_} for grep(/~$/, keys %mods);
+	delete $mods{$_} for hook("loaded_plugins");
+
+	@entries = grep { $_ ne "CVS" and $_ ne "compress_dist" and $_ ne "clear_dist" } @entries;
+
+	$self->Label(-text => 'Unloaded Plugins:')->pack(-fill => 'both', -expand => 1);
+
+	$self->{list} = $self->JBrowseEntry(-choices => [sort @entries], -variable => \$self->{plugin})->pack();
+
+	$self->Button(-text => "Load...", -command => [ $self, "on_load"])->pack(-pady => 6,  -padx => 6);
+
+	$self->bind("<Escape>" => [sub { shift->destroy }, $self]);
+	hook("tk_seticon", -wnd => $self);
+
+	$self->update;
+	$self->geometry("+" . int(($self->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($self->screenheight() / 2) - int($self->height() / 2)) );
+	$self->deiconify;
+
+	$self->update();
+	$self->focus;
+}
+
+1;

plugins/Tk-PluginsConf/Milkbone/PluginsConf.pm

@@ -0,0 +1,94 @@
+package Milkbone::PluginsConf;
+
+use Milkbone;
+use Milkbone::PluginLoad;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBPluginsConf';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+}
+
+sub on_add
+{
+	my ($self) = @_;
+	my $load_dlg = $self->MBPluginLoad;
+	$load_dlg->init($self);
+}
+
+sub on_delete
+{
+	my ($self) = @_;
+	my $sel = $self->{list}->curselection;
+
+	return unless $sel;
+
+	my $plugin = $self->{list}->get($sel);
+
+	unload_plugin($plugin);
+	$self->{list}->delete($sel);
+}
+
+sub on_reload
+{
+	my ($self) = @_;
+	my $sel = $self->{list}->curselection;
+
+	return unless $sel;
+
+	my $plugin = $self->{list}->get($sel);
+
+	unload_plugin($plugin);	
+        load_plugin($plugin);
+	init_plugin($plugin);
+}
+
+
+sub init
+{
+	my ($self) = @_;
+	$self->withdraw;
+	$self->configure(-title => "Configure Plugins");
+	$self->focus();
+
+	$self->Label(-text => 'Plugins:')->pack(-fill => 'both', -expand => 1);
+
+	$self->{left} = $self->Frame->pack(-side => 'left', -padx => 2, -pady => 2);
+	$self->{right} = $self->Frame->pack(-side => 'right');
+
+	$self->{list} = $self->{left}->Scrolled("Listbox", -scrollbars => 'oe', -background => 'white')->pack(-expand => 1, -fill => 'y');
+
+	$self->{list}->insert('end', sort(@{hook("loaded_plugins")}));
+
+	$self->Button(-text => "Load...", -command => [ $self, "on_add"])->pack(-pady => 6,  -padx => 6);
+	$self->Button(-text => "Unload", -command => [ $self, "on_delete"])->pack(-pady => 6,  -padx => 6);
+	$self->Button(-text => "Reload", -command => [ $self, "on_reload"])->pack(-pady => 6,  -padx => 6);
+	
+	$self->bind('<Return>' => [$self, 'on_apply']);
+	$self->bind("<Escape>" => [$self, "destroy"]);
+	hook("tk_seticon", -wnd => $self);
+
+	$self->update;
+	$self->geometry("+" . int(($self->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($self->screenheight() / 2) - int($self->height() / 2)) );
+	$self->deiconify;
+
+	$self->update();
+	$self->focus;
+}
+
+1;

plugins/Tk-PluginsConf/Tk-PluginsConf.pl

@@ -0,0 +1,15 @@
+package TkPluginsConf;
+
+use warnings;
+use strict;
+
+use Milkbone;
+use Milkbone::PluginsConf;
+
+register_hook("dlg_plugins", sub {
+	my $parent = $ARGS{-parent};
+
+	$parent->MBPluginsConf->init;
+});
+
+1;

plugins/Tk-Profile/Milkbone/Profile.pm

@@ -0,0 +1,119 @@
+# milkbone - profile dialog
+
+package Milkbone::Profile;
+
+use Milkbone;
+
+our $VERSION = '1.0';
+
+use Tk::widgets qw(Frame Browser);
+use base qw(Tk::Toplevel);
+use strict;
+use warnings;
+
+Construct Tk::Widget 'MBProfile';
+
+sub ClassInit
+{
+	my ($class, $mw) = @_;
+	$class->SUPER::ClassInit($mw);
+}
+
+sub Populate
+{
+	my ($self, $args) = @_;
+	$self->SUPER::Populate($args);
+
+	$self->ConfigSpecs('DEFAULT' => ['SELF']);
+}
+
+sub on_receive_away
+{
+	my ($self, $away) = @_;
+	$away = $self->process($away);
+		
+	$self->{text}->insertHTML('0.0', "\n-------------------------\n");
+	$self->{text}->insertHTML('0.0', $away);
+	$self->{close}->focus;
+}
+
+sub on_receive_prof
+{
+	my ($self, $prof) = @_;
+	$prof = $self->process($prof);
+	
+	$self->{text}->insertHTML('end', $prof);
+	$self->{close}->focus;
+}
+
+sub on_destroy
+{
+	my ($self) = @_;
+
+	$self->{destroyed} = 1;
+
+	hook("remove_profile", -who => $self->{who});
+}
+
+sub set_buddy
+{
+	my ($self, $buddy) = @_;
+	$self->{buddy} = $buddy;
+}
+
+sub process
+{
+	my ($self, $str) = @_;
+	
+	$str =~ s/\%n/data("me")/eg;
+
+	return $str;
+}
+
+sub init
+{
+	my ($self, $who) = @_;
+	my ($mins, $hrs, $days);
+
+	$self->{who} = $who;
+
+	my $on_time = time - hook("protocol_on_since", -who => $who);
+	(undef, $mins, $hrs, $days, undef, undef, undef) = gmtime($on_time);
+	$days--;
+
+	$self->Label(-text => "$who has been online for $days days, $hrs hours, $mins minutes")->pack(-ipady => 1, -anchor => 'w');
+
+	if(hook("protocol_idle_since", -who => $who))
+	{
+            use integer;
+
+            my $idle_time = hook("protocol_idle_since", -who => $who);
+	    
+            my ($mins, $hrs, $days);
+            $mins = $idle_time / 60;
+            
+            $hrs = $mins / 60;
+            $mins %= 60;
+            
+            $days = $hrs / 24;
+            $hrs %= 24;
+                
+            $self->Label(-text => "$who has been idle for $days days, $hrs hours, $mins minutes")->pack(-ipady => 1, -anchor => 'w');
+	}
+
+	$self->Label(-text => "Profile Text:", -font => 'arial 9 bold')->pack(-ipady => 1, -anchor => 'w');
+
+	$self->{text} = $self->Frame->pack(-expand => 1, -fill => 'both')->
+		Scrolled("Browser", -scrollbars => 'oe', -background => 'white', -wrap => 'word')->
+		pack(-expand => 1, -fill => 'both');
+
+	$self->{text}->tagConfigure('away', -foreground => 'blue', -font => 'arial 10 bold');
+	$self->{text}->tagConfigure('prof', -foreground => 'black', -font => 'arial 10 bold');
+	$self->{close} = $self->Button(-text => "Close", -command => [$self, "destroy"])->pack;
+
+	hook("tk_bindwheel", -window => $self->{text});
+
+	$self->OnDestroy([\&on_destroy, $self]);
+	$self->bind("<Escape>", [$self, "destroy"]);
+	hook("tk_seticon", -wnd => $self);
+}

plugins/Tk-Profile/Tk-Profile.pl

@@ -0,0 +1,46 @@
+package TkProfile;
+
+use Milkbone::Profile;
+use Milkbone;
+
+use strict;
+use warnings;
+
+my $mw = hook("tk_getmain");
+
+register_hook("get_profile", sub {
+	my $who = $ARGS{-user};
+
+	$who =~ s/ //g;
+	$who =~ tr/A-Z/a-z/;
+
+	my $prof = $mw->MBProfile(-title => "Profile for $who");
+	$prof->init($who);
+
+	hook("protocol_request_info", -user => $who);
+	hook("protocol_request_away", -user => $who);
+
+	$prof->focus;
+
+	register_hook("protocol_info_received_$who", sub {
+		return unless $ARGS{-self};
+		my $self = $ARGS{-self};
+
+		if(defined $ARGS{-profile})
+		{
+			$self->on_receive_prof($ARGS{-profile});
+			$self->{prof_rec} = 1;
+		}
+		if(defined $ARGS{-away})
+		{
+			$self->on_receive_away($ARGS{-away});
+			$self->{away_rec} = 1;
+		}
+	}, {-self => $prof});
+});
+
+register_hook("remove_profile", sub {
+	deregister_hook("protocol_info_received_" . $ARGS{-who});
+});
+
+1;

plugins/Tk-Splash.pl

@@ -0,0 +1,20 @@
+package TkSplash;
+
+use strict;
+use warnings;
+
+use Milkbone;
+
+my $splash;
+
+BEGIN 
+{
+    require Tk::FastSplash;
+    $splash = Tk::FastSplash->Show("images/splash.bmp", 50, 50, "splash",1);
+}
+
+register_hook("pre_mainloop", sub {
+    $splash->Destroy;
+});
+
+1;

plugins/Win32-Tray.pl

@@ -0,0 +1,78 @@
+BEGIN { return 1 unless $^O =~ /win32/i; }
+
+package Win32Tray;
+
+use strict;
+use warnings;
+
+use Milkbone;
+use Win32::GUI;
+use Tk;
+
+my $icon = new Win32::GUI::Icon(path("images/mbone.ico")) or die "Couldn't load icon.";
+my ($i);
+our ($parent, $tray, $menu);
+
+register_hook("signed_in", sub {
+	return unless option("TrayIcon") == 1;
+	$parent = Win32::GUI::Window->new(-name => 'Main', -text => 'Perl',
+		-width => 200, -height => 200) or die $!;
+	$parent->Hide();
+	$tray = $parent->AddNotifyIcon(-icon => $icon, -name => 'NI', -id => 1, -tip => data("me") . " - milkbone");
+
+	$menu = Win32::GUI::MakeMenu(
+		"POPUP" => "POPUP_MENU",
+		" >Show/Hide All" => "Tray_Toggle",
+		" >Exit" => "Tray_Exit"
+		);
+
+	hook("tk_getmain")->repeat(500, [sub {
+		Win32::GUI::DoEvents;
+	}, $parent]);
+
+	register_hook("post_mainloop", sub {
+		$ARGS{-parent}->NI->Delete(-id => 1);
+	}, {-parent => $parent});
+});
+
+END 
+{
+	hook("post_mainloop");
+}
+
+package main;
+
+my $hidden = 0;
+
+sub NI_RightClick
+{
+	my($x, $y) = Win32::GUI::GetCursorPos();  
+    $Win32Tray::parent->TrackPopupMenu($Win32Tray::menu->{POPUP_MENU},$x, $y);
+}
+
+sub Tray_Exit_Click
+{
+	abort;
+}
+
+sub Tray_Head
+{
+}
+
+sub Tray_Toggle_Click
+{
+	my $mw = hook("tk_getmain");
+
+	if($hidden)
+	{
+		$_->deiconify and $_->focus for $mw->children;
+		$hidden = 0;
+	}
+	else
+	{
+		$_->withdraw for $mw->children;
+		$hidden = 1;
+	}
+}
+
+1;

plugins/Win32X.pl

@@ -0,0 +1,18 @@
+return 1 unless $^O =~ /win32/i;
+
+package Win32X;
+
+use Milkbone;
+use Win32::API;
+
+use strict;
+use warnings;
+
+my $FlashWindow = new Win32::API('user32', 'FlashWindow', 'NI', 'I');
+
+register_hook("flash_window", sub {
+	my $wnd = $ARGS{-wnd};
+	$wnd->after(200, [sub { $_[0]->Call(hex($_[1]->frame()), 1) if $_[1]; }, $FlashWindow, $wnd]);
+});
+
+1;

plugins/XAMP.pl

@@ -0,0 +1,95 @@
+package XAMP;
+
+use strict;
+use warnings;
+
+use Milkbone;
+
+my $commit = 0;
+my $last_text = "";
+
+#
+# Some rather kludgy OS-specific code follows
+#
+
+
+if($^O =~ /Win32/)
+{
+    eval '
+	package XAMP;
+
+        use Win32::GuiText qw(FindWindowLike GetWindowText);
+
+        sub get_text
+        {
+            my ($win) = FindWindowLike(0, "", "Winamp v1.x");
+            ($win) = FindWindowLike(0, "", "STUDIO") unless $win;
+
+            my $song = GetWindowText($win) if $win;
+            
+            $song = $song x 2 unless($song =~ m/\d*\. (.*)- Winamp/);
+            return $song;
+ 	}
+    ';
+}
+else
+{
+    eval '
+        use Xmms::Remote;
+
+	my $rem = Xmms::Remote->new;
+	
+	sub get_text
+	{
+		my $text = $rem->get_playlist_title($rem->get_playlist_pos);
+		$commit = 1 if $text ne $last_text;
+		return $text;
+	}
+    ' or die $@;
+}
+
+sub get_title
+{
+	my $text = get_text();
+	my ($title) = $text =~ /-\s+(.*)/;
+	return $title || "Nothing";
+}
+
+sub get_artist
+{
+	my $text = get_text();
+	my ($artist) = $text =~ /(.*?)\s+-/;
+	return $artist || "Nobody";
+}
+
+sub update
+{
+    my ($text) = get_text();
+    return if $text eq $last_text;
+    $last_text = $text;
+
+    my ($artist, $title) = (get_artist(), get_title());
+    hook('protocol_mod_prof', -name => '%a', -value => $artist);
+    hook('protocol_mod_prof', -name => '%s', -value => $title);
+    
+    hook('protocol_mod_away', -name => '%a', -value => $artist);
+    hook('protocol_mod_away', -name => '%s', -value => $title);
+
+    hook("protocol_commit_info") if $commit;
+}
+
+register_hook("signed_in", sub {
+	update();
+	
+	hook("tk_getmain")->repeat(5000, sub {
+		update();
+		$commit = 0;
+	});
+	
+});
+
+
+
+
+
+	    

plugins/stats.pl

@@ -0,0 +1,6 @@
+package Stats;
+
+open(STATS, user_file('stats.txt');
+
+
+1;