commit ceccb689a9fad2654819e44ca6b75fde6c20c655
Author: milkbone57 <milkbone57>
Date:   Fri Jul 11 20:17:20 2003 +0000

    Initial revision

diff --git a/Milkbone.pm b/Milkbone.pm
new file mode 100644
index 0000000..8eda6b9
--- /dev/null
+++ b/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;
diff --git a/build-temp.bat b/build-temp.bat
new file mode 100644
index 0000000..966f293
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/build.bat b/build.bat
new file mode 100644
index 0000000..44bd32e
--- /dev/null
+++ b/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 
\ No newline at end of file
diff --git a/docs/BUGS.txt b/docs/BUGS.txt
new file mode 100644
index 0000000..9f13666
--- /dev/null
+++ b/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)
\ No newline at end of file
diff --git a/docs/CREDIT.txt b/docs/CREDIT.txt
new file mode 100644
index 0000000..d5ba89f
--- /dev/null
+++ b/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 :)
\ No newline at end of file
diff --git a/docs/FILEMAP.txt b/docs/FILEMAP.txt
new file mode 100644
index 0000000..d62e00a
--- /dev/null
+++ b/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.
\ No newline at end of file
diff --git a/docs/HISTORY.txt b/docs/HISTORY.txt
new file mode 100644
index 0000000..33c7582
--- /dev/null
+++ b/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.
\ No newline at end of file
diff --git a/docs/HOOKS.txt b/docs/HOOKS.txt
new file mode 100644
index 0000000..1f2629a
--- /dev/null
+++ b/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);
diff --git a/docs/KLUDGES.txt b/docs/KLUDGES.txt
new file mode 100644
index 0000000..d8610d2
--- /dev/null
+++ b/docs/KLUDGES.txt
@@ -0,0 +1 @@
+the browser system
diff --git a/docs/OSCARMODS.txt b/docs/OSCARMODS.txt
new file mode 100644
index 0000000..d40c349
--- /dev/null
+++ b/docs/OSCARMODS.txt
@@ -0,0 +1,2 @@
+Accepts typing notifications
+Retrieves mobile information
\ No newline at end of file
diff --git a/docs/README.txt b/docs/README.txt
new file mode 100644
index 0000000..625542f
--- /dev/null
+++ b/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.
\ No newline at end of file
diff --git a/docs/SLOGANS.txt b/docs/SLOGANS.txt
new file mode 100644
index 0000000..cb34740
--- /dev/null
+++ b/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"
\ No newline at end of file
diff --git a/docs/SPECS.txt b/docs/SPECS.txt
new file mode 100644
index 0000000..cd7d290
--- /dev/null
+++ b/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 )
\ No newline at end of file
diff --git a/docs/VERSION.txt b/docs/VERSION.txt
new file mode 100644
index 0000000..63887f3
--- /dev/null
+++ b/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)
\ No newline at end of file
diff --git a/docs/WISHBONE.txt b/docs/WISHBONE.txt
new file mode 100644
index 0000000..c96d28b
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/docs/milkbone.pod b/docs/milkbone.pod
new file mode 100644
index 0000000..e69de29
diff --git a/errlog.txt b/errlog.txt
new file mode 100644
index 0000000..b305b7a
--- /dev/null
+++ b/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
+
diff --git a/images/away.bmp b/images/away.bmp
new file mode 100644
index 0000000..b0da5c6
Binary files /dev/null and b/images/away.bmp differ
diff --git a/images/blank.gif b/images/blank.gif
new file mode 100644
index 0000000..ca2b3ae
Binary files /dev/null and b/images/blank.gif differ
diff --git a/images/cell.gif b/images/cell.gif
new file mode 100644
index 0000000..3b87e87
Binary files /dev/null and b/images/cell.gif differ
diff --git a/images/icon.bmp b/images/icon.bmp
new file mode 100644
index 0000000..6c3f4ba
Binary files /dev/null and b/images/icon.bmp differ
diff --git a/images/icon.jpg b/images/icon.jpg
new file mode 100644
index 0000000..1195b8a
Binary files /dev/null and b/images/icon.jpg differ
diff --git a/images/logo.bmp b/images/logo.bmp
new file mode 100644
index 0000000..556b10e
Binary files /dev/null and b/images/logo.bmp differ
diff --git a/images/logon.bmp b/images/logon.bmp
new file mode 100644
index 0000000..09467ed
Binary files /dev/null and b/images/logon.bmp differ
diff --git a/images/mbone.ico b/images/mbone.ico
new file mode 100644
index 0000000..d2990d0
Binary files /dev/null and b/images/mbone.ico differ
diff --git a/images/splash.bmp b/images/splash.bmp
new file mode 100644
index 0000000..556b10e
Binary files /dev/null and b/images/splash.bmp differ
diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm
new file mode 100644
index 0000000..3c38963
--- /dev/null
+++ b/lib/File/Temp.pm
@@ -0,0 +1,1876 @@
+package File::Temp;
+
+=head1 NAME
+
+File::Temp - return name and handle of a temporary file safely
+
+=begin __INTERNALS
+
+=head1 PORTABILITY
+
+This module is designed to be portable across operating systems
+and it currently supports Unix, VMS, DOS, OS/2, Windows and
+Mac OS (Classic). When
+porting to a new OS there are generally three main issues
+that have to be solved:
+
+=over 4
+
+=item *
+
+Can the OS unlink an open file? If it can not then the
+C<_can_unlink_opened_file> method should be modified.
+
+=item *
+
+Are the return values from C<stat> reliable? By default all the
+return values from C<stat> are compared when unlinking a temporary
+file using the filename and the handle. Operating systems other than
+unix do not always have valid entries in all fields. If C<unlink0> fails
+then the C<stat> comparison should be modified accordingly.
+
+=item *
+
+Security. Systems that can not support a test for the sticky bit
+on a directory can not use the MEDIUM and HIGH security tests.
+The C<_can_do_level> method should be modified accordingly.
+
+=back
+
+=end __INTERNALS
+
+=head1 SYNOPSIS
+
+  use File::Temp qw/ tempfile tempdir /;
+
+  $dir = tempdir( CLEANUP => 1 );
+  ($fh, $filename) = tempfile( DIR => $dir );
+
+  ($fh, $filename) = tempfile( $template, DIR => $dir);
+  ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
+
+  $fh = tempfile();
+
+MkTemp family:
+
+  use File::Temp qw/ :mktemp  /;
+
+  ($fh, $file) = mkstemp( "tmpfileXXXXX" );
+  ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
+
+  $tmpdir = mkdtemp( $template );
+
+  $unopened_file = mktemp( $template );
+
+POSIX functions:
+
+  use File::Temp qw/ :POSIX /;
+
+  $file = tmpnam();
+  $fh = tmpfile();
+
+  ($fh, $file) = tmpnam();
+  $fh = tmpfile();
+
+
+Compatibility functions:
+
+  $unopened_file = File::Temp::tempnam( $dir, $pfx );
+
+=begin later
+
+Objects (NOT YET IMPLEMENTED):
+
+  require File::Temp;
+
+  $fh = new File::Temp($template);
+  $fname = $fh->filename;
+
+=end later
+
+=head1 DESCRIPTION
+
+C<File::Temp> can be used to create and open temporary files in a safe way.
+The tempfile() function can be used to return the name and the open
+filehandle of a temporary file.  The tempdir() function can
+be used to create a temporary directory.
+
+The security aspect of temporary file creation is emphasized such that
+a filehandle and filename are returned together.  This helps guarantee
+that a race condition can not occur where the temporary file is
+created by another process between checking for the existence of the
+file and its opening.  Additional security levels are provided to
+check, for example, that the sticky bit is set on world writable
+directories.  See L<"safe_level"> for more information.
+
+For compatibility with popular C library functions, Perl implementations of
+the mkstemp() family of functions are provided. These are, mkstemp(),
+mkstemps(), mkdtemp() and mktemp().
+
+Additionally, implementations of the standard L<POSIX|POSIX>
+tmpnam() and tmpfile() functions are provided if required.
+
+Implementations of mktemp(), tmpnam(), and tempnam() are provided,
+but should be used with caution since they return only a filename
+that was valid when function was called, so cannot guarantee
+that the file will not exist by the time the caller opens the filename.
+
+=cut
+
+# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
+# People would like a version on 5.005 so give them what they want :-)
+use 5.005;
+use strict;
+use Carp;
+use File::Spec 0.8;
+use File::Path qw/ rmtree /;
+use Fcntl 1.03;
+use Errno;
+require VMS::Stdio if $^O eq 'VMS';
+
+# Need the Symbol package if we are running older perl
+require Symbol if $] < 5.006;
+
+
+# use 'our' on v5.6.0
+use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG);
+
+$DEBUG = 0;
+
+# We are exporting functions
+
+use base qw/Exporter/;
+
+# Export list - to allow fine tuning of export table
+
+@EXPORT_OK = qw{
+	      tempfile
+	      tempdir
+	      tmpnam
+	      tmpfile
+	      mktemp
+	      mkstemp
+	      mkstemps
+	      mkdtemp
+	      unlink0
+		};
+
+# Groups of functions for export
+
+%EXPORT_TAGS = (
+		'POSIX' => [qw/ tmpnam tmpfile /],
+		'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
+	       );
+
+# add contents of these tags to @EXPORT
+Exporter::export_tags('POSIX','mktemp');
+
+# Version number
+
+$VERSION = '0.13';
+
+# This is a list of characters that can be used in random filenames
+
+my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
+	         a b c d e f g h i j k l m n o p q r s t u v w x y z
+	         0 1 2 3 4 5 6 7 8 9 _
+	     /);
+
+# Maximum number of tries to make a temp file before failing
+
+use constant MAX_TRIES => 10;
+
+# Minimum number of X characters that should be in a template
+use constant MINX => 4;
+
+# Default template when no template supplied
+
+use constant TEMPXXX => 'X' x 10;
+
+# Constants for the security level
+
+use constant STANDARD => 0;
+use constant MEDIUM   => 1;
+use constant HIGH     => 2;
+
+# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
+# us an optimisation when many temporary files are requested
+
+my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
+
+unless ($^O eq 'MacOS') {
+  for my $oflag (qw/ BINARY NOINHERIT /) {
+    my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+    no strict 'refs';
+    $OPENFLAGS |= $bit if eval {
+      # Make sure that redefined die handlers do not cause problems
+      # eg CGI::Carp
+      local $SIG{__DIE__} = sub {};
+      local $SIG{__WARN__} = sub {};
+      $bit = &$func();
+      1;
+    };
+  }
+}
+
+# On some systems the O_TEMPORARY flag can be used to tell the OS
+# to automatically remove the file when it is closed. This is fine
+# in most cases but not if tempfile is called with UNLINK=>0 and
+# the filename is requested -- in the case where the filename is to
+# be passed to another routine. This happens on windows. We overcome
+# this by using a second open flags variable
+
+my $OPENTEMPFLAGS = $OPENFLAGS;
+unless ($^O eq 'MacOS') {
+  for my $oflag (qw/ TEMPORARY /) {
+    my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+    no strict 'refs';
+    $OPENTEMPFLAGS |= $bit if eval {
+      # Make sure that redefined die handlers do not cause problems
+      # eg CGI::Carp
+      local $SIG{__DIE__} = sub {};
+      local $SIG{__WARN__} = sub {};
+      $bit = &$func();
+      1;
+    };
+  }
+}
+
+# INTERNAL ROUTINES - not to be used outside of package
+
+# Generic routine for getting a temporary filename
+# modelled on OpenBSD _gettemp() in mktemp.c
+
+# The template must contain X's that are to be replaced
+# with the random values
+
+#  Arguments:
+
+#  TEMPLATE   - string containing the XXXXX's that is converted
+#           to a random filename and opened if required
+
+# Optionally, a hash can also be supplied containing specific options
+#   "open" => if true open the temp file, else just return the name
+#             default is 0
+#   "mkdir"=> if true, we are creating a temp directory rather than tempfile
+#             default is 0
+#   "suffixlen" => number of characters at end of PATH to be ignored.
+#                  default is 0.
+#   "unlink_on_close" => indicates that, if possible,  the OS should remove
+#                        the file as soon as it is closed. Usually indicates
+#                        use of the O_TEMPORARY flag to sysopen.
+#                        Usually irrelevant on unix
+
+# Optionally a reference to a scalar can be passed into the function
+# On error this will be used to store the reason for the error
+#   "ErrStr"  => \$errstr
+
+# "open" and "mkdir" can not both be true
+# "unlink_on_close" is not used when "mkdir" is true.
+
+# The default options are equivalent to mktemp().
+
+# Returns:
+#   filehandle - open file handle (if called with doopen=1, else undef)
+#   temp name  - name of the temp file or directory
+
+# For example:
+#   ($fh, $name) = _gettemp($template, "open" => 1);
+
+# for the current version, failures are associated with
+# stored in an error string and returned to give the reason whilst debugging
+# This routine is not called by any external function
+sub _gettemp {
+
+  croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
+    unless scalar(@_) >= 1;
+
+  # the internal error string - expect it to be overridden
+  # Need this in case the caller decides not to supply us a value
+  # need an anonymous scalar
+  my $tempErrStr;
+
+  # Default options
+  my %options = (
+		 "open" => 0,
+		 "mkdir" => 0,
+		 "suffixlen" => 0,
+		 "unlink_on_close" => 0,
+		 "ErrStr" => \$tempErrStr,
+		);
+
+  # Read the template
+  my $template = shift;
+  if (ref($template)) {
+    # Use a warning here since we have not yet merged ErrStr
+    carp "File::Temp::_gettemp: template must not be a reference";
+    return ();
+  }
+
+  # Check that the number of entries on stack are even
+  if (scalar(@_) % 2 != 0) {
+    # Use a warning here since we have not yet merged ErrStr
+    carp "File::Temp::_gettemp: Must have even number of options";
+    return ();
+  }
+
+  # Read the options and merge with defaults
+  %options = (%options, @_)  if @_;
+
+  # Make sure the error string is set to undef
+  ${$options{ErrStr}} = undef;
+
+  # Can not open the file and make a directory in a single call
+  if ($options{"open"} && $options{"mkdir"}) {
+    ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
+    return ();
+  }
+
+  # Find the start of the end of the  Xs (position of last X)
+  # Substr starts from 0
+  my $start = length($template) - 1 - $options{"suffixlen"};
+
+  # Check that we have at least MINX x X (eg 'XXXX") at the end of the string
+  # (taking suffixlen into account). Any fewer is insecure.
+
+  # Do it using substr - no reason to use a pattern match since
+  # we know where we are looking and what we are looking for
+
+  if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
+    ${$options{ErrStr}} = "The template must contain at least ".
+      MINX . " 'X' characters\n";
+    return ();
+  }
+
+  # Replace all the X at the end of the substring with a
+  # random character or just all the XX at the end of a full string.
+  # Do it as an if, since the suffix adjusts which section to replace
+  # and suffixlen=0 returns nothing if used in the substr directly
+  # and generate a full path from the template
+
+  my $path = _replace_XX($template, $options{"suffixlen"});
+
+
+  # Split the path into constituent parts - eventually we need to check
+  # whether the directory exists
+  # We need to know whether we are making a temp directory
+  # or a tempfile
+
+  my ($volume, $directories, $file);
+  my $parent; # parent directory
+  if ($options{"mkdir"}) {
+    # There is no filename at the end
+    ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
+
+    # The parent is then $directories without the last directory
+    # Split the directory and put it back together again
+    my @dirs = File::Spec->splitdir($directories);
+
+    # If @dirs only has one entry (i.e. the directory template) that means
+    # we are in the current directory
+    if ($#dirs == 0) {
+      $parent = File::Spec->curdir;
+    } else {
+
+      if ($^O eq 'VMS') {  # need volume to avoid relative dir spec
+        $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
+        $parent = 'sys$disk:[]' if $parent eq '';
+      } else {
+
+	# Put it back together without the last one
+	$parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
+
+	# ...and attach the volume (no filename)
+	$parent = File::Spec->catpath($volume, $parent, '');
+      }
+
+    }
+
+  } else {
+
+    # Get rid of the last filename (use File::Basename for this?)
+    ($volume, $directories, $file) = File::Spec->splitpath( $path );
+
+    # Join up without the file part
+    $parent = File::Spec->catpath($volume,$directories,'');
+
+    # If $parent is empty replace with curdir
+    $parent = File::Spec->curdir
+      unless $directories ne '';
+
+  }
+
+  # Check that the parent directories exist
+  # Do this even for the case where we are simply returning a name
+  # not a file -- no point returning a name that includes a directory
+  # that does not exist or is not writable
+
+  unless (-d $parent) {
+    ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
+    return ();
+  }
+  unless (-w _) {
+    ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
+      return ();
+  }
+
+
+  # Check the stickiness of the directory and chown giveaway if required
+  # If the directory is world writable the sticky bit
+  # must be set
+
+  if (File::Temp->safe_level == MEDIUM) {
+    my $safeerr;
+    unless (_is_safe($parent,\$safeerr)) {
+      ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
+      return ();
+    }
+  } elsif (File::Temp->safe_level == HIGH) {
+    my $safeerr;
+    unless (_is_verysafe($parent, \$safeerr)) {
+      ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
+      return ();
+    }
+  }
+
+
+  # Now try MAX_TRIES time to open the file
+  for (my $i = 0; $i < MAX_TRIES; $i++) {
+
+    # Try to open the file if requested
+    if ($options{"open"}) {
+      my $fh;
+
+      # If we are running before perl5.6.0 we can not auto-vivify
+      if ($] < 5.006) {
+	$fh = &Symbol::gensym;
+      }
+
+      # Try to make sure this will be marked close-on-exec
+      # XXX: Win32 doesn't respect this, nor the proper fcntl,
+      #      but may have O_NOINHERIT. This may or may not be in Fcntl.
+      local $^F = 2;
+
+      # Store callers umask
+      my $umask = umask();
+
+      # Set a known umask
+      umask(066);
+
+      # Attempt to open the file
+      my $open_success = undef;
+      if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) {
+        # make it auto delete on close by setting FAB$V_DLT bit
+	$fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
+	$open_success = $fh;
+      } else {
+	my $flags = ( $options{"unlink_on_close"} ?
+		      $OPENTEMPFLAGS :
+		      $OPENFLAGS );
+	$open_success = sysopen($fh, $path, $flags, 0600);
+      }
+      if ( $open_success ) {
+
+	# Reset umask
+	umask($umask) if defined $umask;
+
+	# Opened successfully - return file handle and name
+	return ($fh, $path);
+
+      } else {
+	# Reset umask
+	umask($umask) if defined $umask;
+
+	# Error opening file - abort with error
+	# if the reason was anything but EEXIST
+	unless ($!{EEXIST}) {
+	  ${$options{ErrStr}} = "Could not create temp file $path: $!";
+	  return ();
+	}
+
+	# Loop round for another try
+
+      }
+    } elsif ($options{"mkdir"}) {
+
+      # Store callers umask
+      my $umask = umask();
+
+      # Set a known umask
+      umask(066);
+
+      # Open the temp directory
+      if (mkdir( $path, 0700)) {
+	# created okay
+	# Reset umask
+	umask($umask) if defined $umask;
+
+	return undef, $path;
+      } else {
+
+	# Reset umask
+	umask($umask) if defined $umask;
+
+	# Abort with error if the reason for failure was anything
+	# except EEXIST
+	unless ($!{EEXIST}) {
+	  ${$options{ErrStr}} = "Could not create directory $path: $!";
+	  return ();
+	}
+
+	# Loop round for another try
+
+      }
+
+    } else {
+
+      # Return true if the file can not be found
+      # Directory has been checked previously
+
+      return (undef, $path) unless -e $path;
+
+      # Try again until MAX_TRIES
+
+    }
+
+    # Did not successfully open the tempfile/dir
+    # so try again with a different set of random letters
+    # No point in trying to increment unless we have only
+    # 1 X say and the randomness could come up with the same
+    # file MAX_TRIES in a row.
+
+    # Store current attempt - in principal this implies that the
+    # 3rd time around the open attempt that the first temp file
+    # name could be generated again. Probably should store each
+    # attempt and make sure that none are repeated
+
+    my $original = $path;
+    my $counter = 0;  # Stop infinite loop
+    my $MAX_GUESS = 50;
+
+    do {
+
+      # Generate new name from original template
+      $path = _replace_XX($template, $options{"suffixlen"});
+
+      $counter++;
+
+    } until ($path ne $original || $counter > $MAX_GUESS);
+
+    # Check for out of control looping
+    if ($counter > $MAX_GUESS) {
+      ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
+      return ();
+    }
+
+  }
+
+  # If we get here, we have run out of tries
+  ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
+    . MAX_TRIES . ") to open temp file/dir";
+
+  return ();
+
+}
+
+# Internal routine to return a random character from the
+# character list. Does not do an srand() since rand()
+# will do one automatically
+
+# No arguments. Return value is the random character
+
+# No longer called since _replace_XX runs a few percent faster if
+# I inline the code. This is important if we are creating thousands of
+# temporary files.
+
+sub _randchar {
+
+  $CHARS[ int( rand( $#CHARS ) ) ];
+
+}
+
+# Internal routine to replace the XXXX... with random characters
+# This has to be done by _gettemp() every time it fails to
+# open a temp file/dir
+
+# Arguments:  $template (the template with XXX),
+#             $ignore   (number of characters at end to ignore)
+
+# Returns:    modified template
+
+sub _replace_XX {
+
+  croak 'Usage: _replace_XX($template, $ignore)'
+    unless scalar(@_) == 2;
+
+  my ($path, $ignore) = @_;
+
+  # Do it as an if, since the suffix adjusts which section to replace
+  # and suffixlen=0 returns nothing if used in the substr directly
+  # Alternatively, could simply set $ignore to length($path)-1
+  # Don't want to always use substr when not required though.
+
+  if ($ignore) {
+    substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
+  } else {
+    $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
+  }
+
+  return $path;
+}
+
+# internal routine to check to see if the directory is safe
+# First checks to see if the directory is not owned by the
+# current user or root. Then checks to see if anyone else
+# can write to the directory and if so, checks to see if
+# it has the sticky bit set
+
+# Will not work on systems that do not support sticky bit
+
+#Args:  directory path to check
+#       Optionally: reference to scalar to contain error message
+# Returns true if the path is safe and false otherwise.
+# Returns undef if can not even run stat() on the path
+
+# This routine based on version written by Tom Christiansen
+
+# Presumably, by the time we actually attempt to create the
+# file or directory in this directory, it may not be safe
+# anymore... Have to run _is_safe directly after the open.
+
+sub _is_safe {
+
+  my $path = shift;
+  my $err_ref = shift;
+
+  # Stat path
+  my @info = stat($path);
+  unless (scalar(@info)) {
+    $$err_ref = "stat(path) returned no values";
+    return 0;
+  };
+  return 1 if $^O eq 'VMS';  # owner delete control at file level
+
+  # Check to see whether owner is neither superuser (or a system uid) nor me
+  # Use the real uid from the $< variable
+  # UID is in [4]
+  if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
+
+    Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
+		File::Temp->top_system_uid());
+
+    $$err_ref = "Directory owned neither by root nor the current user"
+      if ref($err_ref);
+    return 0;
+  }
+
+  # check whether group or other can write file
+  # use 066 to detect either reading or writing
+  # use 022 to check writability
+  # Do it with S_IWOTH and S_IWGRP for portability (maybe)
+  # mode is in info[2]
+  if (($info[2] & &Fcntl::S_IWGRP) ||   # Is group writable?
+      ($info[2] & &Fcntl::S_IWOTH) ) {  # Is world writable?
+    # Must be a directory
+    unless (-d _) {
+      $$err_ref = "Path ($path) is not a directory"
+      if ref($err_ref);
+      return 0;
+    }
+    # Must have sticky bit set
+    unless (-k _) {
+      $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
+	if ref($err_ref);
+      return 0;
+    }
+  }
+
+  return 1;
+}
+
+# Internal routine to check whether a directory is safe
+# for temp files. Safer than _is_safe since it checks for
+# the possibility of chown giveaway and if that is a possibility
+# checks each directory in the path to see if it is safe (with _is_safe)
+
+# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
+# directory anyway.
+
+# Takes optional second arg as scalar ref to error reason
+
+sub _is_verysafe {
+
+  # Need POSIX - but only want to bother if really necessary due to overhead
+  require POSIX;
+
+  my $path = shift;
+  print "_is_verysafe testing $path\n" if $DEBUG;
+  return 1 if $^O eq 'VMS';  # owner delete control at file level
+
+  my $err_ref = shift;
+
+  # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
+  # and If it is not there do the extensive test
+  my $chown_restricted;
+  $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
+    if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
+
+  # If chown_resticted is set to some value we should test it
+  if (defined $chown_restricted) {
+
+    # Return if the current directory is safe
+    return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
+
+  }
+
+  # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
+  # was not avialable or the symbol was there but chown giveaway
+  # is allowed. Either way, we now have to test the entire tree for
+  # safety.
+
+  # Convert path to an absolute directory if required
+  unless (File::Spec->file_name_is_absolute($path)) {
+    $path = File::Spec->rel2abs($path);
+  }
+
+  # Split directory into components - assume no file
+  my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
+
+  # Slightly less efficient than having a function in File::Spec
+  # to chop off the end of a directory or even a function that
+  # can handle ../ in a directory tree
+  # Sometimes splitdir() returns a blank at the end
+  # so we will probably check the bottom directory twice in some cases
+  my @dirs = File::Spec->splitdir($directories);
+
+  # Concatenate one less directory each time around
+  foreach my $pos (0.. $#dirs) {
+    # Get a directory name
+    my $dir = File::Spec->catpath($volume,
+				  File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
+				  ''
+				  );
+
+    print "TESTING DIR $dir\n" if $DEBUG;
+
+    # Check the directory
+    return 0 unless _is_safe($dir,$err_ref);
+
+  }
+
+  return 1;
+}
+
+
+
+# internal routine to determine whether unlink works on this
+# platform for files that are currently open.
+# Returns true if we can, false otherwise.
+
+# Currently WinNT, OS/2 and VMS can not unlink an opened file
+# On VMS this is because the O_EXCL flag is used to open the
+# temporary file. Currently I do not know enough about the issues
+# on VMS to decide whether O_EXCL is a requirement.
+
+sub _can_unlink_opened_file {
+
+  if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') {
+    return 0;
+  } else {
+    return 1;
+  }
+
+}
+
+# internal routine to decide which security levels are allowed
+# see safe_level() for more information on this
+
+# Controls whether the supplied security level is allowed
+
+#   $cando = _can_do_level( $level )
+
+sub _can_do_level {
+
+  # Get security level
+  my $level = shift;
+
+  # Always have to be able to do STANDARD
+  return 1 if $level == STANDARD;
+
+  # Currently, the systems that can do HIGH or MEDIUM are identical
+  if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS') {
+    return 0;
+  } else {
+    return 1;
+  }
+
+}
+
+# This routine sets up a deferred unlinking of a specified
+# filename and filehandle. It is used in the following cases:
+#  - Called by unlink0 if an opened file can not be unlinked
+#  - Called by tempfile() if files are to be removed on shutdown
+#  - Called by tempdir() if directories are to be removed on shutdown
+
+# Arguments:
+#   _deferred_unlink( $fh, $fname, $isdir );
+#
+#   - filehandle (so that it can be expclicitly closed if open
+#   - filename   (the thing we want to remove)
+#   - isdir      (flag to indicate that we are being given a directory)
+#                 [and hence no filehandle]
+
+# Status is not referred to since all the magic is done with an END block
+
+{
+  # Will set up two lexical variables to contain all the files to be
+  # removed. One array for files, another for directories
+  # They will only exist in this block
+  # This means we only have to set up a single END block to remove all files
+  # @files_to_unlink contains an array ref with the filehandle and filename
+  my (@files_to_unlink, @dirs_to_unlink);
+
+  # Set up an end block to use these arrays
+  END {
+    # Files
+    foreach my $file (@files_to_unlink) {
+      # close the filehandle without checking its state
+      # in order to make real sure that this is closed
+      # if its already closed then I dont care about the answer
+      # probably a better way to do this
+      close($file->[0]);  # file handle is [0]
+
+      if (-f $file->[1]) {  # file name is [1]
+	unlink $file->[1] or warn "Error removing ".$file->[1];
+      }
+    }
+    # Dirs
+    foreach my $dir (@dirs_to_unlink) {
+      if (-d $dir) {
+	rmtree($dir, $DEBUG, 1);
+      }
+    }
+
+  }
+
+  # This is the sub called to register a file for deferred unlinking
+  # This could simply store the input parameters and defer everything
+  # until the END block. For now we do a bit of checking at this
+  # point in order to make sure that (1) we have a file/dir to delete
+  # and (2) we have been called with the correct arguments.
+  sub _deferred_unlink {
+
+    croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
+      unless scalar(@_) == 3;
+
+    my ($fh, $fname, $isdir) = @_;
+
+    warn "Setting up deferred removal of $fname\n"
+      if $DEBUG;
+
+    # If we have a directory, check that it is a directory
+    if ($isdir) {
+
+      if (-d $fname) {
+
+	# Directory exists so store it
+	# first on VMS turn []foo into [.foo] for rmtree
+	$fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
+	push (@dirs_to_unlink, $fname);
+
+      } else {
+	carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
+      }
+
+    } else {
+
+      if (-f $fname) {
+
+	# file exists so store handle and name for later removal
+	push(@files_to_unlink, [$fh, $fname]);
+
+      } else {
+	carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
+      }
+
+    }
+
+  }
+
+
+}
+
+=head1 FUNCTIONS
+
+This section describes the recommended interface for generating
+temporary files and directories.
+
+=over 4
+
+=item B<tempfile>
+
+This is the basic function to generate temporary files.
+The behaviour of the file can be changed using various options:
+
+  ($fh, $filename) = tempfile();
+
+Create a temporary file in  the directory specified for temporary
+files, as specified by the tmpdir() function in L<File::Spec>.
+
+  ($fh, $filename) = tempfile($template);
+
+Create a temporary file in the current directory using the supplied
+template.  Trailing `X' characters are replaced with random letters to
+generate the filename.  At least four `X' characters must be present
+in the template.
+
+  ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
+
+Same as previously, except that a suffix is added to the template
+after the `X' translation.  Useful for ensuring that a temporary
+filename has a particular extension when needed by other applications.
+But see the WARNING at the end.
+
+  ($fh, $filename) = tempfile($template, DIR => $dir);
+
+Translates the template as before except that a directory name
+is specified.
+
+  ($fh, $filename) = tempfile($template, UNLINK => 1);
+
+Return the filename and filehandle as before except that the file is
+automatically removed when the program exits. Default is for the file
+to be removed if a file handle is requested and to be kept if the
+filename is requested. In a scalar context (where no filename is
+returned) the file is always deleted either on exit or when it is closed.
+
+If the template is not specified, a template is always
+automatically generated. This temporary file is placed in tmpdir()
+(L<File::Spec>) unless a directory is specified explicitly with the
+DIR option.
+
+  $fh = tempfile( $template, DIR => $dir );
+
+If called in scalar context, only the filehandle is returned
+and the file will automatically be deleted when closed (see
+the description of tmpfile() elsewhere in this document).
+This is the preferred mode of operation, as if you only
+have a filehandle, you can never create a race condition
+by fumbling with the filename. On systems that can not unlink
+an open file or can not mark a file as temporary when it is opened
+(for example, Windows NT uses the C<O_TEMPORARY> flag))
+the file is marked for deletion when the program ends (equivalent
+to setting UNLINK to 1). The C<UNLINK> flag is ignored if present.
+
+  (undef, $filename) = tempfile($template, OPEN => 0);
+
+This will return the filename based on the template but
+will not open this file.  Cannot be used in conjunction with
+UNLINK set to true. Default is to always open the file
+to protect from possible race conditions. A warning is issued
+if warnings are turned on. Consider using the tmpnam()
+and mktemp() functions described elsewhere in this document
+if opening the file is not required.
+
+Options can be combined as required.
+
+=cut
+
+sub tempfile {
+
+  # Can not check for argument count since we can have any
+  # number of args
+
+  # Default options
+  my %options = (
+		 "DIR"    => undef,  # Directory prefix
+                "SUFFIX" => '',     # Template suffix
+                "UNLINK" => 0,      # Do not unlink file on exit
+                "OPEN"   => 1,      # Open file
+		);
+
+  # Check to see whether we have an odd or even number of arguments
+  my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
+
+  # Read the options and merge with defaults
+  %options = (%options, @_)  if @_;
+
+  # First decision is whether or not to open the file
+  if (! $options{"OPEN"}) {
+
+    warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
+      if $^W;
+
+  }
+
+  if ($options{"DIR"} and $^O eq 'VMS') {
+
+      # on VMS turn []foo into [.foo] for concatenation
+      $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
+  }
+
+  # Construct the template
+
+  # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
+  # functions or simply constructing a template and using _gettemp()
+  # explicitly. Go for the latter
+
+  # First generate a template if not defined and prefix the directory
+  # If no template must prefix the temp directory
+  if (defined $template) {
+    if ($options{"DIR"}) {
+
+      $template = File::Spec->catfile($options{"DIR"}, $template);
+
+    }
+
+  } else {
+
+    if ($options{"DIR"}) {
+
+      $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
+
+    } else {
+
+      $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
+
+    }
+
+  }
+
+  # Now add a suffix
+  $template .= $options{"SUFFIX"};
+
+  # Determine whether we should tell _gettemp to unlink the file
+  # On unix this is irrelevant and can be worked out after the file is
+  # opened (simply by unlinking the open filehandle). On Windows or VMS
+  # we have to indicate temporary-ness when we open the file. In general
+  # we only want a true temporary file if we are returning just the
+  # filehandle - if the user wants the filename they probably do not
+  # want the file to disappear as soon as they close it.
+  # For this reason, tie unlink_on_close to the return context regardless
+  # of OS.
+  my $unlink_on_close = ( wantarray ? 0 : 1);
+
+  # Create the file
+  my ($fh, $path, $errstr);
+  croak "Error in tempfile() using $template: $errstr"
+    unless (($fh, $path) = _gettemp($template,
+				    "open" => $options{'OPEN'},
+				    "mkdir"=> 0 ,
+                                    "unlink_on_close" => $unlink_on_close,
+				    "suffixlen" => length($options{'SUFFIX'}),
+				    "ErrStr" => \$errstr,
+				   ) );
+
+  # Set up an exit handler that can do whatever is right for the
+  # system. This removes files at exit when requested explicitly or when
+  # system is asked to unlink_on_close but is unable to do so because
+  # of OS limitations.
+  # The latter should be achieved by using a tied filehandle.
+  # Do not check return status since this is all done with END blocks.
+  _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
+
+  # Return
+  if (wantarray()) {
+
+    if ($options{'OPEN'}) {
+      return ($fh, $path);
+    } else {
+      return (undef, $path);
+    }
+
+  } else {
+
+    # Unlink the file. It is up to unlink0 to decide what to do with
+    # this (whether to unlink now or to defer until later)
+    unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
+
+    # Return just the filehandle.
+    return $fh;
+  }
+
+
+}
+
+=item B<tempdir>
+
+This is the recommended interface for creation of temporary directories.
+The behaviour of the function depends on the arguments:
+
+  $tempdir = tempdir();
+
+Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
+
+  $tempdir = tempdir( $template );
+
+Create a directory from the supplied template. This template is
+similar to that described for tempfile(). `X' characters at the end
+of the template are replaced with random letters to construct the
+directory name. At least four `X' characters must be in the template.
+
+  $tempdir = tempdir ( DIR => $dir );
+
+Specifies the directory to use for the temporary directory.
+The temporary directory name is derived from an internal template.
+
+  $tempdir = tempdir ( $template, DIR => $dir );
+
+Prepend the supplied directory name to the template. The template
+should not include parent directory specifications itself. Any parent
+directory specifications are removed from the template before
+prepending the supplied directory.
+
+  $tempdir = tempdir ( $template, TMPDIR => 1 );
+
+Using the supplied template, create the temporary directory in
+a standard location for temporary files. Equivalent to doing
+
+  $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
+
+but shorter. Parent directory specifications are stripped from the
+template itself. The C<TMPDIR> option is ignored if C<DIR> is set
+explicitly.  Additionally, C<TMPDIR> is implied if neither a template
+nor a directory are supplied.
+
+  $tempdir = tempdir( $template, CLEANUP => 1);
+
+Create a temporary directory using the supplied template, but
+attempt to remove it (and all files inside it) when the program
+exits. Note that an attempt will be made to remove all files from
+the directory even if they were not created by this module (otherwise
+why ask to clean it up?). The directory removal is made with
+the rmtree() function from the L<File::Path|File::Path> module.
+Of course, if the template is not specified, the temporary directory
+will be created in tmpdir() and will also be removed at program exit.
+
+=cut
+
+# '
+
+sub tempdir  {
+
+  # Can not check for argument count since we can have any
+  # number of args
+
+  # Default options
+  my %options = (
+		 "CLEANUP"    => 0,  # Remove directory on exit
+		 "DIR"        => '', # Root directory
+		 "TMPDIR"     => 0,  # Use tempdir with template
+		);
+
+  # Check to see whether we have an odd or even number of arguments
+  my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
+
+  # Read the options and merge with defaults
+  %options = (%options, @_)  if @_;
+
+  # Modify or generate the template
+
+  # Deal with the DIR and TMPDIR options
+  if (defined $template) {
+
+    # Need to strip directory path if using DIR or TMPDIR
+    if ($options{'TMPDIR'} || $options{'DIR'}) {
+
+      # Strip parent directory from the filename
+      #
+      # There is no filename at the end
+      $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
+      my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
+
+      # Last directory is then our template
+      $template = (File::Spec->splitdir($directories))[-1];
+
+      # Prepend the supplied directory or temp dir
+      if ($options{"DIR"}) {
+
+        $template = File::Spec->catdir($options{"DIR"}, $template);
+
+      } elsif ($options{TMPDIR}) {
+
+	# Prepend tmpdir
+	$template = File::Spec->catdir(File::Spec->tmpdir, $template);
+
+      }
+
+    }
+
+  } else {
+
+    if ($options{"DIR"}) {
+
+      $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
+
+    } else {
+
+      $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
+
+    }
+
+  }
+
+  # Create the directory
+  my $tempdir;
+  my $suffixlen = 0;
+  if ($^O eq 'VMS') {  # dir names can end in delimiters
+    $template =~ m/([\.\]:>]+)$/;
+    $suffixlen = length($1);
+  }
+  if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
+    # dir name has a trailing ':'
+    ++$suffixlen;
+  }
+
+  my $errstr;
+  croak "Error in tempdir() using $template: $errstr"
+    unless ((undef, $tempdir) = _gettemp($template,
+				    "open" => 0,
+				    "mkdir"=> 1 ,
+				    "suffixlen" => $suffixlen,
+				    "ErrStr" => \$errstr,
+				   ) );
+
+  # Install exit handler; must be dynamic to get lexical
+  if ( $options{'CLEANUP'} && -d $tempdir) {
+    _deferred_unlink(undef, $tempdir, 1);
+  }
+
+  # Return the dir name
+  return $tempdir;
+
+}
+
+=back
+
+=head1 MKTEMP FUNCTIONS
+
+The following functions are Perl implementations of the
+mktemp() family of temp file generation system calls.
+
+=over 4
+
+=item B<mkstemp>
+
+Given a template, returns a filehandle to the temporary file and the name
+of the file.
+
+  ($fh, $name) = mkstemp( $template );
+
+In scalar context, just the filehandle is returned.
+
+The template may be any filename with some number of X's appended
+to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
+with unique alphanumeric combinations.
+
+=cut
+
+
+
+sub mkstemp {
+
+  croak "Usage: mkstemp(template)"
+    if scalar(@_) != 1;
+
+  my $template = shift;
+
+  my ($fh, $path, $errstr);
+  croak "Error in mkstemp using $template: $errstr"
+    unless (($fh, $path) = _gettemp($template,
+				    "open" => 1,
+				    "mkdir"=> 0 ,
+				    "suffixlen" => 0,
+				    "ErrStr" => \$errstr,
+				   ) );
+
+  if (wantarray()) {
+    return ($fh, $path);
+  } else {
+    return $fh;
+  }
+
+}
+
+
+=item B<mkstemps>
+
+Similar to mkstemp(), except that an extra argument can be supplied
+with a suffix to be appended to the template.
+
+  ($fh, $name) = mkstemps( $template, $suffix );
+
+For example a template of C<testXXXXXX> and suffix of C<.dat>
+would generate a file similar to F<testhGji_w.dat>.
+
+Returns just the filehandle alone when called in scalar context.
+
+=cut
+
+sub mkstemps {
+
+  croak "Usage: mkstemps(template, suffix)"
+    if scalar(@_) != 2;
+
+
+  my $template = shift;
+  my $suffix   = shift;
+
+  $template .= $suffix;
+
+  my ($fh, $path, $errstr);
+  croak "Error in mkstemps using $template: $errstr"
+    unless (($fh, $path) = _gettemp($template,
+				    "open" => 1,
+				    "mkdir"=> 0 ,
+				    "suffixlen" => length($suffix),
+				    "ErrStr" => \$errstr,
+				   ) );
+
+  if (wantarray()) {
+    return ($fh, $path);
+  } else {
+    return $fh;
+  }
+
+}
+
+=item B<mkdtemp>
+
+Create a directory from a template. The template must end in
+X's that are replaced by the routine.
+
+  $tmpdir_name = mkdtemp($template);
+
+Returns the name of the temporary directory created.
+Returns undef on failure.
+
+Directory must be removed by the caller.
+
+=cut
+
+#' # for emacs
+
+sub mkdtemp {
+
+  croak "Usage: mkdtemp(template)"
+    if scalar(@_) != 1;
+
+  my $template = shift;
+  my $suffixlen = 0;
+  if ($^O eq 'VMS') {  # dir names can end in delimiters
+    $template =~ m/([\.\]:>]+)$/;
+    $suffixlen = length($1);
+  }
+  if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
+    # dir name has a trailing ':'
+    ++$suffixlen;
+  }
+  my ($junk, $tmpdir, $errstr);
+  croak "Error creating temp directory from template $template\: $errstr"
+    unless (($junk, $tmpdir) = _gettemp($template,
+					"open" => 0,
+					"mkdir"=> 1 ,
+					"suffixlen" => $suffixlen,
+					"ErrStr" => \$errstr,
+				       ) );
+
+  return $tmpdir;
+
+}
+
+=item B<mktemp>
+
+Returns a valid temporary filename but does not guarantee
+that the file will not be opened by someone else.
+
+  $unopened_file = mktemp($template);
+
+Template is the same as that required by mkstemp().
+
+=cut
+
+sub mktemp {
+
+  croak "Usage: mktemp(template)"
+    if scalar(@_) != 1;
+
+  my $template = shift;
+
+  my ($tmpname, $junk, $errstr);
+  croak "Error getting name to temp file from template $template: $errstr"
+    unless (($junk, $tmpname) = _gettemp($template,
+					 "open" => 0,
+					 "mkdir"=> 0 ,
+					 "suffixlen" => 0,
+					 "ErrStr" => \$errstr,
+					 ) );
+
+  return $tmpname;
+}
+
+=back
+
+=head1 POSIX FUNCTIONS
+
+This section describes the re-implementation of the tmpnam()
+and tmpfile() functions described in L<POSIX>
+using the mkstemp() from this module.
+
+Unlike the L<POSIX|POSIX> implementations, the directory used
+for the temporary file is not specified in a system include
+file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
+returned by L<File::Spec|File::Spec>. On some implementations this
+location can be set using the C<TMPDIR> environment variable, which
+may not be secure.
+If this is a problem, simply use mkstemp() and specify a template.
+
+=over 4
+
+=item B<tmpnam>
+
+When called in scalar context, returns the full name (including path)
+of a temporary file (uses mktemp()). The only check is that the file does
+not already exist, but there is no guarantee that that condition will
+continue to apply.
+
+  $file = tmpnam();
+
+When called in list context, a filehandle to the open file and
+a filename are returned. This is achieved by calling mkstemp()
+after constructing a suitable template.
+
+  ($fh, $file) = tmpnam();
+
+If possible, this form should be used to prevent possible
+race conditions.
+
+See L<File::Spec/tmpdir> for information on the choice of temporary
+directory for a particular operating system.
+
+=cut
+
+sub tmpnam {
+
+   # Retrieve the temporary directory name
+   my $tmpdir = File::Spec->tmpdir;
+
+   croak "Error temporary directory is not writable"
+     if $tmpdir eq '';
+
+   # Use a ten character template and append to tmpdir
+   my $template = File::Spec->catfile($tmpdir, TEMPXXX);
+
+   if (wantarray() ) {
+       return mkstemp($template);
+   } else {
+       return mktemp($template);
+   }
+
+}
+
+=item B<tmpfile>
+
+Returns the filehandle of a temporary file.
+
+  $fh = tmpfile();
+
+The file is removed when the filehandle is closed or when the program
+exits. No access to the filename is provided.
+
+If the temporary file can not be created undef is returned.
+Currently this command will probably not work when the temporary
+directory is on an NFS file system.
+
+=cut
+
+sub tmpfile {
+
+  # Simply call tmpnam() in a list context
+  my ($fh, $file) = tmpnam();
+
+  # Make sure file is removed when filehandle is closed
+  # This will fail on NFS
+  unlink0($fh, $file)
+    or return undef;
+
+  return $fh;
+
+}
+
+=back
+
+=head1 ADDITIONAL FUNCTIONS
+
+These functions are provided for backwards compatibility
+with common tempfile generation C library functions.
+
+They are not exported and must be addressed using the full package
+name.
+
+=over 4
+
+=item B<tempnam>
+
+Return the name of a temporary file in the specified directory
+using a prefix. The file is guaranteed not to exist at the time
+the function was called, but such guarantees are good for one
+clock tick only.  Always use the proper form of C<sysopen>
+with C<O_CREAT | O_EXCL> if you must open such a filename.
+
+  $filename = File::Temp::tempnam( $dir, $prefix );
+
+Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
+(using unix file convention as an example)
+
+Because this function uses mktemp(), it can suffer from race conditions.
+
+=cut
+
+sub tempnam {
+
+  croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
+
+  my ($dir, $prefix) = @_;
+
+  # Add a string to the prefix
+  $prefix .= 'XXXXXXXX';
+
+  # Concatenate the directory to the file
+  my $template = File::Spec->catfile($dir, $prefix);
+
+  return mktemp($template);
+
+}
+
+=back
+
+=head1 UTILITY FUNCTIONS
+
+Useful functions for dealing with the filehandle and filename.
+
+=over 4
+
+=item B<unlink0>
+
+Given an open filehandle and the associated filename, make a safe
+unlink. This is achieved by first checking that the filename and
+filehandle initially point to the same file and that the number of
+links to the file is 1 (all fields returned by stat() are compared).
+Then the filename is unlinked and the filehandle checked once again to
+verify that the number of links on that file is now 0.  This is the
+closest you can come to making sure that the filename unlinked was the
+same as the file whose descriptor you hold.
+
+  unlink0($fh, $path) or die "Error unlinking file $path safely";
+
+Returns false on error. The filehandle is not closed since on some
+occasions this is not required.
+
+On some platforms, for example Windows NT, it is not possible to
+unlink an open file (the file must be closed first). On those
+platforms, the actual unlinking is deferred until the program ends and
+good status is returned. A check is still performed to make sure that
+the filehandle and filename are pointing to the same thing (but not at
+the time the end block is executed since the deferred removal may not
+have access to the filehandle).
+
+Additionally, on Windows NT not all the fields returned by stat() can
+be compared. For example, the C<dev> and C<rdev> fields seem to be
+different.  Also, it seems that the size of the file returned by stat()
+does not always agree, with C<stat(FH)> being more accurate than
+C<stat(filename)>, presumably because of caching issues even when
+using autoflush (this is usually overcome by waiting a while after
+writing to the tempfile before attempting to C<unlink0> it).
+
+Finally, on NFS file systems the link count of the file handle does
+not always go to zero immediately after unlinking. Currently, this
+command is expected to fail on NFS disks.
+
+=cut
+
+sub unlink0 {
+
+  croak 'Usage: unlink0(filehandle, filename)'
+    unless scalar(@_) == 2;
+
+  # Read args
+  my ($fh, $path) = @_;
+
+  warn "Unlinking $path using unlink0\n"
+    if $DEBUG;
+
+  # Stat the filehandle
+  my @fh = stat $fh;
+
+  if ($fh[3] > 1 && $^W) {
+    carp "unlink0: fstat found too many links; SB=@fh" if $^W;
+  }
+
+  # Stat the path
+  my @path = stat $path;
+
+  unless (@path) {
+    carp "unlink0: $path is gone already" if $^W;
+    return;
+  }
+
+  # this is no longer a file, but may be a directory, or worse
+  unless (-f _) {
+    confess "panic: $path is no longer a file: SB=@fh";
+  }
+
+  # Do comparison of each member of the array
+  # On WinNT dev and rdev seem to be different
+  # depending on whether it is a file or a handle.
+  # Cannot simply compare all members of the stat return
+  # Select the ones we can use
+  my @okstat = (0..$#fh);  # Use all by default
+  if ($^O eq 'MSWin32') {
+    @okstat = (1,2,3,4,5,7,8,9,10);
+  } elsif ($^O eq 'os2') {
+    @okstat = (0, 2..$#fh);
+  } elsif ($^O eq 'VMS') { # device and file ID are sufficient
+    @okstat = (0, 1);
+  } elsif ($^O eq 'dos') {
+     @okstat = (0,2..7,11..$#fh);
+  }
+
+  # Now compare each entry explicitly by number
+  for (@okstat) {
+    print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
+    # Use eq rather than == since rdev, blksize, and blocks (6, 11,
+    # and 12) will be '' on platforms that do not support them.  This
+    # is fine since we are only comparing integers.
+    unless ($fh[$_] eq $path[$_]) {
+      warn "Did not match $_ element of stat\n" if $DEBUG;
+      return 0;
+    }
+  }
+
+  # attempt remove the file (does not work on some platforms)
+  if (_can_unlink_opened_file()) {
+    # XXX: do *not* call this on a directory; possible race
+    #      resulting in recursive removal
+    croak "unlink0: $path has become a directory!" if -d $path;
+    unlink($path) or return 0;
+
+    # Stat the filehandle
+    @fh = stat $fh;
+
+    print "Link count = $fh[3] \n" if $DEBUG;
+
+    # Make sure that the link count is zero
+    # - Cygwin provides deferred unlinking, however,
+    #   on Win9x the link count remains 1
+    # On NFS the link count may still be 1 but we cant know that
+    # we are on NFS
+    return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
+
+  } else {
+    _deferred_unlink($fh, $path, 0);
+    return 1;
+  }
+
+}
+
+=back
+
+=head1 PACKAGE VARIABLES
+
+These functions control the global state of the package.
+
+=over 4
+
+=item B<safe_level>
+
+Controls the lengths to which the module will go to check the safety of the
+temporary file or directory before proceeding.
+Options are:
+
+=over 8
+
+=item STANDARD
+
+Do the basic security measures to ensure the directory exists and
+is writable, that the umask() is fixed before opening of the file,
+that temporary files are opened only if they do not already exist, and
+that possible race conditions are avoided.  Finally the L<unlink0|"unlink0">
+function is used to remove files safely.
+
+=item MEDIUM
+
+In addition to the STANDARD security, the output directory is checked
+to make sure that it is owned either by root or the user running the
+program. If the directory is writable by group or by other, it is then
+checked to make sure that the sticky bit is set.
+
+Will not work on platforms that do not support the C<-k> test
+for sticky bit.
+
+=item HIGH
+
+In addition to the MEDIUM security checks, also check for the
+possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
+sysconf() function. If this is a possibility, each directory in the
+path is checked in turn for safeness, recursively walking back to the
+root directory.
+
+For platforms that do not support the L<POSIX|POSIX>
+C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
+assumed that ``chown() giveaway'' is possible and the recursive test
+is performed.
+
+=back
+
+The level can be changed as follows:
+
+  File::Temp->safe_level( File::Temp::HIGH );
+
+The level constants are not exported by the module.
+
+Currently, you must be running at least perl v5.6.0 in order to
+run with MEDIUM or HIGH security. This is simply because the
+safety tests use functions from L<Fcntl|Fcntl> that are not
+available in older versions of perl. The problem is that the version
+number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
+they are different versions.
+
+On systems that do not support the HIGH or MEDIUM safety levels
+(for example Win NT or OS/2) any attempt to change the level will
+be ignored. The decision to ignore rather than raise an exception
+allows portable programs to be written with high security in mind
+for the systems that can support this without those programs failing
+on systems where the extra tests are irrelevant.
+
+If you really need to see whether the change has been accepted
+simply examine the return value of C<safe_level>.
+
+  $newlevel = File::Temp->safe_level( File::Temp::HIGH );
+  die "Could not change to high security"
+      if $newlevel != File::Temp::HIGH;
+
+=cut
+
+{
+  # protect from using the variable itself
+  my $LEVEL = STANDARD;
+  sub safe_level {
+    my $self = shift;
+    if (@_) {
+      my $level = shift;
+      if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
+	carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
+      } else {
+	# Dont allow this on perl 5.005 or earlier
+	if ($] < 5.006 && $level != STANDARD) {
+	  # Cant do MEDIUM or HIGH checks
+	  croak "Currently requires perl 5.006 or newer to do the safe checks";
+	}
+	# Check that we are allowed to change level
+	# Silently ignore if we can not.
+        $LEVEL = $level if _can_do_level($level);
+      }
+    }
+    return $LEVEL;
+  }
+}
+
+=item TopSystemUID
+
+This is the highest UID on the current system that refers to a root
+UID. This is used to make sure that the temporary directory is
+owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
+simply by root.
+
+This is required since on many unix systems C</tmp> is not owned
+by root.
+
+Default is to assume that any UID less than or equal to 10 is a root
+UID.
+
+  File::Temp->top_system_uid(10);
+  my $topid = File::Temp->top_system_uid;
+
+This value can be adjusted to reduce security checking if required.
+The value is only relevant when C<safe_level> is set to MEDIUM or higher.
+
+=back
+
+=cut
+
+{
+  my $TopSystemUID = 10;
+  sub top_system_uid {
+    my $self = shift;
+    if (@_) {
+      my $newuid = shift;
+      croak "top_system_uid: UIDs should be numeric"
+        unless $newuid =~ /^\d+$/s;
+      $TopSystemUID = $newuid;
+    }
+    return $TopSystemUID;
+  }
+}
+
+=head1 WARNING
+
+For maximum security, endeavour always to avoid ever looking at,
+touching, or even imputing the existence of the filename.  You do not
+know that that filename is connected to the same file as the handle
+you have, and attempts to check this can only trigger more race
+conditions.  It's far more secure to use the filehandle alone and
+dispense with the filename altogether.
+
+If you need to pass the handle to something that expects a filename
+then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
+programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
+programs.  You will have to clear the close-on-exec bit on that file
+descriptor before passing it to another process.
+
+    use Fcntl qw/F_SETFD F_GETFD/;
+    fcntl($tmpfh, F_SETFD, 0)
+        or die "Can't clear close-on-exec flag on temp fh: $!\n";
+
+=head2 Temporary files and NFS
+
+Some problems are associated with using temporary files that reside
+on NFS file systems and it is recommended that a local filesystem
+is used whenever possible. Some of the security tests will most probably
+fail when the temp file is not local. Additionally, be aware that
+the performance of I/O operations over NFS will not be as good as for
+a local disk.
+
+=head1 HISTORY
+
+Originally began life in May 1999 as an XS interface to the system
+mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
+translated to Perl for total control of the code's
+security checking, to ensure the presence of the function regardless of
+operating system and to help with portability.
+
+=head1 SEE ALSO
+
+L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
+
+See L<IO::File> and L<File::MkTemp> for different implementations of
+temporary file handling.
+
+=head1 AUTHOR
+
+Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt>
+
+Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and
+Astronomy Research Council. All Rights Reserved.  This program is free
+software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+Original Perl implementation loosely based on the OpenBSD C code for
+mkstemp(). Thanks to Tom Christiansen for suggesting that this module
+should be written and providing ideas for code improvements and
+security enhancements.
+
+=cut
+
+
+1;
diff --git a/lib/Milkbone/AllHooks.pm b/lib/Milkbone/AllHooks.pm
new file mode 100644
index 0000000..90a9442
--- /dev/null
+++ b/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;
diff --git a/lib/Milkbone/HookEntry.pm b/lib/Milkbone/HookEntry.pm
new file mode 100644
index 0000000..cca3298
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/lib/Tk/Text.pm b/lib/Tk/Text.pm
new file mode 100644
index 0000000..cdba615
--- /dev/null
+++ b/lib/Tk/Text.pm
@@ -0,0 +1,1599 @@
+# text.tcl --
+#
+# This file defines the default bindings for Tk text widgets.
+# 
+# @(#) text.tcl 1.18 94/12/17 16:05:26
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# perl/Tk version:
+# Copyright (c) 1995-1999 Nick Ing-Simmons
+# Copyright (c) 1999 Greg London
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package Tk::Text;
+use Carp;
+use strict;
+
+use Text::Tabs;
+
+use vars qw($VERSION);
+$VERSION = '3.044'; # $Id$
+
+use Tk qw(Ev $XS_VERSION);
+use base  qw(Tk::Clipboard Tk::Widget);
+
+Construct Tk::Widget 'Text';
+
+bootstrap Tk::Text;
+
+sub Tk_cmd { \&Tk::text }
+
+sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
+
+Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump',
+            'get','image','index','insert','mark','scan','search',
+            'see','tag','window','xview','yview');
+
+use Tk::Submethods ( 'mark'   => [qw(gravity names next previous set unset)],
+		     'scan'   => [qw(mark dragto)],
+		     'tag'    => [qw(add bind cget configure delete lower
+				     names nextrange prevrange raise ranges remove)],
+		     'window' => [qw(cget configure create names)],
+		     'image'  => [qw(cget configure create names)],
+		     'xview'  => [qw(moveto scroll)],
+		     'yview'  => [qw(moveto scroll)],
+		     );
+
+sub Tag;
+sub Tags;
+
+sub bindRdOnly
+{
+
+ my ($class,$mw) = @_;
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<Meta-B1-Motion>','NoOp');
+ $mw->bind($class,'<Meta-1>','NoOp');
+ $mw->bind($class,'<Alt-KeyPress>','NoOp');
+ $mw->bind($class,'<Escape>','unselectAll');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
+ $mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
+ $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);
+
+ $mw->bind($class,'<Double-1>','selectWord' ) ;
+ $mw->bind($class,'<Triple-1>','selectLine' ) ;
+ $mw->bind($class,'<Shift-1>','adjustSelect' ) ;
+ $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
+ $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);
+
+ $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);
+
+ $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);
+
+ $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);
+
+ $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);
+
+ $mw->bind($class,'<Home>',['SetCursor','insert linestart']);
+ $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
+ $mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
+ $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);
+
+ $mw->bind($class,'<End>',['SetCursor','insert lineend']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
+ $mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
+ $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);
+
+ $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);
+
+ $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);
+
+ $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
+ $mw->bind($class,'<Control-Tab>','focusNext');
+ $mw->bind($class,'<Control-Shift-Tab>','focusPrev');
+
+ $mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Select>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Control-slash>','selectAll');
+ $mw->bind($class,'<Control-backslash>','unselectAll');
+
+ if (!$Tk::strictMotif)
+  {
+   $mw->bind($class,'<Control-a>',    ['SetCursor','insert linestart']);
+   $mw->bind($class,'<Control-b>',    ['SetCursor','insert-1c']);
+   $mw->bind($class,'<Control-e>',    ['SetCursor','insert lineend']);
+   $mw->bind($class,'<Control-f>',    ['SetCursor','insert+1c']);
+   $mw->bind($class,'<Meta-b>',       ['SetCursor','insert-1c wordstart']);
+   $mw->bind($class,'<Meta-f>',       ['SetCursor','insert wordend']);
+   $mw->bind($class,'<Meta-less>',    ['SetCursor','1.0']);
+   $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']);
+
+   $mw->bind($class,'<Control-n>',    ['SetCursor',Ev('UpDownLine',1)]);
+   $mw->bind($class,'<Control-p>',    ['SetCursor',Ev('UpDownLine',-1)]);
+
+   $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]);
+   $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]);
+  }
+ $mw->bind($class,'<Destroy>','Destroy');
+ $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')]  );
+
+ return $class;
+}
+
+sub selectAll
+{
+ my ($w) = @_;
+ $w->tagAdd('sel','1.0','end');
+}
+
+sub unselectAll
+{
+ my ($w) = @_;
+ $w->tagRemove('sel','1.0','end');
+}
+
+sub adjustSelect
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->ResetAnchor($Ev->xy);
+ $w->SelectTo($Ev->xy,'char')
+}
+
+sub selectLine
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'line');
+ Tk::catch { $w->markSet('insert','sel.first') };
+}
+
+sub selectWord
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'word');
+ Tk::catch { $w->markSet('insert','sel.first') }
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $class->bindRdOnly($mw);
+
+ $mw->bind($class,'<Tab>', 'insertTab');
+ $mw->bind($class,'<Control-i>', ['Insert',"\t"]);
+ $mw->bind($class,'<Return>', ['Insert',"\n"]);
+ $mw->bind($class,'<Delete>','Delete');
+ $mw->bind($class,'<BackSpace>','Backspace');
+ $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ;
+ $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]);
+
+ $mw->bind($class,'<F1>', 'clipboardColumnCopy');
+ # $mw->bind($class,'<F2>', 'clipboardColumnCut');
+ $mw->bind($class,'<F3>', 'clipboardColumnPaste');
+
+ # Additional emacs-like bindings:
+
+ if (!$Tk::strictMotif)
+  {
+   $mw->bind($class,'<Control-d>',['delete','insert']);
+   $mw->bind($class,'<Control-k>','deleteToEndofLine') ;
+   $mw->bind($class,'<Control-o>','openLine');
+   $mw->bind($class,'<Control-t>','Transpose');
+   $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']);
+   $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']);
+
+   # A few additional bindings of my own.
+   $mw->bind($class,'<Control-h>','deleteBefore');
+   $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2');
+  }
+ $Tk::prevPos = undef;
+ return $class;
+}
+
+sub insertTab
+{
+ my ($w) = @_;
+ # $w->Insert("\t");
+ # $w->focus;
+ # $w->break
+}
+
+sub deleteToEndofLine
+{
+ my ($w) = @_;
+ if ($w->compare('insert','==','insert lineend'))
+  {
+   $w->delete('insert')
+  }
+ else
+  {
+   $w->delete('insert','insert lineend')
+  }
+}
+
+sub openLine
+{
+ my ($w) = @_;
+ $w->insert('insert',"\n");
+ $w->markSet('insert','insert-1c')
+}
+
+sub Button2
+{
+ my ($w,$x,$y) = @_;
+ $w->scan('mark',$x,$y);
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $Tk::mouseMoved = 0;
+}
+
+sub Motion2
+{
+ my ($w,$x,$y) = @_;
+ $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
+ $w->scan('dragto',$x,$y) if ($Tk::mouseMoved);
+}
+
+sub ButtonRelease2
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+  {
+   Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) }
+  }
+}
+
+sub InsertSelection
+{
+ my ($w) = @_;
+ Tk::catch { $w->Insert($w->SelectionGet) }
+}
+
+sub Backspace
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+  {
+   $w->delete('sel.first','sel.last');
+   return;
+  }
+ $w->deleteBefore;
+}
+
+sub deleteBefore
+{
+ my ($w) = @_;
+ if ($w->compare('insert','!=','1.0'))
+  {
+   $w->delete('insert-1c');
+   $w->see('insert')
+  }
+}
+
+sub Delete
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+  {
+   $w->delete('sel.first','sel.last')
+  }
+ else
+  {
+   $w->delete('insert');
+   $w->see('insert')
+  }
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in text
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The x-coordinate of the button press.
+sub Button1
+{
+ my ($w,$x,$y) = @_;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $w->SetCursor('@'.$x.','.$y);
+ $w->markSet('anchor','insert');
+ $w->focus() if ($w->cget('-state') eq 'normal');
+}
+
+sub B1_Motion
+{
+ my ($w) = @_;
+ return unless defined $Tk::mouseMoved;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->SelectTo($Ev->xy)
+}
+
+sub B1_Leave
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->AutoScan;
+}
+
+# SelectTo --
+# This procedure is invoked to extend the selection, typically when
+# dragging it with the mouse. Depending on the selection mode (character,
+# word, line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# index - Index of character at which the mouse button was pressed.
+sub SelectTo
+{
+ my ($w, $index, $mode)= @_;
+ $Tk::selectMode = $mode if defined ($mode);
+ my $cur = $w->index($index);
+ my $anchor = Tk::catch { $w->index('anchor') };
+ if (!defined $anchor)
+  {
+   $w->markSet('anchor',$anchor = $cur);
+   $Tk::mouseMoved = 0;
+  }
+ elsif ($w->compare($cur,'!=',$anchor))
+  {
+   $Tk::mouseMoved = 1;
+  }
+ $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
+ $mode = $Tk::selectMode;
+ my ($first,$last);
+ if ($mode eq 'char')
+  {
+   if ($w->compare($cur,'<','anchor'))
+    {
+     $first = $cur;
+     $last = 'anchor';
+    }
+   else
+    {
+     $first = 'anchor';
+     $last = $cur
+    }
+  }
+ elsif ($mode eq 'word')
+  {
+   if ($w->compare($cur,'<','anchor'))
+    {
+     $first = $w->index("$cur wordstart");
+     $last = $w->index('anchor - 1c wordend')
+    }
+   else
+    {
+     $first = $w->index('anchor wordstart');
+     $last = $w->index("$cur wordend")
+    }
+  }
+ elsif ($mode eq 'line')
+  {
+   if ($w->compare($cur,'<','anchor'))
+    {
+     $first = $w->index("$cur linestart");
+     $last = $w->index('anchor - 1c lineend + 1c')
+    }
+   else
+    {
+     $first = $w->index('anchor linestart');
+     $last = $w->index("$cur lineend + 1c")
+    }
+  }
+ if ($Tk::mouseMoved || $Tk::selectMode ne 'char')
+  {
+   $w->tagRemove('sel','1.0',$first);
+   $w->tagAdd('sel',$first,$last);
+   $w->tagRemove('sel',$last,'end');
+   $w->idletasks;
+  }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves a text window
+# with button 1 down. It scrolls the window up, down, left, or right,
+# depending on where the mouse is (this information was saved in
+# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after'
+# command so that the window continues to scroll until the mouse
+# moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The text window.
+sub AutoScan
+{
+ my ($w) = @_;
+ if ($Tk::y >= $w->height)
+  {
+   $w->yview('scroll',2,'units')
+  }
+ elsif ($Tk::y < 0)
+  {
+   $w->yview('scroll',-2,'units')
+  }
+ elsif ($Tk::x >= $w->width)
+  {
+   $w->xview('scroll',2,'units')
+  }
+ elsif ($Tk::x < 0)
+  {
+   $w->xview('scroll',-2,'units')
+  }
+ else
+  {
+   return;
+  }
+ $w->SelectTo('@' . $Tk::x . ','. $Tk::y);
+ $w->RepeatId($w->after(50,['AutoScan',$w]));
+}
+# SetCursor
+# Move the insertion cursor to a given position in a text. Also
+# clears the selection, if there is one in the text, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The text window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my ($w,$pos) = @_;
+ $pos = 'end - 1 chars' if $w->compare($pos,'==','end');
+ $w->markSet('insert',$pos);
+ $w->unselectAll;
+ $w->see('insert')
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The text window.
+# new - A new position for the insertion cursor (the cursor has not
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my ($w,$new) = @_;
+ my ($first,$last);
+ if (!defined $w->tag('ranges','sel'))
+  {
+   # No selection yet
+   $w->markSet('anchor','insert');
+   if ($w->compare($new,'<','insert'))
+    {
+     $w->tagAdd('sel',$new,'insert')
+    }
+   else
+    {
+     $w->tagAdd('sel','insert',$new)
+    }
+  }
+ else
+  {
+   # Selection exists
+   if ($w->compare($new,'<','anchor'))
+    {
+     $first = $new;
+     $last = 'anchor'
+    }
+   else
+    {
+     $first = 'anchor';
+     $last = $new
+    }
+   $w->tagRemove('sel','1.0',$first);
+   $w->tagAdd('sel',$first,$last);
+   $w->tagRemove('sel',$last,'end')
+  }
+ $w->markSet('insert',$new);
+ $w->see('insert');
+ $w->idletasks;
+}
+# ResetAnchor --
+# Set the selection anchor to whichever end is farthest from the
+# index argument. One special trick: if the selection has two or
+# fewer characters, just leave the anchor where it is. In this
+# case it does not matter which point gets chosen for the anchor,
+# and for the things like Shift-Left and Shift-Right this produces
+# better behavior when the cursor moves back and forth across the
+# anchor.
+#
+# Arguments:
+# w - The text widget.
+# index - Position at which mouse button was pressed, which determines
+# which end of selection should be used as anchor point.
+sub ResetAnchor
+{
+ my ($w,$index) = @_;
+ if (!defined $w->tag('ranges','sel'))
+  {
+   $w->markSet('anchor',$index);
+   return;
+  }
+ my $a = $w->index($index);
+ my $b = $w->index('sel.first');
+ my $c = $w->index('sel.last');
+ if ($w->compare($a,'<',$b))
+  {
+   $w->markSet('anchor','sel.last');
+   return;
+  }
+ if ($w->compare($a,'>',$c))
+  {
+   $w->markSet('anchor','sel.first');
+   return;
+  }
+ my ($lineA,$chA) = split(/\./,$a);
+ my ($lineB,$chB) = split(/\./,$b);
+ my ($lineC,$chC) = split(/\./,$c);
+ if ($lineB < $lineC+2)
+  {
+   my $total = length($w->get($b,$c));
+   if ($total <= 2)
+    {
+     return;
+    }
+   if (length($w->get($b,$a)) < $total/2)
+    {
+     $w->markSet('anchor','sel.last')
+    }
+   else
+    {
+     $w->markSet('anchor','sel.first')
+    }
+   return;
+  }
+ if ($lineA-$lineB < $lineC-$lineA)
+  {
+   $w->markSet('anchor','sel.last')
+  }
+ else
+  {
+   $w->markSet('anchor','sel.first')
+  }
+}
+
+########################################################################
+sub markExists
+{
+ my ($w, $markname)=@_;
+ my $mark_exists=0;
+ my @markNames_list = $w->markNames;
+ foreach my $mark (@markNames_list)
+  { if ($markname eq $mark) {$mark_exists=1;last;} }
+ return $mark_exists;
+}
+
+########################################################################
+sub OverstrikeMode
+{
+ my ($w,$mode) = @_;
+
+ $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'});
+
+ $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1);
+
+ return $w->{'OVERSTRIKE_MODE'};
+}
+
+########################################################################
+# pressed the <Insert> key, just above 'Del' key.
+# this toggles between insert mode and overstrike mode.
+sub ToggleInsertMode
+{
+ my ($w)=@_;
+ $w->OverstrikeMode(!$w->OverstrikeMode);
+}
+
+########################################################################
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ if ($w->OverstrikeMode)
+  {
+   my $current=$w->get('insert');
+   $w->delete('insert') unless($current eq "\n");
+  }
+ $w->Insert($char);
+}
+
+########################################################################
+sub GotoLineNumber
+{
+ my ($w,$line_number) = @_;
+ $line_number=~ s/^\s+|\s+$//g;
+ return if $line_number =~ m/\D/;
+ my ($last_line,$junk)  = split(/\./, $w->index('end'));
+ if ($line_number > $last_line) {$line_number = $last_line; }
+ $w->{'LAST_GOTO_LINE'} = $line_number;
+ $w->markSet('insert', $line_number.'.0');
+ $w->see('insert');
+}
+
+########################################################################
+sub GotoLineNumberPopUp
+{
+ my ($w)=@_;
+ my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'};
+
+ unless (defined($w->{'LAST_GOTO_LINE'}))
+  {
+   my ($line,$col) =  split(/\./, $w->index('insert'));
+   $w->{'LAST_GOTO_LINE'} = $line;
+  }
+
+ ## if anything is selected when bring up the pop-up, put it in entry window.	
+ my $selected;
+ eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ unless ($@)
+  {
+   if (defined($selected) and length($selected))
+    {
+     unless ($selected =~ /\D/)
+      {
+       $w->{'LAST_GOTO_LINE'} = $selected;
+      }
+    }
+  }
+ unless (defined($popup))
+  {
+   require Tk::DialogBox;
+   $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w,
+                          -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'});
+   $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup;
+   $popup->resizable('no','no');
+   my $frame = $popup->Frame->pack(-fill => 'x');
+   $frame->Label(text=>'Enter line number: ')->pack(-side => 'left');
+   my $entry = $frame->Entry(-background=>'white',width=>25,
+                             -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x');
+   $popup->Advertise(entry => $entry);
+  }
+ $popup->Popup;
+ $popup->Subwidget('entry')->focus;
+ $popup->Wait;
+}
+
+########################################################################
+
+sub getSelected
+{
+ shift->GetTextTaggedWith('sel');
+}
+
+sub deleteSelected
+{
+ shift->DeleteTextTaggedWith('sel');
+}
+
+sub GetTextTaggedWith
+{
+ my ($w,$tag) = @_;
+
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+ my $return_text='';
+
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return $return_text;}	
+
+ # for every range-pair, get selected text
+ while(@ranges)
+  {
+  my $first = shift(@ranges);
+  my $last = shift(@ranges);
+  my $text = $w->get($first , $last);
+  if(defined($text))
+   {$return_text = $return_text . $text;}
+  # if there is more tagged text, separate with an end of line  character
+  if(@ranges)
+   {$return_text = $return_text . "\n";}
+  }
+ return $return_text;
+}
+
+########################################################################
+sub DeleteTextTaggedWith
+{
+ my ($w,$tag) = @_;
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+	
+ # if nothing tagged with that tag, then ignore
+ if ($range_total == 0) {return;}
+	
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+  { $w->markSet('mark_tag_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ for (my $i=0; $i<$range_total; $i=$i+2)
+  {
+  my $first = $w->index('mark_tag_'.$i);
+  my $last = $w->index('mark_tag_'.($i+1));
+
+  my $text = $w->delete($first , $last);
+  }
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+  { $w->markUnset('mark_tag_'.$i); }
+}
+	
+
+########################################################################
+sub FindAll
+{
+ my ($w,$mode, $case, $pattern ) = @_;
+ ### 'sel' tags accumulate, need to remove any previous existing
+ $w->unselectAll;
+	
+ my $match_length=0;
+ my $start_index;
+ my $end_index = '1.0';	
+	
+ while(defined($end_index))
+  {
+  if ($case eq '-nocase')
+   {
+   $start_index = $w->search(
+    $mode,
+    $case,
+    -count => \$match_length,
+    "--",
+    $pattern ,
+    $end_index,
+    'end');
+   }
+  else
+   {
+   $start_index = $w->search(
+    $mode,
+    -count => \$match_length,
+    "--",
+    $pattern ,
+    $end_index,
+    'end');
+   }
+
+  unless(defined($start_index) && $start_index) {last;}
+
+  my ($line,$col) = split(/\./, $start_index);
+  $col = $col + $match_length;
+  $end_index = $line.'.'.$col;
+  $w->tagAdd('sel', $start_index, $end_index);
+  }
+}
+
+########################################################################
+# get current selected text and search for the next occurrence
+sub FindSelectionNext
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-forward', '-exact', '-case', $selected);
+}
+
+########################################################################
+# get current selected text and search for the previous occurrence
+sub FindSelectionPrevious
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-backward', '-exact', '-case', $selected);
+}
+
+
+
+########################################################################
+sub FindNext
+{
+ my ($w,$direction, $mode, $case, $pattern ) = @_;
+	
+ ## if searching forward, start search at end of selected block
+ ## if backward, start search from start of selected block.
+ ## dont want search to find currently selected text.
+ ## tag 'sel' may not be defined, use eval loop to trap error
+ eval {	
+  if ($direction eq '-forward')
+   {
+   $w->markSet('insert', 'sel.last');
+   $w->markSet('current', 'sel.last');
+   }
+  else
+   {
+   $w->markSet('insert', 'sel.first');
+   $w->markSet('current', 'sel.first');
+   }
+ };
+
+ my $saved_index=$w->index('insert');
+	
+ # remove any previous existing tags
+ $w->unselectAll;
+	
+ my $match_length=0;
+ my $start_index;
+	
+ if ($case eq '-nocase')
+  {
+  $start_index = $w->search(
+   $direction,
+   $mode,
+   $case,
+   -count => \$match_length,
+   "--",
+   $pattern ,
+   'insert');
+  }
+ else
+  {
+  $start_index = $w->search(
+   $direction,
+   $mode,
+   -count => \$match_length,
+   "--",
+   $pattern ,
+   'insert');
+  }
+	
+ unless(defined($start_index)) { return 0; }
+ if(length($start_index) == 0) { return 0; }
+	
+ my ($line,$col) = split(/\./, $start_index);
+ $col = $col + $match_length;
+ my $end_index = $line.'.'.$col;
+ $w->tagAdd('sel', $start_index, $end_index);
+	
+ $w->see($start_index);
+	
+ if ($direction eq '-forward')
+  {
+  $w->markSet('insert', $end_index);
+  $w->markSet('current', $end_index);
+  }
+ else
+  {
+  $w->markSet('insert', $start_index);
+  $w->markSet('current', $start_index);
+  }
+	
+ my $compared_index = $w->index('insert');
+
+ my $ret_val;
+ if ($compared_index eq $saved_index)
+  {$ret_val=0;}
+ else
+  {$ret_val=1;}
+ return $ret_val;
+}
+
+########################################################################
+sub FindAndReplaceAll
+{
+ my ($w,$mode, $case, $find, $replace ) = @_;
+ $w->markSet('insert', '1.0');
+ $w->unselectAll;
+ while($w->FindNext('-forward', $mode, $case, $find))
+  {
+  $w->ReplaceSelectionsWith($replace);
+  }
+}
+
+########################################################################
+sub ReplaceSelectionsWith
+{
+ my ($w,$new_text ) = @_;
+
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+	
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return};
+
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+  {$w->markSet('mark_sel_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ my ($first, $last);
+ for (my $i=0; $i<$range_total; $i=$i+2)
+  {
+  $first = $w->index('mark_sel_'.$i);
+  $last = $w->index('mark_sel_'.($i+1));
+
+  ##########################################################################
+  # eventually, want to be able to get selected text,
+  # support regular expression matching, determine replace_text
+  # $replace_text = $selected_text=~m/$new_text/  (or whatever would work)
+  # will have to pass in mode and case flags.
+  # this would allow a regular expression search and replace to be performed
+  # example, look for "line (\d+):" and replace with "$1 >" or similar
+  ##########################################################################
+
+  $w->insert($last, $new_text);
+  $w->delete($first, $last);
+	
+  }
+ ############################################################
+ # set the insert cursor to the end of the last insertion mark
+ $w->markSet('insert',$w->index('mark_sel_'.($range_total-1)));
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+  { $w->markUnset('mark_sel_'.$i); }
+}
+########################################################################
+sub FindAndReplacePopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(0);
+}
+
+########################################################################
+sub FindPopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(1);
+}
+
+########################################################################
+
+sub findandreplacepopup
+{
+ my ($w,$find_only)=@_;
+
+ my $pop = $w->Toplevel;
+ if ($find_only)
+  { $pop->title("Find"); }
+ else
+  { $pop->title("Find and/or Replace"); }
+ my $frame =  $pop->Frame->pack(-anchor=>'nw');
+
+ $frame->Label(text=>"Direction:")
+  ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw');
+ my $direction = '-forward';
+ $frame->Radiobutton(
+  variable => \$direction,
+  text => '-forward',value => '-forward' )
+  ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+  variable => \$direction,
+  text => '-backward',value => '-backward' )
+  ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(text=>"Mode:")
+  ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw');
+ my $mode = '-exact';
+ $frame->Radiobutton(
+  variable => \$mode, text => '-exact',value => '-exact' )
+  ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+  variable => \$mode, text => '-regexp',value => '-regexp' )
+  ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(text=>"Case:")
+  ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw');
+ my $case = '-case';
+ $frame->Radiobutton(
+  variable => \$case, text => '-case',value => '-case' )
+  ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+  variable => \$case, text => '-nocase',value => '-nocase' )
+  ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw');
+
+ ######################################################
+ my $find_entry = $pop->Entry(width=>25);
+
+ my $button_find = $pop->Button(text=>'Find',
+  command => sub {$w->FindNext ($direction,$mode,$case,$find_entry->get()),} )
+  -> pack(-anchor=>'nw');
+
+ $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing
+
+ ######  if any $w text is selected, put it in the find entry
+ ######  could be more than one text block selected, get first selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+  {
+  my $first = shift(@ranges);
+  my $last = shift(@ranges);
+
+  # limit to one line
+  my ($first_line, $first_col) = split(/\./,$first);
+  my ($last_line, $last_col) = split(/\./,$last);
+  unless($first_line == $last_line)
+   {$last = $first. ' lineend';}
+
+  $find_entry->insert('insert', $w->get($first , $last));
+  }
+ else
+  {
+  my $selected;
+  eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); };
+  if($@) {}
+  elsif (defined($selected))
+   {$find_entry->insert('insert', $selected);}
+  }
+
+ my ($replace_entry,$button_replace,$button_replace_all);
+ unless ($find_only)
+  {
+  ######################################################
+  $replace_entry = $pop->Entry(width=>25);
+  ######################################################
+  $button_replace = $pop->Button(text=>'Replace',
+   command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
+   -> pack(-anchor=>'nw');
+
+  $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
+  }
+
+ ######################################################
+ $pop->Label(text=>" ")->pack();
+ ######################################################
+ unless ($find_only)
+  {
+  $button_replace_all = $pop->Button(text=>'Replace All',
+   command => sub {$w->FindAndReplaceAll
+    ($mode,$case,$find_entry->get(),$replace_entry->get());} )
+   ->pack(-side => 'left');
+  }
+
+ my $button_find_all = $pop->Button(text=>'Find All',
+  command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
+  ->pack(-side => 'left');
+
+  my $button_cancel = $pop->Button(text=>'Cancel',
+  command => sub {$pop->destroy()} )
+  ->pack(-side => 'left');
+
+ $pop->resizable('yes','no');
+ return $pop;
+}
+
+# paste clipboard into current location
+sub clipboardPaste
+{
+ my ($w) = @_;
+ local $@;
+ Tk::catch { $w->Insert($w->clipboardGet) };
+}
+
+########################################################################
+# Insert --
+# Insert a string into a text at the point of the insertion cursor.
+# If there is a selection in the text, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The text window in which to insert the string
+# string - The string to insert (usually just a single character)
+sub Insert
+{
+ my ($w,$string) = @_;
+ return unless (defined $string && $string ne '');
+ #figure out if cursor is inside a selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+  {
+   while (@ranges)
+    {
+     my ($first,$last) = splice(@ranges,0,2);
+     if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert'))
+      {
+       $w->ReplaceSelectionsWith($string);
+       return;
+      }
+    }
+  }
+ # paste it at the current cursor location
+ $w->insert('insert',$string);
+ $w->see('insert');
+}
+
+# UpDownLine --
+# Returns the index of the character one line above or below the
+# insertion cursor. There are two tricky things here. First,
+# we want to maintain the original column across repeated operations,
+# even though some lines that will get passed through do not have
+# enough characters to cover the original column. Second, do not
+# try to scroll past the beginning or end of the text.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# n - The number of lines to move: -1 for up one line,
+# +1 for down one line.
+sub UpDownLine_old
+{
+ my ($w,$n) = @_;
+ my $i = $w->index('insert');
+ my ($line,$char) = split(/\./,$i);
+ if (!defined($Tk::prevPos) || $Tk::prevPos ne $i)
+  {
+   $Tk::char = $char
+  }
+ my $new = $w->index($line+$n . '.' . $Tk::char);
+ if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
+  {
+   $new = $i
+  }
+ $Tk::prevPos = $new;
+ return $new;
+}
+
+sub UpDownLine
+{
+ my ($w,$n) = @_;
+ my $i = $w->index('insert');
+ my ($line,$char) = split(/\./,$i);
+ my $string = $w->get($line.'.0', $i);
+
+ $string = expand($string);
+ $char=length($string);
+ $line += $n;
+
+ $string = $w->get($line.'.0', $line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $char);
+
+ $string = unexpand($string);
+ $char = length($string);
+
+ my $new = $w->index($line . '.' . $char);
+ if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
+  {
+   $new = $i
+  }
+ $Tk::prevPos = $new;
+ $Tk::char = $char;
+ return $new;
+}
+
+
+# PrevPara --
+# Returns the index of the beginning of the paragraph just before a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# pos - Position at which to start search.
+sub PrevPara
+{
+ my ($w,$pos) = @_;
+ $pos = $w->index("$pos linestart");
+ while (1)
+  {
+   if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' )
+    {
+     my $string = $w->get($pos,"$pos lineend");
+     if ($string =~ /^(\s)+/)
+      {
+       my $off = length($1);
+       $pos = $w->index("$pos + $off chars")
+      }
+     if ($w->compare($pos,'!=','insert') || $pos eq '1.0')
+      {
+       return $pos;
+      }
+    }
+   $pos = $w->index("$pos - 1 line")
+  }
+}
+# NextPara --
+# Returns the index of the beginning of the paragraph just after a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# start - Position at which to start search.
+sub NextPara
+{
+ my ($w,$start) = @_;
+ my $pos = $w->index("$start linestart + 1 line");
+ while ($w->get($pos) ne "\n")
+  {
+   if ($w->compare($pos,'==','end'))
+    {
+     return $w->index('end - 1c');
+    }
+   $pos = $w->index("$pos + 1 line")
+  }
+ while ($w->get($pos) eq "\n" )
+  {
+   $pos = $w->index("$pos + 1 line");
+   if ($w->compare($pos,'==','end'))
+    {
+     return $w->index('end - 1c');
+    }
+  }
+ my $string = $w->get($pos,"$pos lineend");
+ if ($string =~ /^(\s+)/)
+  {
+   my $off = length($1);
+   return $w->index("$pos + $off chars");
+  }
+ return $pos;
+}
+# ScrollPages --
+# This is a utility procedure used in bindings for moving up and down
+# pages and possibly extending the selection along the way. It scrolls
+# the view in the widget by the number of pages, and it returns the
+# index of the character that is at the same position in the new view
+# as the insertion cursor used to be in the old view.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# count - Number of pages forward to scroll; may be negative
+# to scroll backwards.
+sub ScrollPages
+{
+ my ($w,$count) = @_;
+ my @bbox = $w->bbox('insert');
+ $w->yview('scroll',$count,'pages');
+ if (!@bbox)
+  {
+   return $w->index('@' . int($w->height/2) . ',' . 0);
+  }
+ my $x = int($bbox[0]+$bbox[2]/2);
+ my $y = int($bbox[1]+$bbox[3]/2);
+ return $w->index('@' . $x . ',' . $y);
+}
+
+sub Contents
+{
+ my $w = shift;
+ if (@_)
+  {
+   $w->delete('1.0','end');
+   $w->insert('end',shift) while (@_);
+  }
+ else
+  {
+   return $w->get('1.0','end');
+  }
+}
+
+sub Destroy
+{
+ my ($w) = @_;
+ delete $w->{_Tags_};
+}
+
+sub Transpose
+{
+ my ($w) = @_;
+ my $pos = 'insert';
+ $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
+ return if ($w->compare("$pos - 1 char",'==','1.0'));
+ my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
+ $w->delete("$pos - 2 char",$pos);
+ $w->insert('insert',$new);
+ $w->see('insert');
+}
+
+sub Tag
+{
+ my $w = shift;
+ my $name = shift;
+ Carp::confess('No args') unless (ref $w and defined $name);
+ $w->{_Tags_} = {} unless (exists $w->{_Tags_});
+ unless (exists $w->{_Tags_}{$name})
+  {
+   require Tk::Text::Tag;
+   $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
+  }
+ $w->{_Tags_}{$name}->configure(@_) if (@_);
+ return $w->{_Tags_}{$name};
+}
+
+sub Tags
+{
+ my ($w,$name) = @_;
+ my @result = ();
+ foreach $name ($w->tagNames(@_))
+  {
+   push(@result,$w->Tag($name));
+  }
+ return @result;
+}
+
+sub TIEHANDLE
+{
+ my ($class,$obj) = @_;
+ return $obj;
+}
+
+sub PRINT
+{
+ my $w = shift;
+ # Find out whether 'end' is displayed at the moment
+ # Retrieve the position of the bottom of the window as
+ # a fraction of the entire contents of the Text widget
+ my $yview = ($w->yview)[1];
+
+ # If $yview is 1.0 this means that 'end' is visible in the window
+ my $update = 0;
+ $update = 1 if $yview == 1.0;
+
+ # Loop over all input strings
+ while (@_)
+  {
+   $w->insert('end',shift);
+  }
+  # Move the window to see the end of the text if required
+  $w->see('end') if $update;
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+sub WhatLineNumberPopUp
+{
+ my ($w)=@_;
+ my ($line,$col) = split(/\./,$w->index('insert'));
+ $w->messageBox(-type => 'Ok', -title => "What Line Number",
+                -message => "The cursor is on line $line (column is $col)");
+}
+
+sub MenuLabels
+{
+ return qw[~File ~Edit ~Search ~View];
+}
+
+sub SearchMenuItems
+{
+ my ($w) = @_;
+ return [
+    ['command'=>'~Find',          -command => [$w => 'FindPopUp']],
+    ['command'=>'Find ~Next',     -command => [$w => 'FindSelectionNext']],
+    ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']],
+    ['command'=>'~Replace',       -command => [$w => 'FindAndReplacePopUp']]
+   ];
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+ my @items = ();
+ foreach my $op ($w->clipEvents)
+  {
+   push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]);
+  }
+ push(@items,
+    '-',
+    ['command'=>'Select All', -command   => [$w => 'selectAll']],
+    ['command'=>'Unselect All', -command => [$w => 'unselectAll']],
+  );
+ return \@items;
+}
+
+sub ViewMenuItems
+{
+ my ($w) = @_;
+ my $v;
+ tie $v,'Tk::Configure',$w,'-wrap';
+ return  [
+    ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
+    ['command'=>'~Which Line?',  -command =>  [$w => 'WhatLineNumberPopUp']],
+    ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
+      [radiobutton => 'Word', -variable => \$v, -value => 'word'],
+      [radiobutton => 'Character', -variable => \$v, -value => 'char'],
+      [radiobutton => 'None', -variable => \$v, -value => 'none'],
+    ]],
+  ];
+}
+
+########################################################################
+sub clipboardColumnCopy
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(0);
+}
+
+sub clipboardColumnCut
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(1);
+}
+
+########################################################################
+sub Column_Copy_or_Cut
+{
+ my ($w, $cut) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ # this only makes sense if there is one selected block
+ unless ($range_total==2)
+  {
+  $w->bell;
+  return;
+  }
+
+ my $selection_start_index = shift(@ranges);
+ my $selection_end_index = shift(@ranges);
+
+ my ($start_line, $start_column) = split(/\./, $selection_start_index);
+ my ($end_line,   $end_column)   = split(/\./, $selection_end_index);
+
+ # correct indices for tabs
+ my $string;
+ $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
+ $string = substr($string, 0, $start_column);
+ $string = expand($string);
+ my $tab_start_column = length($string);
+
+ $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
+ $string = substr($string, 0, $end_column);
+ $string = expand($string);
+ my $tab_end_column = length($string);
+
+ my $length = $tab_end_column - $tab_start_column;
+
+ $selection_start_index = $start_line . '.' . $tab_start_column;
+ $selection_end_index   = $end_line   . '.' . $tab_end_column;
+
+ # clear the clipboard
+ $w->clipboardClear;
+ my ($clipstring, $startstring, $endstring);
+ my $padded_string = ' 'x$tab_end_column;
+ for(my $line = $start_line; $line <= $end_line; $line++)
+  {
+  $string = $w->get($line.'.0', $line.'.0 lineend');
+  $string = expand($string) . $padded_string;
+  $clipstring = substr($string, $tab_start_column, $length);
+  #$clipstring = unexpand($clipstring);
+  $w->clipboardAppend($clipstring."\n");
+
+  if ($cut)
+   {
+   $startstring = substr($string, 0, $tab_start_column);
+   $startstring = unexpand($startstring);
+   $start_column = length($startstring);
+
+   $endstring = substr($string, 0, $tab_end_column );
+   $endstring = unexpand($endstring);
+   $end_column = length($endstring);
+
+   $w->delete($line.'.'.$start_column,  $line.'.'.$end_column);
+   }
+  }
+}
+
+########################################################################
+
+sub clipboardColumnPaste
+{
+ my ($w) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ if ($range_total)
+  {
+  warn " there cannot be any selections during clipboardColumnPaste. \n";
+  $w->bell;
+  return;
+  }
+
+ my $clipboard_text;
+ eval
+  {
+  $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD");
+  };
+
+ return unless (defined($clipboard_text));
+ return unless (length($clipboard_text));
+ my $string;
+
+ my $current_index = $w->index('insert');
+ my ($current_line, $current_column) = split(/\./,$current_index);
+ $string = $w->get($current_line.'.0', $current_line.'.'.$current_column);
+ $string = expand($string);
+ $current_column = length($string);
+
+ my @clipboard_lines = split(/\n/,$clipboard_text);
+ my $length;
+ my $end_index;
+ my ($delete_start_column, $delete_end_column, $insert_column_index);
+ foreach my $line (@clipboard_lines)
+  {
+  if ($w->OverstrikeMode)
+   {
+   #figure out start and end indexes to delete, compensating for tabs.
+   $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+   $string = expand($string);
+   $string = substr($string, 0, $current_column);
+   $string = unexpand($string);
+   $delete_start_column = length($string);
+
+   $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+   $string = expand($string);
+   $string = substr($string, 0, $current_column + length($line));
+   chomp($string);  # dont delete a "\n" on end of line.
+   $string = unexpand($string);
+   $delete_end_column = length($string);
+
+
+
+   $w->delete(
+              $current_line.'.'.$delete_start_column ,
+              $current_line.'.'.$delete_end_column
+             );
+   }
+
+  $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+  $string = expand($string);
+  $string = substr($string, 0, $current_column);
+  $string = unexpand($string);
+  $insert_column_index = length($string);
+
+  $w->insert($current_line.'.'.$insert_column_index, unexpand($line));
+  $current_line++;
+  }
+
+}
+
+# Backward compatibility
+sub GetMenu
+{
+ carp((caller(0))[3]." is deprecated") if $^W;
+ shift->menu
+}
+
+1;
+__END__
+
diff --git a/lines.pl b/lines.pl
new file mode 100644
index 0000000..9caad62
--- /dev/null
+++ b/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"
diff --git a/makedist.pl b/makedist.pl
new file mode 100644
index 0000000..7ff5342
--- /dev/null
+++ b/makedist.pl
@@ -0,0 +1,3 @@
+#!/usr/bin/perl
+
+use Archive::Tar;
diff --git a/mb.conf b/mb.conf
new file mode 100644
index 0000000..4d583fd
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/milkbone.nsi b/milkbone.nsi
new file mode 100644
index 0000000..8e94495
--- /dev/null
+++ b/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
diff --git a/mos.pl b/mos.pl
new file mode 100755
index 0000000..4e061a7
--- /dev/null
+++ b/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();
diff --git a/patch.nsi b/patch.nsi
new file mode 100644
index 0000000..93665cb
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/perl58.dll b/perl58.dll
new file mode 100644
index 0000000..10d77c1
Binary files /dev/null and b/perl58.dll differ
diff --git a/plugins/Bark.pl b/plugins/Bark.pl
new file mode 100644
index 0000000..608d431
--- /dev/null
+++ b/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;
diff --git a/plugins/Forum-Check/Forum-Check.pl b/plugins/Forum-Check/Forum-Check.pl
new file mode 100644
index 0000000..107e467
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Forum-Check/Speak.pl b/plugins/Forum-Check/Speak.pl
new file mode 100644
index 0000000..1941f04
--- /dev/null
+++ b/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}"); });
\ No newline at end of file
diff --git a/plugins/Log.pl b/plugins/Log.pl
new file mode 100644
index 0000000..1ccf3c4
--- /dev/null
+++ b/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;
diff --git a/plugins/Milkbot-Music.pl b/plugins/Milkbot-Music.pl
new file mode 100644
index 0000000..b837241
--- /dev/null
+++ b/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;
diff --git a/plugins/Milkbot.pl b/plugins/Milkbot.pl
new file mode 100644
index 0000000..4dd5b19
--- /dev/null
+++ b/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;
diff --git a/plugins/Monitor.pl b/plugins/Monitor.pl
new file mode 100644
index 0000000..7341adf
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net-OSCAR.pl b/plugins/Net-OSCAR/Net-OSCAR.pl
new file mode 100644
index 0000000..b0a9262
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR.pm b/plugins/Net-OSCAR/Net/OSCAR.pm
new file mode 100644
index 0000000..af89eaf
--- /dev/null
+++ b/plugins/Net-OSCAR/Net/OSCAR.pm
@@ -0,0 +1,2663 @@
+package Net::OSCAR;
+
+$VERSION = '0.62'; 
+
+=head1 NAME
+
+Net::OSCAR - Implementation of AOL's OSCAR protocol for instant messaging
+
+=head1 SYNOPSIS
+
+	use Net::OSCAR qw(:standard);
+	use Net::OSCAR::OldPerl; # You may need to use this perls older than 5.6.
+
+	$oscar = Net::OSCAR->new();
+	$oscar->set_callback_foo(\&foo);
+	$oscar->signon($screenname, $password);
+	while(1) {
+		$oscar->do_one_loop();
+		# Do stuff
+	}
+
+=head1 INSTALLATION
+
+	perl Makefile.PL
+	make
+	make test
+	make install
+
+See C<perlmodinstall> for details.
+
+=head1 DEPENDENCIES
+
+This modules requires C<Digest::MD5> and C<Scalar::Util>.
+
+=head1 ABSTRACT
+
+C<Net::OSCAR> implements the OSCAR protocol which is used by AOL's AOL Instant
+Messenger service.  To use the module, you create a C<Net::OSCAR> object,
+register some functions as handlers for various events by using the module's
+callback mechanism, and then continually make calls to the module's event
+processing methods.
+
+You probably want to use the :standard parameter when importing this module
+in order to have a few important constants added to your namespace.  See
+L<"CONSTANTS"> below for a list of the constants exported by the C<:standard> tag.
+
+No official documentation exists for the OSCAR protocol, so it had to be figured
+out by analyzing traffic generated by AOL's official AOL Instant Messenger client.
+That doesn't really help this module's stability much.
+
+This module strives to be as compatible with C<Net::AIM> as possible, but some
+protocol-level differences prevent total compatibility.  The TOC protocol implemented
+by C<Net::AIM> is simpler and more well-documented but less-powerful protocol then
+C<OSCAR>.  See the section on L<Net::AIM Compatibility> for more information.
+
+=head1 EVENT PROCESSING
+
+There are three main ways for the module to handle event processing.  The first is to
+call the L<do_one_loop> method, which performs a C<select> call on all the object's
+sockets and reads incoming commands from the OSCAR server on any connections which
+have them.  The C<select> call has a default timeout of 0.01 seconds which can
+be adjust using the L<timeout> method.
+
+A second way of doing event processing is designed to make it easy to integrate
+C<Net::OSCAR> into an existing C<select>-based event loop, especially one where you
+have many C<Net::OSCAR> objects.  Simply call the L<"process_connections"> method
+with references to the lists of readers, writers, and errors given to you by
+C<select>.  Connections that don't belong to the object will be ignored, and
+connections that do belong to the object will be removed from the C<select> lists
+so that you can use the lists for your own purposes.  Here is an example that
+demonstrates how to use this method with multiple C<Net::OSCAR> objects:
+
+	my($rin, $win) = (0, 0);
+	foreach my $oscar(@oscars) {
+		my($thisrin, $thiswin) = $oscar->selector_filenos;
+		$rin |= $thisrin;
+		$win |= $thiswin;
+	}
+	# Add in any other file descriptors you care about using vec().
+	my $ein = $rin | $win;
+	select($rin, $win, $ein, 0.01);
+	foreach my $oscar(@oscars) {
+		$oscar->process_connections(\$rin, \$win, \$ein);
+	}
+
+	# Now $rin, $win, and $ein only have the file descriptors not
+	# associated with any of the OSCAR objects in them - we can
+	# process our events.
+
+The third way of doing connection processing uses the L<"connection_changed">
+callback in conjunction with C<Net::OSCAR::Connection>'s L<"process_one"> method.
+This method, in conjunction with C<IO::Poll>, probably offers the highest performance
+in situations where you have a long-lived application which creates and destroys many
+C<Net::OSCAR> sessions; that is, an application whose list of file descriptors to
+monitor will likely be sparse.  However, this method is the most complicated.
+What you need to do is call C<IO::Poll::mask> inside of the L<"connection_changed">
+callback.  That part's simple.  The tricky bit is figuring out which
+C<Net::OSCAR::Connection::process_one>'s to call and how to call them.  My recommendation
+for doing this is to use a hashmap whose keys are the file descriptors of everything
+you're monitoring in the C<IO::Poll> - the FDs can be retrieved by doing
+C<fileno($connection-E<gt>get_filehandle)> inside of the L<"connection_changed"> -
+and then calling C<@handles = $poll-E<gt>handles(POLLIN | POLLOUT | POLLERR | POLLHUP)>
+and walking through the handles.
+
+
+=head1 FUNCTIONALITY
+
+C<Net::OSCAR> pretends to be WinAIM 4.7.2480.  It supports remote buddylists
+including permit and deny settings.  It also supports chat.  At the present
+time, setting and retrieving of directory information is not supported; nor
+are email privacy settings, buddy icons, voice chat, stock ticker, and
+many other of the official AOL Instant Messenger client's features.
+
+=head1 TERMINOLOGY/METHODOLOGY
+
+When you sign on with the OSCAR service, you are establishing an OSCAR session.
+C<Net::OSCAR> connects to the login server and requests a random challenge
+string.  It then sends the MD5 sum of the challenge string,
+C<AOL Instant Messenger (SM)>, and your password to the server.  If the login
+is successful, the login server gives you an IP address and an authorization
+cookie to use to connect with the BOS (Basic OSCAR Services) server.
+
+C<Net::OSCAR> proceeds to disconnect from the login server and connect to the
+BOS server.  The two go through a handshaking process which includes the
+server sending us our buddylist.
+
+C<Net::OSCAR> supports privacy controls.  Our visibility setting, along
+with the contents of the permit and deny lists, determines who can
+contact us.  Visibility can be set to permit or deny everyone, permit only
+those on the permit list, deny only those on the deny list, or permit
+everyone on our buddylist.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
+use Carp;
+use Scalar::Util;
+use Net::OSCAR::Common qw(:all);
+use Net::OSCAR::Connection;
+use Net::OSCAR::Callbacks;
+use Net::OSCAR::TLV;
+use Net::OSCAR::Buddylist;
+use Net::OSCAR::Screenname;
+use Net::OSCAR::Chat;
+use Net::OSCAR::_BLInternal;
+use Net::OSCAR::OldPerl;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = @Net::OSCAR::Common::EXPORT_OK;
+%EXPORT_TAGS = %Net::OSCAR::Common::EXPORT_TAGS;
+
+=pod
+
+=item new
+
+Creates a new C<Net::OSCAR> object.
+
+=cut
+
+sub new($) {
+	my $class = ref($_[0]) || $_[0] || "Net::OSCAR";
+	shift;
+	my $self = { };
+	bless $self, $class;
+	$self->{LOGLEVEL} = 0;
+	$self->{SNDEBUG} = 0;
+	$self->{description} = "OSCAR session";
+
+	$self->{timeout} = 0.01;
+
+	return $self;
+}
+
+
+=pod
+
+=item timeout ([NEW TIMEOUT])
+
+Gets or sets the timeout value used by the L<do_one_loop> method.
+The default timeout is 0.01 seconds.
+
+=cut
+
+sub timeout($;$) {
+	my($self, $timeout) = @_;
+	return $self->{timeout} unless $timeout;
+	$self->{timeout} = $timeout;
+}
+
+=pod
+
+=item signon (HASH) 
+
+=item signon (SCREENNAME, PASSWORD[, HOST, PORT])
+
+Sign on to the OSCAR service.  Using a hash to
+pass the parameters to this function is preferred -
+the old method is deprecated.  You can specify an
+alternate host/port to connect to.  The default is
+login.oscar.aol.com port 5190.
+
+If you use a hash to pass parameters to this function,
+here are the valid keys:
+
+=over 4
+
+=item screenname
+
+=item password
+
+Screenname and password are mandatory.  The other keys are optional.
+In the special case of password being present but undefined, the
+auth_challenge callback will be used - see L<"auth_challenge"> for details.
+
+=item host
+
+=item port
+
+=back
+
+There are some other data that can be passed to this method.
+These data are used to sign on to an OSCAR-using service other than the default of
+AOL Instant Messenger, such as ICQ.  You should not attempt to specify
+these data directly - instead, use one of the following constants:
+
+=over 4
+
+=item OSCAR_SVC_AIM
+
+=item OSCAR_SVC_ICQ
+
+=back
+
+Example of signing on to ICQ:
+
+	$oscar->signon(screenname => "123456", password => "password", OSCAR_SVC_ICQ);
+
+=cut
+
+sub signon($@) {
+	my($self, $password, $host, %args);
+	$self = shift;
+
+	# Determine whether caller is using hash-method or old method of passing parms.
+	# Note that this breaks if caller passes in both a host and a port using the old way.
+	# But hey, that's why it's deprecated!
+	if(@_ < 3) {
+		$args{screenname} = shift @_ or return $self->crapout($self->{bos}, "You must specify a username to sign on with!");
+		$args{password} = shift @_ or return $self->crapout($self->{bos}, "You must specify a password to sign on with!");;
+		$args{host} = shift @_ if @_;
+		$args{port} = shift @_ if @_;
+	} else {
+		%args = @_;
+		return $self->crapout($self->{bos}, "You must specify a username and password to sign on with!") unless $args{screenname} and exists($args{password});
+	}
+
+	my %defaults = OSCAR_SVC_AIM;
+	foreach my $key(keys %defaults) {
+		$args{$key} ||= $defaults{$key};
+	}
+	return $self->crapout($self->{bos}, "MD5 authentication not available for this service (you must define a password.)") if !defined($args{password}) and $args{hashlogin};
+	$self->{screenname} = new Net::OSCAR::Screenname $args{screenname};
+
+	# We set BOS to the login connection so that our error handlers pick up errors on this connection as fatal.
+	$args{host} ||= "login.oscar.aol.com";
+	$args{port} ||= 5190;
+
+
+	($self->{screenname}, $password, $host, $self->{port}) =
+		delete @args{qw(screenname password host port)};
+
+	$self->{svcdata} = \%args;
+	$self->{bos} = $self->addconn($password, CONNTYPE_LOGIN, "login", $host);
+}
+
+=pod
+
+=item auth_response (MD5_DIGEST)
+
+Provide a response to an authentication challenge - see the L<"auth_challenge">
+callback for details.
+
+=cut
+
+sub auth_response($$) {
+	my($self, $digest) = @_;
+	$self->log_print(OSCAR_DBG_SIGNON, "Got authentication response - proceeding with signon");
+	$self->{auth_response} = $digest;
+	$self->{bos}->snac_put(family => 0x17, subtype => 0x2, data => tlv(signon_tlv($self)));
+}
+
+=pod
+
+=item signoff
+
+Sign off from the OSCAR service.
+
+=cut
+
+sub signoff($) {
+	my $self = shift;
+	foreach my $connection(@{$self->{connections}}) {
+		$self->delconn($connection);
+	}
+	my $screenname = $self->{screenname};
+	%$self = ();
+	$self->{screename} = $screenname; # Useful for post-mortem processing in multiconnection apps
+}
+
+=pod
+
+=item loglevel ([LOGLEVEL[, SCREENNAME DEBUG]])
+
+Gets or sets the loglevel.  If this is non-zero, varing amounts of information will be printed
+to standard error (unless you have a L<"log"> callback defined).  Higher loglevels will give you more information.
+If the optional screenname debug parameter is non-zero,
+debug messages will be prepended with the screenname of the OSCAR session which is generating
+the message (but only if you don't have a L<"log"> callback defined).  This is useful when you have multiple C<Net::OSCAR> objects.
+
+See the L<"log"> callback for more information.
+
+=cut
+
+sub loglevel($;$$) {
+	my $self = shift;
+	return $self->{LOGLEVEL} unless @_;
+	$self->{LOGLEVEL} = shift;
+	$self->{SNDEBUG} = shift if @_;
+}
+
+sub addconn($$$$$) {
+	my $self = shift;
+	my $conntype = $_[1];
+
+	my $connection = ($conntype == CONNTYPE_CHAT) ? Net::OSCAR::Chat->new($self, @_) : Net::OSCAR::Connection->new($self, @_);
+	if($_[1] == CONNTYPE_BOS) {
+		$self->{bos} = $connection;
+	} elsif($_[1] == CONNTYPE_ADMIN) {
+		$self->{admin} = 1; # We're not quite ready yet - add to queue but don't send svcreq
+	} elsif($_[1] == CONNTYPE_CHATNAV) {
+		$self->{chatnav} = 1;
+	}
+	push @{$self->{connections}}, $connection;
+	$self->callback_connection_changed($connection, "write");
+	return $connection;
+}
+
+sub delconn($$) {
+	my($self, $connection) = @_;
+
+	return unless $self->{connections};
+	$self->callback_connection_changed($connection, "deleted");
+	for(my $i = scalar @{$self->{connections}} - 1; $i >= 0; $i--) {
+		next unless $self->{connections}->[$i] == $connection;
+		$connection->log_print(OSCAR_DBG_NOTICE, "Closing.");
+		splice @{$self->{connections}}, $i, 1;
+		if(!$connection->{sockerr}) {
+			eval {
+				$connection->flap_put("", FLAP_CHAN_CLOSE) if $connection->{socket};
+				close $connection->{socket} if $connection->{socket};
+			};
+		} else {
+			if($connection->{conntype} == CONNTYPE_BOS or ($connection->{conntype} == CONNTYPE_LOGIN and !$connection->{closing})) {
+				delete $connection->{socket};
+				print $connection->{sockerr};
+				return $self->crapout($connection, "Lost connection to BOS");
+			} elsif($connection->{conntype} == CONNTYPE_CHATNAV) {
+				delete $self->{chatnav};
+			} elsif($connection->{conntype} == CONNTYPE_ADMIN) {
+				delete $self->{admin};
+				$self->callback_admin_error("all", ADMIN_ERROR_CONNREF, undef) if scalar(keys(%{$self->{adminreq}}));
+			} elsif($connection->{conntype} == CONNTYPE_CHAT) {
+				$self->callback_chat_closed($connection, "Lost connection to chat");
+			}
+		}
+		delete $connection->{socket};
+		return 1;
+	}
+	return 0;
+}
+
+=pod
+
+=item findconn (FILENO)
+
+Finds the connection that is using the specified file number, or undef
+if the connection could not be found.  Returns a C<Net::OSCAR::Connection>
+object.
+
+=cut
+
+sub findconn($$) {
+	my($self, $target) = @_;
+	my($conn) = grep { fileno($_->{socket}) == $target } @{$self->{connections}};
+	return $conn;
+}
+
+sub DESTROY {
+	my $self = shift;
+
+	foreach my $connection(@{$self->{connections}}) {
+		next unless $connection->{socket} and not $connection->{sockerr};
+		$connection->flap_put("", FLAP_CHAN_CLOSE);
+		close $connection->{socket} if $connection->{socket};
+	}
+}
+
+=pod
+
+=item process_connections (READERSREF, WRITERSREF, ERRORSREF)
+
+Use this method when you want to implement your own C<select>
+statement for event processing instead of using C<Net::OSCAR>'s
+L<do_one_loop> method.  The parameters are references to the
+readers, writers, and errors parameters used by the select
+statement.  The method will ignore all connections which
+are not C<Net::OSCAR::Connection> objects or which are
+C<Net::OSCAR::Connection> objects from a different C<Net::OSCAR>
+object.  It modifies its arguments so that its connections
+are removed from the connection lists.  This makes it very
+convenient for use with multiple C<Net::OSCAR> objects or
+use with a C<select>-based event loop that you are also
+using for other purposes.
+
+See the L<selector_filenos> method for a way to get the necessary
+bit vectors to use in your C<select>.
+
+=cut
+
+sub process_connections($\$\$\$) {
+	my($self, $readers, $writers, $errors) = @_;
+
+	# Filter out our connections and remove them from the to-do list
+	foreach my $connection(@{$self->{connections}}) {
+		my($read, $write) = (0, 0);
+		next unless $connection->fileno;
+		if($connection->{connected}) {
+			next unless vec($$readers | $$errors, $connection->fileno, 1);
+			vec($$readers, $connection->fileno, 1) = 0;
+			$read = 1;
+		}
+		if(!$connection->{connected} or $connection->{outbuff}) {
+			next unless vec($$writers | $$errors, $connection->fileno, 1);
+			vec($$writers, $connection->fileno, 1) = 0;
+			$write = 1;
+		}
+		if(vec($$errors, $connection->fileno, 1)) {
+			vec($$errors, $connection->fileno, 1) = 0;
+			$connection->{sockerr} = 1;
+			print "socket error is: " . $$errors;
+			$connection->disconnect();
+		} else {
+			$connection->process_one($read, $write);
+		}
+	}
+}
+
+=pod
+
+=item do_one_loop
+
+Processes incoming data from our connections to the various
+OSCAR services.  This method reads one command from any
+connections which have data to be read.  See the
+L<timeout> method to set the timeout interval used
+by this method.
+
+=cut
+
+sub do_one_loop($) {
+	my $self = shift;
+	my $timeout = $self->{timeout};
+
+	undef $timeout if $timeout == -1;
+
+	my($rin, $win, $ein) = ('', '', '');
+
+	foreach my $connection(@{$self->{connections}}) {
+		next unless exists($connection->{socket});
+		if($connection->{connected}) {
+			vec($rin, fileno $connection->{socket}, 1) = 1;
+		} else {
+			vec($win, fileno $connection->{socket}, 1) = 1;
+		}
+	}
+	$ein = $rin | $win;
+
+	my $nfound = select($rin, $win, $ein, $timeout);
+	$self->process_connections(\$rin, \$win, \$ein) if $nfound;
+}
+
+sub findgroup($$) {
+	my($self, $groupid) = @_;
+	my($group, $currgroup, $currid);
+
+	my $thegroup = undef;
+
+	$self->log_printf(OSCAR_DBG_DEBUG, "findgroup 0x%04X", $groupid);
+	while(($group, $currgroup) = each(%{$self->{buddies}})) {
+		$self->log_printf(OSCAR_DBG_DEBUG, "\t$group == 0x%04X", $currgroup->{groupid});
+		next unless exists($currgroup->{groupid}) and $groupid == $currgroup->{groupid};
+		$thegroup = $group;
+		last;
+	}
+	my $a = keys %{$self->{buddies}}; # reset the iterator
+	return $thegroup;
+}
+
+=pod
+
+=item findbuddy (BUDDY)
+
+Returns the name of the group that BUDDY is in, or undef if
+BUDDY could not be found in any group.  If BUDDY is in multiple
+groups, will return the first one we find.
+
+=cut
+
+
+sub findbuddy($$) {
+	my($self, $buddy) = @_;
+
+	#$self->log_print(OSCAR_DBG_DEBUG, "findbuddy $buddy");
+	foreach my $group(keys %{$self->{buddies}}) {
+		#$self->debug_print("\t$buddy? ", join(",", keys %{$self->{buddies}->{$group}->{members}}));
+		return $group if $self->{buddies}->{$group}->{members}->{$buddy};
+	}
+	return undef;
+}
+
+sub findbuddy_byid($$$) {
+	my($self, $buddies, $bid) = @_;
+
+	while(my($buddy, $value) = each(%$buddies)) {
+		return $buddy if $value->{buddyid} == $bid;
+	}
+	return undef;
+}
+
+sub newid($;$) {
+	my($self, $group) = @_;
+	my $id = 0;
+	my %ids = ();
+
+	if($group) {
+		%ids = map { $_->{buddyid} => 1 } values %$group;
+		do { ++$id; } while($ids{$id});
+	} else {
+		do { $id = ++$self->{nextid}->{__GROUPID__}; } while($self->findgroup($id));
+	}
+	return $id;
+}
+
+=pod
+
+=item commit_buddylist
+
+Sends your modified buddylist to the OSCAR server.  Changes to the buddylist
+won't actually take effect until this method is called.  Methods that change
+the buddylist have a warning about needing to call this method in their
+documentation.
+
+=item rollback_buddylist
+
+Revert changes you've made to the buddylist, assuming you haven't called
+L<"commit_buddylist"> since making them.
+
+=item reorder_groups (GROUPS)
+
+Changes the ordering of the groups in your buddylist.  Call L<"commit_buddylist"> to
+save the
+new order on the OSCAR server.
+
+=item reorder_buddies (GROUP, BUDDIES)
+
+Changes the ordering of the buddies in a group on your buddylist.
+Call L<"commit_buddylist"> to save the new order on the OSCAR server.
+
+=item add_permit (BUDDIES)
+
+Add buddies to your permit list.  Call L<"commit_buddylist"> for the
+change to take effect.
+
+=item add_deny (BUDDIES)
+
+See L<add_permit>.
+
+=item remove_permit (BUDDIES)
+
+See L<add_permit>.
+
+=item remove_deny (BUDDIES)
+
+See L<add_permit>.
+
+=item get_permitlist
+
+Returns a list of all members of the permit list.
+
+=item get_denylist
+
+Returns a list of all members of the deny list.
+
+=cut
+
+sub commit_buddylist($) {
+	my($self) = shift;
+	return must_be_on($self) unless $self->{is_on};
+	Net::OSCAR::_BLInternal::NO_to_BLI($self);
+}
+
+sub reorder_groups($@) {
+	my $self = shift;
+	return must_be_on($self) unless $self->{is_on};
+	my @groups = @_;
+	tied(%{$self->{buddies}})->setorder(@groups);
+}
+
+sub reorder_buddies($$@) {
+	my $self = shift;
+	return must_be_on($self) unless $self->{is_on};
+	my $group = shift;
+	my @buddies = @_;
+	tied(%{$self->{buddies}->{$group}->{members}})->setorder(@buddies);
+}
+
+sub add_permit($@) { shift->mod_permit(MODBL_ACTION_ADD, "permit", @_); }
+sub add_deny($@) { shift->mod_permit(MODBL_ACTION_ADD, "deny", @_); }
+sub remove_permit($@) { shift->mod_permit(MODBL_ACTION_DEL, "permit", @_); }
+sub remove_deny($@) { shift->mod_permit(MODBL_ACTION_DEL, "deny", @_); }
+sub get_permitlist($) { return keys %{shift->{permit}}; }
+sub get_denylist(@) { return keys %{shift->{deny}}; }
+
+=pod
+
+=item rename_group (OLDNAME, NEWNAME)
+
+Renames a group.  Call L<"commit_buddylist"> for the change to take effect.
+
+=item add_buddy (GROUP, BUDDIES)
+
+Adds buddies to the given group on your buddylist.  Call L<"commit_buddylist">
+for the change to take effect.
+
+=item remove_buddy (GROUP, BUDDIES)
+
+See L<add_buddy>.
+
+=cut
+
+sub rename_group($$$) {
+	my($self, $oldgroup, $newgroup) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	return send_error($self, $self->{bos}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$oldgroup};
+	$self->{buddies}->{$newgroup} = $self->{buddies}->{$oldgroup};
+	delete $self->{buddies}->{$oldgroup};
+}
+
+sub add_buddy($$@) {
+	my($self, $group, @buddies) = @_;
+	$self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_BUDDY, $group, @buddies);
+}
+
+sub remove_buddy($$@) {
+	my($self, $group, @buddies) = @_;
+	$self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_BUDDY, $group, @buddies);
+}
+
+=pod
+
+=item set_visibility (MODE)
+
+Sets the visibility mode, which determines how the permit and deny lists
+are interpreted.  The visibility mode may be:
+
+=over 4
+
+=item *
+
+VISMODE_PERMITALL: Permit everybody.
+
+=item *
+
+VISMODE_DENYALL: Deny everybody.
+
+=item *
+
+VISMODE_PERMITSOME: Permit only those on your permit list.
+
+=item *
+
+VISMODE_DENYSOME: Deny only those on your deny list.
+
+=item *
+
+VISMODE_PERMITBUDS: Same as VISMODE_PERMITSOME, but your permit list is made to be
+the same as the buddies from all the various groups in your
+buddylist (except the deny group!)  Adding and removing buddies
+maintains this relationship.  You shouldn't manually alter the
+permit or deny groups when using this visibility mode.
+
+=back
+
+These constants are contained in the C<Net::OSCAR::Common> package,
+and will be imported into your namespace if you import C<Net::OSCAR>
+with the C<:standard> parameter.
+
+When someone is permitted, they can see when you are online and
+send you messages.  When someone is denied, they can't see when
+you are online or send you messages.  You cannot see them or
+send them messages.  You can talk to them if you are in the same
+chatroom, although neither of you can invite the other one into
+a chatroom.
+
+Call L<"commit_buddylist"> for the change to take effect.
+
+=cut
+
+sub set_visibility($$) {
+	my($self, $vismode) = @_;
+
+	return must_be_on($self) unless $self->{is_on};
+	$self->{visibility} = $vismode;
+}
+
+=pod
+
+=item set_group_permissions (NEWPERMS)
+
+Set group permissions.  This lets you block any OSCAR users or any AOL users.
+C<NEWPERMS> should be a list of zero or more of the following constants:
+
+=over 4
+
+=item GROUPPERM_OSCAR
+
+Permit AOL Instant Messenger users to contact you.
+
+=item GROUPPERM_AOL
+
+Permit AOL subscribers to contact you.
+
+=back
+
+Call L<"commit_buddylist"> for the change to take effect.
+
+=cut
+
+sub set_group_permissions($@) {
+	my($self, @perms) = @_;
+	my $perms = 0xFFFFFF00;
+
+	return must_be_on($self) unless $self->{is_on};
+	foreach my $perm (@perms) { $perms |= $perm; }
+	$self->{groupperms} = $perms;
+}
+
+=pod
+
+=item group_permissions
+
+Returns current group permissions.  The return value is a list like the one
+that L<"set_group_permissions"> wants.
+
+=cut
+
+sub group_permissions($) {
+	my $self = shift;
+	my @retval = ();
+
+	foreach my $perm (GROUPPERM_OSCAR, GROUPPERM_AOL) {
+		push @retval, $perm if $self->{groupperms} & $perm;
+	}
+	return @retval;
+}
+
+=pod
+
+=item profile
+
+Returns your current profile.
+
+=cut
+
+sub profile($) { return shift->{profile}; }
+
+=pod
+
+=item get_app_data ([GROUP[, BUDDY]])
+
+Gets application-specific data.  Returns a hashref whose keys are app-data IDs.
+IDs with high-order byte 0x0001 are reserved for non-application-specific usage
+and must be registered with the C<libfaim-aim-protocol@lists.sourceforge.net> list.
+If you wish to set application-specific data, you should reserve a high-order
+byte for your application by emailing C<libfaim-aim-protocol@lists.sourceforge.net>.
+This data is stored in your server-side buddylist and so will be persistent,
+even across machines.
+
+If C<GROUP> is present, a hashref for accessing data specific to that group
+is returned.
+
+If C<BUDDY> is present, a hashref for accessing data specific to that buddy
+is returned.
+
+Call L<"commit_buddylist"> to have the new data saved on the OSCAR server.
+
+=cut
+
+sub get_app_data($;$$) {
+	my($self, $group, $buddy) = @_;
+
+	return $self->{appdata} unless $group;
+	return $self->{buddies}->{$group}->{data} unless $buddy;
+	return $self->{buddies}->{$group}->{members}->{$buddy}->{data};
+}
+
+sub mod_permit($$$@) {
+	my($self, $action, $group, @buddies) = @_;
+
+	return must_be_on($self) unless $self->{is_on};
+	if($action == MODBL_ACTION_ADD) {
+		foreach my $buddy(@buddies) {
+			next if exists($self->{$group}->{$buddy});
+			$self->{$group}->{$buddy}->{buddyid} = $self->newid($self->{group});
+		}
+	} else {
+		foreach my $buddy(@buddies) {
+			delete $self->{$group}->{$buddy};
+		}
+	}
+}
+
+sub mod_buddylist($$$$;@) {
+	my($self, $action, $what, $group, @buddies) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	@buddies = ($group) if $what == MODBL_WHAT_GROUP;
+
+	if($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_ADD) {
+		return if exists $self->{buddies}->{$group};
+		$self->{buddies}->{$group} = {
+			groupid => $self->newid(),
+			members => bltie,
+			data => tlvtie
+		};
+	} elsif($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_DEL) {
+		return unless exists $self->{buddies}->{$group};
+		delete $self->{buddies}->{$group};
+	} elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_ADD) {
+		$self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_GROUP, $group) unless exists $self->{buddies}->{$group};
+		@buddies = grep {not exists $self->{buddies}->{$group}->{members}->{$_}} @buddies;
+		return unless @buddies;
+		foreach my $buddy(@buddies) {
+			$self->{buddies}->{$group}->{members}->{$buddy} = {
+				buddyid => $self->newid($self->{buddies}->{$group}->{members}),
+				data => tlvtie,
+				online => 0,
+				comment => undef
+			};
+		}
+	} elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_DEL) {
+		return unless exists $self->{buddies}->{$group};
+		@buddies = grep {exists $self->{buddies}->{$group}->{members}->{$_}} @buddies;
+		return unless @buddies;
+		foreach my $buddy(@buddies) {
+			delete $self->{buddies}->{$group}->{members}->{$buddy};
+		}
+		$self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group) unless scalar keys %{$self->{buddies}->{$group}->{members}};
+	}
+}
+
+sub extract_userinfo($$) {
+	my($self, $data) = @_;
+	my $retval = {};
+	my $tlvcnt;
+
+	($retval->{screenname}, $retval->{evil}, $tlvcnt) = unpack("C/a* n n", $data);
+	$retval->{screenname} = new Net::OSCAR::Screenname $retval->{screenname};
+	$retval->{evil} /= 10;
+	substr($data, 0, 5+length($retval->{screenname})) = "";
+	$self->log_print(OSCAR_DBG_DEBUG, "Decoding userinfo TLV with tlvcnt $tlvcnt.");
+
+	my($tlv, $chainlen) = tlv_decode($data, $tlvcnt);
+	#$chainlen--;
+
+	$self->log_print(OSCAR_DBG_DEBUG, "Done decoding userinfo TLV - chainlen $chainlen.");
+	my($flags) = unpack("n", $tlv->{1});
+	$retval->{trial} = $flags & 0x1;
+	$retval->{admin} = $flags & 0x2;
+	$retval->{aol} = $flags & 0x4;
+	$retval->{pay} = $flags & 0x8;
+	$retval->{free} = $flags & 0x10;
+	$retval->{away} = $flags & 0x20;
+	$retval->{mobile} = $flags & 0x80;
+
+	($retval->{membersince}) = unpack("N", $tlv->{2}) if exists($tlv->{2});
+	($retval->{onsince}) = unpack("N", $tlv->{3}) if exists($tlv->{3});
+	($retval->{idle}) = unpack("n", $tlv->{4}) if exists($tlv->{4});
+	($retval->{capabilities}) = $tlv->{0xD} if exists($tlv->{0xD});
+
+	substr($data, 0, $chainlen) = "";
+
+	if($data) {
+		$tlv = tlv_decode($data);
+		$retval->{profile} = $tlv->{0x2} if $tlv->{0x2};
+		$retval->{awaymsg} = $tlv->{0x4} if $tlv->{0x4};
+		$retval->{chatdata} = $tlv->{0x5} if $tlv->{0x5};
+	}
+
+	$chainlen += 5+length($retval->{screenname});
+	return wantarray ? ($retval, $chainlen) : $retval;
+}
+
+=pod
+
+=item get_info (WHO)
+
+Requests a user's information, which includes their profile and idle time.
+See the L<buddy_info> callback for more information.
+
+=item get_away (WHO)
+
+Similar to L<get_info>, except requests the user's away message instead of
+their profile.
+
+=cut
+
+sub get_info($$) {
+	my($self, $screenname) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	$self->{bos}->snac_put(reqdata => $screenname, family => 0x2, subtype => 0x5, data => pack("nCa*", 1, length($screenname), $screenname));
+}
+
+sub get_away($$) {
+	my($self, $screenname) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	$self->{bos}->snac_put(reqdata => $screenname, family => 0x2, subtype => 0x5, data => pack("nCa*", 3, length($screenname), $screenname));
+}
+
+=pod
+
+=item send_im (WHO, MESSAGE[, AWAY])
+
+Sends someone an instant message.  If the message is an automated reply generated,
+perhaps, because you have an away message set, give the AWAY parameter a non-zero
+value.  Note that C<Net::OSCAR> will not handle sending away messages to people who
+contact you when you are away - you must perform this yourself if you want it done.
+
+Returns a "request ID" that you can use in the C<im_ok> callback to identify the message.
+If the message was too long to send, returns zero.
+
+=cut
+
+sub send_im($$$;$) {
+	my($self, $to, $msg, $away) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	my $packet = "";
+	my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
+
+	if(!$self->{svcdata}->{hashlogin}) {
+		return 0 if length($msg) >= 7987;
+	} else {
+		return 0 if length($msg) > 2000;
+	}
+
+	$packet = randchars(8);
+	$packet .= pack("n", 1); # channel
+	$packet .= pack("Ca*", length($to), $to);
+
+	$packet .= tlv(2 => pack("n3 C n C n3 a*", 0x501, 4, 0x101, 1, 0x201, 1, length($msg)+4, 0, 0, $msg));
+
+	if($away) {
+		$packet .= tlv(4 => "");
+	} else {
+		$packet .= tlv(3 => ""); #request server confirmation
+	}
+
+	$self->{bos}->snac_put(reqid => $reqid, reqdata => $to, family => 0x4, subtype => 0x6, data => $packet, 
+		flags2 => 0xb);
+
+	return $reqid;
+}
+
+=pod
+
+=item set_typing (WHO, STATUS)
+
+Tells user WHO that your typing status has changed.  STATUS can be any of the following values: MTN_TYPING_DONE,
+MTN_TEXT_TYPED MTN_TYPING_BEGUN.
+
+=cut
+
+sub set_typing($$$) {
+	my($self, $who, $status) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	my $packet = "";
+
+	$packet .= pack("n*", 0, 0, 0, 0);
+	$packet .= pack("n", 0x01);
+	$packet .= pack("Ca*", length($who), $who);
+
+	$packet .= pack("n", $status);
+
+	$self->{bos}->snac_put(family => 0x4, subtype => 0x14, data => $packet);
+}
+
+=pod
+
+=item buddyhash
+
+Returns a reference to a tied hash which automatically normalizes its keys upon a fetch.
+Use this for hashes whose keys are AIM screennames since AIM screennames with different
+capitalization and spacing are considered equivalent.
+
+The keys of the hash as returned by the C<keys> and C<each> functions will be
+C<Net::OSCAR::Screenname> objects, so you they will automagically be compared
+without regards to case and whitespace.
+
+=cut
+
+sub buddyhash($) { bltie; }
+
+sub im_parse($$) {
+	my($self, $data) = @_;
+	my($from, $msg, $away) = ("", "", 0);
+	my $chat = undef;
+	my $chaturl = undef;
+
+	my $cookie = substr($data, 0, 8, ""); #OSCAR is so nice, it feeds us BLTs and cookies as SNACs.
+	my($channel) = unpack("n", substr($data, 0, 2, ""));
+	if($channel != 1 and $channel != 2) {
+		carp "Got ICBM on unsupported channel $channel - ignoring.";
+		return;
+	} else {
+		$self->log_print(OSCAR_DBG_DEBUG, "Incoming ICBM on channel $channel.");
+	}
+
+	$self->log_print(OSCAR_DBG_DEBUG, "Extracting user info.");
+	my ($senderinfo, $tlvlen) = $self->extract_userinfo($data);
+	$from = $senderinfo->{screenname};
+
+	# Copying gAIM/libfaim is *so* much easier than understanding stuff.
+	if($channel == 1) {
+		substr($data, 0, $tlvlen) = "";
+		$self->log_print(OSCAR_DBG_DEBUG, "Decoding ICBM secondary TLV.");
+
+		my $tlv = tlv_decode($data);
+		$msg = $tlv->{2};
+
+		substr($msg, 0, 2) = "";
+		my($y) = unpack("n", substr($msg, 0, 2, ""));
+		substr($msg, 0, $y+2) = "";
+
+		my($msglen, $flags1, $flags2) = unpack("nnn", substr($msg, 0, 6, ""));
+		$msglen -= 4;
+
+		$away = 1 if exists $tlv->{4};
+		if($tlv->{3}) { # server ack requested
+			#$self->log_print(OSCAR_DBG_DEBUG, "Sending message ack.");
+			#$self->{bos}->snac_put(family => 0x4, subtype => 0xC, data =>
+			#	$cookie . pack("nCa*", 1, length($from), $from)
+			#);
+		}
+	} else {
+		$data = $senderinfo->{chatdata};
+		$away = 0;
+
+		substr($data, 0, 26) = "";
+		my $tlv = tlv_decode($data);
+		$msg = $tlv->{0xC};
+		if($tlv->{0x2711}) {
+			($chaturl) = unpack("xx C/a*", $tlv->{0x2711});
+
+			$chaturl =~ /-.*?-(.*)/;
+			$chat = $1;
+			$chat =~ s/%([0-9A-Z]{1,2})/chr(hex($1))/eig;
+		}
+
+		$self->{chatinvites}->{$chaturl} = {
+			cookie => $cookie,
+			sender => $from
+		};
+	}
+
+	return ($from, $msg, $away, $chat, $chaturl);
+}
+
+=pod
+
+=item evil (WHO[, ANONYMOUSLY])
+
+C<Evils>, or C<warns>, a user.  Evilling a user increases their evil level,
+which makes them look bad and decreases the rate at which they can send
+messages.  Evil level gradually decreases over time.  If the second
+parameter is non-zero, the evil will be done anonymously, which does
+not increase the user's evil level by as much as a standard evil.
+
+You can't always evil someone.  You can only do it when they do something
+like send you an instant message.
+
+=cut
+
+sub evil($$;$) {
+	my($self, $who, $anon) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	$self->{bos}->snac_put(reqdata => $who, family => 0x04, subtype => 0x08, data =>
+		pack("n C a*", ($anon ? 1 : 0), length($who), $who)
+	);
+}
+
+sub capabilities($) {
+	my $self = shift;
+	my $caps;
+
+	#AIM_CAPS_CHAT
+	$caps .= pack("C*", map{hex($_)} split(/[ \t\n]+/,
+		"74 8F 24 20  62 87 11 D1   82 22 44 45  53 54 00 00"));	
+
+	return $caps;
+}
+
+=pod
+
+=item set_away (MESSAGE)
+
+Set's the users away message, also marking them as being away.
+If the message is undef or the empty string, the user will be
+marked as no longer being away.
+
+=cut
+
+sub set_away($$) {
+	my($self, $awaymsg) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	shift->set_info(undef, $awaymsg);
+}
+
+=pod
+
+=item set_info (PROFILE)
+
+Sets the user's profile.  Call L<"commit_buddylist"> to have
+the new profile stored on the OSCAR server.
+
+=cut
+
+sub set_info($$;$) {
+	my($self, $profile, $awaymsg) = @_;
+
+	my %tlv;
+	tie %tlv, "Net::OSCAR::TLV";
+
+	if(defined($profile)) {
+		$tlv{0x1} = ENCODING;
+		$tlv{0x2} = $profile;
+		$self->{profile} = $profile;
+	}
+
+	if(defined($awaymsg)) {
+		$tlv{0x3} = ENCODING;
+		$tlv{0x4} = $awaymsg;
+	}
+
+	$tlv{0x5} = $self->capabilities();
+
+	$self->log_print(OSCAR_DBG_NOTICE, "Setting user information.");
+	$self->{bos}->snac_put(family => 0x02, subtype => 0x04, data => tlv_encode(\%tlv));
+}
+
+sub svcdo($$%) {
+	my($self, $service, %snac) = @_;
+	my $svcname = "";
+	if($service == CONNTYPE_ADMIN) {
+		$svcname = "admin";
+	} elsif($service == CONNTYPE_CHATNAV) {
+		$svcname = "chatnav";
+	}
+
+	if($self->{$svcname} and ref($self->{$svcname})) {
+		$self->{$svcname}->snac_put(%snac);
+	} else {
+		push @{$self->{"${svcname}_queue"}}, \%snac;
+		$self->svcreq($service) unless $self->{$svcname};
+	}
+}
+
+sub svcreq($$) {
+        my($self, $svctype) = @_;
+
+        $self->log_print(OSCAR_DBG_INFO, "Sending service request for servicetype $svctype.");
+        $self->{bos}->snac_put(family => 0x1, subtype => 0x4, data => pack("n", $svctype));
+}
+
+=pod
+
+=item change_password (CURRENT PASSWORD, NEW PASSWORD)
+
+Changes the user's password.
+
+=cut
+
+sub change_password($$$) {
+	my($self, $currpass, $newpass) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	if($self->{adminreq}->{ADMIN_TYPE_PASSWORD_CHANGE}++) {
+		$self->callback_admin_error(ADMIN_TYPE_PASSWORD_CHANGE, ADMIN_ERROR_REQPENDING);
+		return;
+	}
+
+	my %tlv;
+	tie %tlv, "Net::OSCAR::TLV";
+
+	%tlv = (
+		0x02 => $newpass,
+		0x12 => $currpass
+	);
+
+	$self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv_encode(\%tlv));
+}
+
+=pod
+
+=item confirm_account
+
+Confirms the user's account.  This can be used when the user's account is in the trial state,
+as determined by the presence of the C<trial> key in the information given when the user's
+information is requested.
+
+=cut
+
+sub confirm_account($) {
+	my($self) = shift;
+	return must_be_on($self) unless $self->{is_on};
+
+	if($self->{adminreq}->{ADMIN_TYPE_ACCOUNT_CONFIRM}++) {
+		$self->callback_admin_error(ADMIN_TYPE_ACCOUNT_CONFIRM, ADMIN_ERROR_REQPENDING);
+		return;
+	}
+	$self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x06);
+}
+
+=pod
+
+=item change_email (NEW EMAIL)
+
+Requests that the email address registered to the user's account be changed.
+This causes the OSCAR server to send an email to both the new address and the
+old address.  To complete the change, the user must follow instructions contained
+in the email sent to the new address.  The email sent to the old address contains
+instructions which allow the user to cancel the change within three days of the
+change request.  It is important that the user's current email address be
+known to the OSCAR server so that it may email the account password if the
+user forgets it.
+
+=cut
+
+sub change_email($$) {
+	my($self, $newmail) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	if($self->{adminreq}->{ADMIN_TYPE_EMAIL_CHANGE}++) {
+		$self->callback_admin_error(ADMIN_TYPE_EMAIL_CHANGE, ADMIN_ERROR_REQPENDING);
+		return;
+	}
+	$self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv(0x11 => $newmail));
+}
+
+=pod
+
+=item format_screenname (NEW FORMAT)
+
+Allows the capitalization and spacing of the user's screenname to be changed.
+The new format must be the same as the user's current screenname, except that
+case may be changed and spaces may be inserted or deleted.
+
+=cut
+
+sub format_screenname($$) {
+	my($self, $newname) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	if($self->{adminreq}->{ADMIN_TYPE_SCREENNAME_FORMAT}++) {
+		$self->callback_admin_error(ADMIN_TYPE_SCREENNAME_FORMAT, ADMIN_ERROR_REQPENDING);
+		return;
+	}
+	$self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv(1 => $newname));
+}
+
+=pod
+
+=item chat_join (NAME[, EXCHANGE])
+
+Creates (or joins?) a chatroom.  The exchange parameter should probably not be
+specified unless you know what you're doing.  Do not use this method
+to accept invitations to join a chatroom - use the L<"chat_accept"> method
+for that.
+
+=cut
+
+sub chat_join($$; $) {
+	my($self, $name, $exchange) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	$exchange ||= 4;
+
+	$self->log_print(OSCAR_DBG_INFO, "Creating chatroom $name ($exchange).");
+	my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
+	$self->{chats}->{pack("N", $reqid)} = $name;
+	$self->svcdo(CONNTYPE_CHATNAV, family => 0x0D, subtype => 0x08, reqid => $reqid, data =>
+		#pack("n Ca*n3C na*", $exchange,
+		#	length("create"), "create", 0xFFFF, 0x100, 0x100, 0xD3,
+		#	length($name), $name
+		#)
+
+		pack("n Ca*n2C a*", $exchange,
+			length("create"), "create", 0xFFFF, 0x100, 0x03,
+			tlv(
+				0xD7 => "en",
+				0xD6 => "us-ascii",
+				0xD3 => $name
+			)
+		)
+	);
+}
+
+=pod
+
+=item chat_accept (CHAT)
+
+Use this to accept an invitation to join a chatroom.
+
+=item chat_decline (CHAT)
+
+Use this to decline an invitation to join a chatroom.
+
+=cut
+
+sub chat_accept($$) {
+	my($self, $chat) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	delete $self->{chatinvites}->{$chat};
+	$self->log_print(OSCAR_DBG_NOTICE, "Accepting chat invite for $chat.");
+	$self->svcdo(CONNTYPE_CHATNAV, family => 0x0D, subtype => 0x04, data =>
+		pack("nca* Cn", 4, length($chat), $chat, 0, 2)
+	);
+}
+
+sub chat_decline($$) {
+	my($self, $chat) = @_;
+	return must_be_on($self) unless $self->{is_on};
+
+	my($invite) = delete $self->{chatinvites}->{$chat} or do {
+		$self->log_print(OSCAR_DBG_WARN, "Chat invite for $chat doesn't exist, so we can't decline it.");
+		return;
+	};
+	$self->log_print(OSCAR_DBG_NOTICE, "Declining chat invite for $chat.");
+	$self->{bos}->snac_put(family => 0x04, subtype => 0x0B, data =>
+		$invite->{cookie} .
+		pack("n", 2) .
+		pack("Ca*", length($invite->{sender}), $invite->{sender}) .
+		pack("nnn", 3, 2, 1)
+	);
+}
+
+sub crapout($$$;$) {
+	my($self, $connection, $reason, $errno) = @_;
+	send_error($self, $connection, $errno || 0, $reason, 1);
+	$self->signoff();
+}
+
+sub must_be_on($) {
+	my $self = shift;
+	send_error($self, $self->{bos}, 0, "You have not finished signing on.", 0);
+}
+
+=pod
+
+=item set_idle (TIME)
+
+Sets the user's idle time in seconds.  Set to zero to mark the user as
+not being idle.  Set to non-zero once the user becomes idle.  The OSCAR
+server will automatically increment the user's idle time once you mark
+the user as being idle.
+
+=cut
+
+sub set_idle($$) {
+	my($self, $time) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	$self->{bos}->snac_put(family => 0x1, subtype => 0x11, data => pack("N", $time));
+}
+
+=pod
+
+=item clone
+
+Clones the object.  This creates a new C<Net::OSCAR> object whose callbacks,
+loglevel, screenname debugging, and timeout are the same as those of the
+current object.  This is provided as a convenience when using multiple
+C<Net::OSCAR> objects in order to allow you to set those parameters once
+and then call the L<signon> method on the object returned by clone.
+
+=cut
+
+sub clone($) {
+	my $self = shift;
+	my $clone = $self->new(); 	# Born in a science lab late one night
+					# Without a mother or a father
+					# Just a test tube and womb with a view...
+
+	# Okay, now we don't want to just copy the reference.
+	# If we did that, changing ourself would change the clone.
+	$clone->{callbacks} = { %{$self->{callbacks}} };
+
+	$clone->{LOGLEVEL} = $self->{LOGLEVEL};
+	$clone->{SNDEBUG} = $self->{SNDEBUG};
+	$clone->{timeout} = $self->{timeout};
+
+	return $clone;
+}
+
+=pod
+
+=item selector_filenos
+
+Returns a list whose first element is a vec of all filehandles that we care
+about reading from and whose second element is a vec of all filehandles that
+we care about writing to.  See the L<"process_connections"> method for details.
+
+=cut
+
+sub selector_filenos($) {
+	my($rin, $win) = ('', '');
+
+	foreach my $connection(@{shift->{connections}}) {
+		next unless $connection->{socket};
+		if($connection->{connected}) {
+			vec($rin, fileno $connection->{socket}, 1) = 1;
+		}
+		if(!$connection->{connected} or $connection->{outbuff}) {
+			vec($win, fileno $connection->{socket}, 1) = 1;
+		}
+	}
+	return ($rin, $win);
+}
+
+=pod
+
+=item visibility
+
+Returns the user's current visibility setting.  See L<set_visibility>.
+
+=item groups
+
+Returns a list of groups in the user's buddylist.
+
+=item buddies (GROUP)
+
+Returns the names of the buddies in the specified group in the user's buddylist.
+The names may not be formatted - that is, they may have spaces and capitalization
+removed.  The names are C<Net::OSCAR::Screenname> objects, so you don't have to
+worry that they're case and whitespace insensitive when using them for comparison.
+
+=item buddy (BUDDY[, GROUP])
+
+Returns information about a buddy on the user's buddylist.  This information is
+a hashref which may have the following keys:
+
+=over 4
+
+=item online
+
+The user is signed on.  If this key is not present, all of the other keys may not
+be present.
+
+=item screenname
+
+The formatted version of the user's screenname.  This includes all spacing and
+capitalization.  This is a C<Net::OSCAR::Screenname> object, so you don't have to
+worry about the fact that it's case and whitespace insensitive when comparing it.
+
+=item comment
+
+A user-defined comment associated with the buddy.  See L<"set_buddy_comment">.
+Note that this key will be present but undefined if there is no comment.
+
+=item trial
+
+The user's account has trial status.
+
+=item aol
+
+The user is accessing the AOL Instant Messenger service from America OnLine.
+
+=item free
+
+Opposite of aol.
+
+=item away
+
+The user is away.
+
+=item admin
+
+The user is an administrator.
+
+=item membersince
+
+Time that the user's account was created, in the same format as the C<time> function.
+
+=item onsince
+
+Time that the user signed on to the service, in the same format as the C<time> function.
+
+=item idle
+
+Time that the user has been idle for, in seconds.  If this key is present but zero,
+the user is not idle.  If this key is not present, the user is not reporting idle time.
+
+=back
+
+=item email
+
+Returns the email address currently assigned to the user's account.
+
+=item screenname
+
+Returns the user's current screenname, including all capitalization and spacing.
+
+=item is_on
+
+Returns true if the user is signed on to the OSCAR service.  Otherwise,
+returns false.
+
+=cut
+
+sub visibility($) { return shift->{visibility}; }
+sub groups($) { return keys %{shift->{buddies}}; }
+sub buddies($;$) {
+	my($self, $group) = @_;
+
+	return keys %{$self->{buddies}->{$group}->{members}} if $group;
+	return map { keys %{$_->{members}} } values %{$self->{buddies}};
+}
+sub buddy($$;$) {
+	my($self, $buddy, $group) = @_;
+	$group ||= $self->findbuddy($buddy);
+	return undef unless $group;
+	return $self->{buddies}->{$group}->{members}->{$buddy};
+}
+sub email($) { return shift->{email}; }
+sub screenname($) { return shift->{screenname}; }
+sub is_on($) { return shift->{is_on}; }
+
+=pod
+
+=item set_buddy_comment (GROUP, BUDDY[, COMMENT])
+
+Set a brief comment about a buddy.  This can be used for things such
+as the buddy's real name.  You must call L<"commit_buddylist"> to save
+the comment to the server.  If COMMENT is undefined, the comment is
+deleted.
+
+=cut
+
+sub set_buddy_comment($$$;$) {
+	my($self, $group, $buddy, $comment) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	$self->{buddies}->{$group}->{members}->{$buddy}->{comment} = $comment;
+}
+
+=pod
+
+=item chat_invite (CHAT, MESSAGE, WHO)
+
+Deprecated.  Provided for compatibility with C<Net::AIM>.
+Use the appropriate method of the C<Net::OSCAR::Chat> object
+instead.
+
+=cut
+
+sub chat_invite($$$@) {
+	my($self, $chat, $msg, @who) = @_;
+	return must_be_on($self) unless $self->{is_on};
+	foreach my $who(@who) { $chat->{connection}->invite($who, $msg); }
+}
+
+=pod
+
+=item chat_leave (CHAT)
+
+Deprecated.  Provided for compatibility with C<Net::AIM>.
+Use the appropriate method of the C<Net::OSCAR::Chat> object
+instead.
+
+=item chat_send (CHAT, MESSAGE)
+
+Deprecated.  Provided for compatibility with C<Net::AIM>.
+Use the appropriate method of the C<Net::OSCAR::Chat> object
+instead.
+
+=cut
+
+sub chat_leave($$) { $_[1]->part(); }
+sub chat_send($$$) { $_[1]->chat_send($_[2]); }
+
+=pod
+
+=back
+
+=head1 CALLBACKS
+
+C<Net::OSCAR> uses a callback mechanism to notify you about different events.
+A callback is registered by calling the C<set_callback_callbackname> method
+with a code reference as a parameter.  For instance, you might call
+C<$oscar-E<gt>set_callback_error(\&got_error);>.  Your callback function will
+be passed parameters which are different for each callback type (and are
+documented below).  The first parameter to each callback function will be
+the C<Net::OSCAR> object which generated the callback.  This is useful
+when using multiple C<Net::OSCAR> objects.
+
+=over 4
+
+=item error (OSCAR, CONNECTION, ERROR, DESCRIPTION, FATAL)
+
+Called when any sort of error occurs (except see L<admin_error> below.)
+
+C<CONNECTION> is the particular connection which generated the error - the C<log_print> method of
+C<Net::OSCAR::Connection> may be useful, as may be getting C<$connection-E<gt>{description}>.
+C<DESCRIPTION> is a nicely formatted description of the error.  C<ERROR> is an error number.
+
+If C<FATAL> is non-zero, the error was fatal and the connection to OSCAR has been
+closed.
+
+=item rate_alert (OSCAR, LEVEL, CLEAR, WINDOW, WORRISOME)
+
+This is called when you are sending commands to OSCAR too quickly.
+
+LEVEL is one of RATE_CLEAR, RATE_ALERT, RATE_LIMIT, or RATE_DISCONNECT from the C<Net::OSCAR::Common>
+package (they are imported into your namespace if you import C<Net::OSCAR> with the C<:standard>
+parameter.)  RATE_CLEAR means that you're okay.  RATE_ALERT means you should slow down.  RATE_LIMIT
+means that the server is ignoring messages from you until you slow down.  RATE_DISCONNECT means you're
+about to be disconnected.
+
+CLEAR and WINDOW tell you the maximum speed you can send in order to maintain RATE_CLEAR standing.
+You must send no more than WINDOW commands in CLEAR milliseconds.  If you just want to keep it
+simple, you can just not send any commands for CLEAR milliseconds and you'll be fine.
+
+WORRISOME is nonzero if C<Net::OSCAR> thinks that the alert is anything worth
+worrying about.  Otherwise it is zero.  This is very rough, but it's a good way
+for the lazy to determine whether or not to bother passing the alert on to
+their users.
+
+=item buddylist_error (OSCAR, ERROR, WHAT)
+
+This is called when there is an error commiting changes to the buddylist.
+C<ERROR> is the error number.  C<WHAT> is a string describing which buddylist
+change failed.  C<Net::OSCAR> will revert the failed change to
+its state before C<commit_buddylist> was called.  Note that the
+buddylist contains information other than the user's buddies - see 
+any method which says you need to call C<commit_buddylist> to have its
+changes take effect.
+
+=item buddylist_ok (OSCAR)
+
+This is called when your changes to the buddylist have been successfully commited.
+
+=item admin_error (OSCAR, REQTYPE, ERROR, ERRURL)
+
+This is called when there is an error performing an administrative function - changing
+your password, formatting your screenname, changing your email address, or confirming your
+account.  REQTYPE is a string describing the type of request which generated the error.
+ERROR is an error message.  ERRURL is an http URL which the user may visit for more
+information about the error.
+
+=item admin_ok (OSCAR, REQTYPE)
+
+This is called when an administrative function succeeds.  See L<admin_error> for more info.
+
+=item chat_closed (OSCAR, CHAT, ERROR)
+
+Your connection to CHAT (a C<Net::OSCAR::Chat> object) was severed due to ERROR.
+
+=item buddy_in (OSCAR, SCREENNAME, GROUP, BUDDY DATA)
+
+SCREENNAME (in buddy group GROUP) has signed on, or their information has
+changed.  BUDDY DATA is the same as that returned by the L<buddy> method.
+
+=item chat_buddy_in (OSCAR, SCREENNAME, CHAT, BUDDY DATA)
+
+SCREENNAME has entered CHAT.  BUDDY DATA is the same as that returned by
+the L<buddy> method.
+
+=item buddy_out (OSCAR, SCREENNAME, GROUP)
+
+Called when a buddy has signed off (or added us to their deny list.)
+
+=item chat_buddy_out (OSCAR, SCREENNAME, CHAT)
+
+Called when someone leaves a chatroom.
+
+=item im_ok (OSCAR, TO, REQID)
+
+Called when an IM to C<TO> is successfully sent.
+REQID is the request ID of the IM as returned by C<send_im>.
+
+=item im_in (OSCAR, FROM, MESSAGE[, AWAY])
+
+Called when someone sends you an instant message.  If the AWAY parameter
+is non-zero, the message was generated as an automatic reply, perhaps because
+you sent that person a message and they had an away message set.
+
+=item chat_im_in (OSCAR, FROM, CHAT, MESSAGE)
+
+Called when someone says something in a chatroom.  Note that you
+receive your own messages in chatrooms unless you specify the
+NOREFLECT parameter in L<chat_send>.
+
+=item chat_invite (OSCAR, WHO, MESSAGE, CHAT, CHATURL)
+
+Called when someone invites us into a chatroom.  MESSAGE is the message
+that they specified on the invitation.  CHAT is the name of the chatroom.
+CHATURL is a chat URL and not a C<Net::OSCAR::Chat> object.  CHATURL can
+be passed to the L<chat_accept> method to accept the invitation.
+
+=item chat_joined (OSCAR, CHATNAME, CHAT)
+
+Called when you enter a chatroom.  CHAT is the C<Net::OSCAR::Chat>
+object for the chatroom.
+
+=item evil (OSCAR, NEWEVIL[, FROM])
+
+Called when your evil level changes.  NEWEVIL is your new evil level,
+as a percentage (accurate to tenths of a percent.)  ENEMY is undef
+if the evil was anonymous (or if the message was triggered because
+your evil level naturally decreased), otherwise it is the screenname
+of the person who sent us the evil.  See the L<"evil"> method for
+more information on evils.
+
+=item buddy_info (OSCAR, SCREENNAME, BUDDY DATA)
+
+Called in response to a L<get_info> or L<get_away> request.
+BUDDY DATA is the same as that returned by the L<buddy> method,
+except that one of two additional keys, C<profile> and C<awaymsg>,
+may be present.
+
+=item signon_done (OSCAR)
+
+Called when the user is completely signed on to the service.
+
+=item auth_challenge (OSCAR, CHALLENGE, HASHSTR)
+
+OSCAR uses an MD5-based challenge/response system for authentication so that the
+password is never sent in plaintext over the network.  When a user wishes to sign on,
+the OSCAR server sends an arbitrary number as a challenge.  The client must respond
+with the MD5 digest of the concatenation of, in this order, the challenge, the password,
+and an additional hashing string (currently always the string
+"AOL Instant Messenger (SM)", but it is possible that this might change in the future.)
+
+If password is undefined in L<"signon">, this callback will be triggered when the
+server sends a challenge during the signon process.  The client must reply with 
+the MD5 digest of CHALLENGE . password . HASHSTR.  For instance, using the
+L<MD5::Digest> module:
+
+	my($oscar, $challenge, $hashstr) = @_;
+	my $md5 = Digest::MD5->new;
+	$md5->add($challenge);
+	$md5->add("password");
+	$md5->add($hashstr);
+	$oscar->auth_response($md5->digest);
+
+Note that this functionality is only available for certain services.  It is
+available for AIM but not ICQ.  Note also that the MD5 digest must be in binary
+form, not the more common hex or base64 forms.
+
+=item log (OSCAR, LEVEL, MESSAGE)
+
+Use this callback if you don't want the log_print methods to just print to STDERR.
+It is called when even C<MESSAGE> of level C<LEVEL> is called.  The levels are,
+in order of increasing importance:
+
+=item typing_status (OSCAR, WHO, LEVEL)
+
+Sent when C<WHO>'s typing status changes to C<LEVEL>.  C<LEVEL> will be one of the following: 
+MTN_TYPING_DONE, MTN_TEXT_TYPED, MTN_TYPING_BEGUN depending on the status of the other user.
+
+=over 4
+
+=item OSCAR_DBG_NONE
+
+Really only useful for setting in the L<"loglevel"> method.  No information will
+be logged.  The default loglevel.
+
+=item OSCAR_DBG_PACKETS
+
+Hex dumps of all incoming/outgoing packets.
+
+=item OSCAR_DBG_DEBUG
+
+Information useful for debugging C<Net::OSCAR>, and precious little else.
+
+=item OSCAR_DBG_SIGNON
+
+Like C<OSCAR_DBG_NOTICE>, but only for the signon process; this is where
+problems are most likely to occur, so we provide this for the common case of
+people who only want a lot of information during signon.  This may be deprecated
+some-day and be replaced by a more flexible facility/level system, ala syslog.
+
+=item OSCAR_DBG_NOTICE
+
+=item OSCAR_DBG_INFO
+
+=item OSCAR_DBG_WARN
+
+=back
+
+Note that these symbols are imported into your namespace if and only if you use
+the C<:loglevels> or C<:all> tags when importing the module (e.g. C<use Net::OSCAR qw(:standard :loglevels)>.)
+
+Also note that this callback is only triggered for events whose level is greater
+than or equal to the loglevel for the OSCAR session.  The L<"loglevel"> method
+allows you to get or set the loglevel.
+
+=item connection_changed (OSCAR, CONNECTION, STATUS)
+
+Called when the status of a connection changes.  The status is "read" if we
+should call L<"process_one"> on the connection when C<select> indicates that
+the connection is ready for reading, "write" if we should call
+L<"process_one"> when the connection is ready for writing, "readwrite" if L<"process_one">
+should be called in both cases, or "deleted" if the connection has been deleted.
+
+C<CONNECTION> is a C<Net::OSCAR::Connection> object.
+
+Users of this callback may also be interested in the L<"get_filehandle">
+method of C<Net::OSCAR::Connection>.
+
+=cut
+
+sub do_callback($@) {
+	my $callback = shift;
+	return unless $_[0]->{callbacks}->{$callback};
+	&{$_[0]->{callbacks}->{$callback}}(@_);
+}
+sub set_callback { $_[1]->{callbacks}->{$_[0]} = $_[2]; }
+
+sub callback_error(@) { do_callback("error", @_); }
+sub callback_buddy_in(@) { do_callback("buddy_in", @_); }
+sub callback_buddy_out(@) { do_callback("buddy_out", @_); }
+sub callback_typing_status(@) { do_callback("typing_status", @_); }
+sub callback_im_in(@) { do_callback("im_in", @_); }
+sub callback_typing_changed(@) { do_callback("typing_changed", @_); }
+sub callback_chat_joined(@) { do_callback("chat_joined", @_); }
+sub callback_chat_buddy_in(@) { do_callback("chat_buddy_in", @_); }
+sub callback_chat_buddy_out(@) { do_callback("chat_buddy_out", @_); }
+sub callback_chat_im_in(@) { do_callback("chat_im_in", @_); }
+sub callback_chat_invite(@) { do_callback("chat_invite", @_); }
+sub callback_buddy_info(@) { do_callback("buddy_info", @_); }
+sub callback_evil(@) { do_callback("evil", @_); }
+sub callback_chat_closed(@) { do_callback("chat_closed", @_); }
+sub callback_buddylist_error(@) { do_callback("buddylist_error", @_); }
+sub callback_buddylist_ok(@) { do_callback("buddylist_ok", @_); }
+sub callback_admin_error(@) { do_callback("admin_error", @_); }
+sub callback_admin_ok(@) { do_callback("admin_ok", @_); }
+sub callback_rate_alert(@) { do_callback("rate_alert", @_); }
+sub callback_signon_done(@) { do_callback("signon_done", @_); }
+sub callback_log(@) { do_callback("log", @_); }
+sub callback_im_ok(@) { do_callback("im_ok", @_); }
+sub callback_connection_changed(@) { do_callback("connection_changed", @_); }
+sub callback_auth_challenge(@) { do_callback("auth_challenge", @_); }
+
+sub set_callback_error($\&) { set_callback("error", @_); }
+sub set_callback_buddy_in($\&) { set_callback("buddy_in", @_); }
+sub set_callback_buddy_out($\&) { set_callback("buddy_out", @_); }
+sub set_callback_typing_status($\&) { set_callback("typing_status", @_); }
+sub set_callback_im_in($\&) { set_callback("im_in", @_); }
+sub set_callback_chat_joined($\&) { set_callback("chat_joined", @_); }
+sub set_callback_chat_buddy_in($\&) { set_callback("chat_buddy_in", @_); }
+sub set_callback_chat_buddy_out($\&) { set_callback("chat_buddy_out", @_); }
+sub set_callback_chat_im_in($\&) { set_callback("chat_im_in", @_); }
+sub set_callback_chat_invite($\&) { set_callback("chat_invite", @_); }
+sub set_callback_buddy_info($\&) { set_callback("buddy_info", @_); }
+sub set_callback_evil($\&) { set_callback("evil", @_); }
+sub set_callback_chat_closed($\&) { set_callback("chat_closed", @_); }
+sub set_callback_buddylist_error($\&) { set_callback("buddylist_error", @_); }
+sub set_callback_buddylist_ok($\&) { set_callback("buddylist_ok", @_); }
+sub set_callback_admin_error($\&) { set_callback("admin_error", @_); }
+sub set_callback_admin_ok($\&) { set_callback("admin_ok", @_); }
+sub set_callback_rate_alert($\&) { set_callback("rate_alert", @_); }
+sub set_callback_signon_done($\&) { set_callback("signon_done", @_); }
+sub set_callback_log($\&) { set_callback("log", @_); }
+sub set_callback_im_ok($\&) { set_callback("im_ok", @_); }
+sub set_callback_connection_changed($\&) { set_callback("connection_changed", @_); }
+sub set_callback_auth_challenge($\&) { set_callback("auth_challenge", @_); }
+
+=pod
+
+=back
+
+=head1 CHATS
+
+Aside from the methods listed here, there are a couple of methods of the
+C<Net::OSCAR::Chat> object that are important for implementing chat
+functionality.  C<Net::OSCAR::Chat> is a descendent of C<Net::OSCAR::Connection>.
+
+=over 4
+
+=item invite (WHO, MESSAGE)
+
+Invite somebody into the chatroom.
+
+=item chat_send (MESSAGE[, NOREFLECT[, AWAY]])
+
+Sends a message to the chatroom.  If the NOREFLECT parameter is
+present, you will not receive the message as an incoming message
+from the chatroom.  If AWAY is present, the message was generated
+as an automatic reply, perhaps because you have an away message set.
+
+=item part
+
+Leave the chatroom.
+
+=item url
+
+Returns the URL for the chatroom.  Use this to associate a chat invitation
+with the chat_joined that C<Net::OSCAR> sends when you've join the chatroom.
+
+=item name
+
+Returns the name of the chatroom.
+
+=item exchange
+
+Returns the exchange of the chatroom.
+This is normally 4 but can be 5 for certain chatrooms.
+
+=back
+
+=head1 ICQ
+
+ICQ support is very preliminary.  A patch enabling us to sign on to
+ICQ was provided by Sam Wong.  No further work beyond the ability
+to sign on has been done on ICQ at this time.  See the C<signon> method
+for details on signing on via ICQ.
+
+=head1 CONSTANTS
+
+The following constants are defined when C<Net::OSCAR> is imported with the
+C<:standard> tag.  Unless indicated otherwise, the constants are magical 
+scalars - they return different values in string and numeric contexts (for
+instance, an error message and an error number.)
+
+=over 4
+
+=item ADMIN_TYPE_PASSWORD_CHANGE
+
+=item ADMIN_TYPE_EMAIL_CHANGE
+
+=item ADMIN_TYPE_SCREENNAME_FORMAT
+
+=item ADMIN_TYPE_ACCOUNT_CONFIRM
+
+=item ADMIN_ERROR_UNKNOWN
+
+=item ADMIN_ERROR_BADPASS
+
+=item ADMIN_ERROR_BADINPUT
+
+=item ADMIN_ERROR_BADLENGTH
+
+=item ADMIN_ERROR_TRYLATER
+
+=item ADMIN_ERROR_REQPENDING
+
+=item ADMIN_ERROR_CONNREF
+
+=item VISMODE_PERMITALL
+
+=item VISMODE_DENYALL
+
+=item VISMODE_PERMITSOME
+
+=item VISMODE_DENYSOME
+
+=item VISMODE_PERMITBUDS
+
+=item RATE_CLEAR
+
+=item RATE_ALERT
+
+=item RATE_LIMIT
+
+=item RATE_DISCONNECT
+
+=item GROUPPERM_OSCAR
+
+=item GROUPPERM_AOL
+
+=back
+
+=head1 Net::AIM Compatibility
+
+Here are the major differences between the C<Net::OSCAR> interface
+and the C<Net::AIM> interface:
+
+=over 4
+
+=item *
+
+No get/set method.
+
+=item *
+
+No newconn/getconn method.
+
+=item *
+
+No group parameter for add_permit or add_deny.
+
+=item *
+
+Many differences in chat handling.
+
+=item *
+
+No chat_whisper.
+
+=item *
+
+No encode method - it isn't needed.
+
+=item *
+
+No send_config method - it isn't needed.
+
+=item *
+
+No send_buddies method - we don't keep a separate local buddylist.
+
+=item *
+
+No normalize method - it isn't needed.  Okay, there is a normalize
+function in C<Net::OSCAR::Common>, but I can't think of any reason
+why it would need to be used outside of the module internals.
+
+=item *
+
+Different callbacks with different parameters.
+
+=back
+
+=head1 MISCELLANEOUS
+
+There are two programs included with the C<Net::OSCAR> distribution.
+oscartest is a minimalist implementation of a C<Net::OSCAR> client.
+snacsnatcher is a tool designed for analyzing the OSCAR protocol from
+libpcap-format packet captures.
+
+There is a class C<Net::OSCAR::Screenname>.  OSCAR screennames
+are case and whitespace insensitive, and if you do something like
+C<$buddy = new Net::OSCAR::Screenname "Matt Sachs"> instead of
+C<$buddy = "Matt Sachs">, this will be taken care of for you when
+you use the string comparison operators (eq, ne, cmp, etc.)
+
+C<Net::OSCAR::Connection>, the class used for connection objects,
+has some methods that may or may not be useful to you.
+
+=over 4
+
+=item get_filehandle
+
+Returns the filehandle used for the connection.  Note that this is a method
+of C<Net::OSCAR::Connection>, not C<Net::OSCAR>.
+
+=item process_one (CAN_READ, CAN_WRITE, HAS_ERROR)
+
+Call this when a C<Net::OSCAR::Connection> is ready for reading and/or
+writing.  You might call this yourself instead of using L<"process_connections">
+when, for instance, using the L<"connection_changed"> callback in conjunction with
+C<IO::Poll> instead of C<select>.  The C<CAN_READ> and C<CAN_WRITE> parameters
+should be non-zero if the connection is ready for the respective operations to be
+performed and zero otherwise.  If and only if there was a socket error with the
+connection, set C<HAS_ERROR> to non-zero.
+
+=item session
+
+Returns the C<Net::OSCAR> object associated with this C<Net::OSCAR::Connection>.
+
+=back
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+0.62, 2002-02-25
+
+=over 4
+
+=item *
+
+Error handling slightly improved; error 29 is no longer unknown.
+
+=item *
+
+A minor internal buddylist enhancement
+
+=item *
+
+snacsnatcher fixes
+
+=back
+
+=item *
+
+0.61, 2002-02-17
+
+=over 4
+
+=item *
+
+Fixed connection handling
+
+=back
+
+=item *
+
+0.60, 2002-02-17
+
+=over 4
+
+=item *
+
+Various connection_changed fixes, including the new readwrite status.
+
+=item *
+
+Added Net::OSCAR::Connection::session method
+
+=item *
+
+Improved Net::OSCAR::Connection::process_one, documented it, and documented using it
+
+=back
+
+=item *
+
+0.59, 2002-02-15
+
+=over 4
+
+=item *
+
+Protocol fixes - solves problem with AOL calling us an unauthorized client
+
+=item *
+
+Better handling of socket errors, especially when writing
+
+=item *
+
+Minor POD fixes
+
+=back
+
+=item *
+
+0.58, 2002-01-20
+
+=over 4
+
+=item *
+
+Send buddylist deletions before adds - needed for complex BL mods (loadbuddies)
+
+=item *
+
+Added hooks to allow client do MD5 digestion for authentication (auth_challenge
+callback, Net::OSCAR::auth_response method)
+
+=back
+
+=item *
+
+0.57, 2002-01-16
+
+=over 4
+
+=item *
+
+Send callback_chat_joined correctly when joining an existing chat
+
+=item *
+
+Don't activate OldPerl fixes for perl 5.6.0
+
+=item *
+
+Ignore chats that we're already in
+
+=back
+
+=item *
+
+0.56, 2002-01-16
+
+=over 4
+
+=item *
+
+Fixed rate handling
+
+=item *
+
+Send multiple buddylist modifications per SNAC
+
+=item *
+
+Detect when someone else signs on with your screenname
+
+=item *
+
+Corrected attribution of ICQ support
+
+=back
+
+=item *
+
+0.55, 2001-12-29
+
+=over 4
+
+=item *
+
+Preliminary ICQ support, courtesy of SDiZ Chen (actually, Sam Wong).
+
+=item *
+
+Restored support for pre-5.6 perls - reverted from C<IO::Socket> to C<Socket>.
+
+=item *
+
+Corrected removal of buddylist entries and other buddylist-handling improvements
+
+=item *
+
+Improved rate handling - new C<worrisome> parameter to rate_alert callback
+
+=item *
+
+Removed remaining C<croak> from C<OSCAR::Connection>
+
+=item *
+
+Added is_on method
+
+=back
+
+=item *
+
+0.50, 2001-12-23
+
+=over 4
+
+=item *
+
+Fixes for the "crap out on 'connection reset by peer'" and "get stuck and slow down in Perl_sv_2bool" bugs!
+
+=item *
+
+Correct handling of very large (over 100 items) buddylists.
+
+=item *
+
+We can now join exchange 5 chats.
+
+=item *
+
+Fixes in modifying permit mode.
+
+=item *
+
+Updated copyright notice courtesy of AOL's lawyers.
+
+=item *
+
+Switch to IO::Socket for portability in set_blocking.
+
+=back
+
+=item *
+
+0.25, 2001-11-26
+
+=over 4
+
+=item *
+
+Net::OSCAR is now in beta!
+
+=item *
+
+We now work with perl 5.005 and even 5.004
+
+=item *
+
+Try to prevent weird Net::OSCAR::Screenname bug where perl gets stuck in Perl_sv_2bool
+
+=item *
+
+Fixed problems with setting visibility mode and adding to deny list (thanks, Philip)
+
+=item *
+
+Added some methods to allow us to be POE-ified
+
+=item *
+
+Added guards around a number of methods to prevent the user from trying to do stuff before s/he's finished signing on.
+
+=item *
+
+Fix *incredibly* stupid error in NO_to_BLI that ate group names
+
+=item *
+
+Fixed bad bug in log_printf
+
+=item *
+
+Buddylist error handling changes
+
+=item *
+
+Added chat_decline command
+
+=item *
+
+Signon, signoff fixes
+
+=item *
+
+Allow AOL screennames to sign on
+
+=item *
+
+flap_get crash fixes
+
+=back
+
+=item *
+
+0.09, 2001-10-01
+
+=over 4
+
+=item *
+
+Crash and undefined value fixes
+
+=item *
+
+New method: im_ok
+
+=item *
+
+New method: rename_group, should fix "Couldn't get group name" error.
+
+=item *
+
+Fix for buddy_in callback and data
+
+=item *
+
+Better error handling when we can't resolve a host
+
+=item *
+
+Vastly improved logging infrastructure - debug_print(f) replaced with log_print(f). debug_print callback is now called log and has an extra parameter.
+
+=item *
+
+Fixed MANIFEST - we don't actually use Changes (and we do use Screenname.pm)
+
+=item *
+
+blinternal now automagically enforces the proper structure (the right things become Net::OSCAR::TLV tied hashes and the name and data keys are automatically created) upon vivification.  So, you can do $bli-E<gt>{0}-E<gt>{1}-E<gt>{2}-E<gt>{data}-E<gt>{0x3} = "foo" without worrying if 0, 1, 2, or data have been tied.  Should close bug #47.
+
+=back
+
+=item *
+
+0.08, 2001-09-07
+
+=over 4
+
+=item *
+
+Totally rewritten buddylist handling.  It is now much cleaner, bug-resistant,
+and featureful.
+
+=item *
+
+Many, many internal changes that I don't feel like enumerating.
+Hey, there's a reason that I haven't declared the interface stable yet! ;)
+
+=item *
+
+New convenience object: Net::OSCAR::Screenname
+
+=item *
+
+Makefile.PL: Fixed perl version test and compatibility with BSD make
+
+=back
+
+=item *
+
+0.07, 2001-08-13
+
+=over 4
+
+=item *
+
+A bunch of Makefile.PL fixes
+
+=item *
+
+Fixed spurious admin_error callback and prevent user from having multiple
+pending requests of the same type.  (closes #39)
+
+=item *
+
+Head off some potential problems with set_visibility.  (closes #34)
+
+=item *
+
+Removed connections method, added selector_filenos
+
+=item *
+
+Added error number 29 (too many recent signons from your site) to Net::OSCAR::Common.
+
+=item *
+
+We now explicitly perl 5.6.0 or newer.
+
+=back
+
+=item *
+
+0.06, 2001-08-12
+
+=over 4
+
+=item *
+
+Prevent sending duplicate signon_done messages
+
+=item *
+
+Don't addconn after crapping out!
+
+=item *
+
+Don't try to delconn unless we have connections.
+
+=item *
+
+delete returns the correct value now in Net::OSCAR::Buddylist.
+
+=item *
+
+Don't use warnings if $] E<lt>= 5.005
+
+=item *
+
+evil is a method, not a manpage (doc fix)
+
+=item *
+
+Added buddyhash method.
+
+=item *
+
+Added a debug_print callback.
+
+=item *
+
+Clarified process_connections method in documentation
+
+=item *
+
+You can now specify an alternate host/port in signon
+
+=item *
+
+Added name method to Chat.
+
+=item *
+
+permit list and deny list are no longer part of buddylist
+
+=item *
+
+Rewrote buddylist parsing (again!)
+
+=item *
+
+No more default profile.
+
+=item *
+
+Fix bug when storing into an already-existing key in Net::OSCAR::Buddylist.
+
+=item *
+
+snacsnatcher: Remove spurious include of Net::OSCAR::Common
+
+=item *
+
+We don't need to handle VISMODE_PERMITBUDS ourself - the server takes care of it.
+Thanks, VB!
+
+=item *
+
+Makefile.PL: Lots of way cool enhancements to make dist:
+
+=over 4
+
+=item -
+
+It modifies the version number for us
+
+=item -
+
+It does a CVS rtag
+
+=item -
+
+It updates the HTML documentation on zevils and the README.
+
+=back
+
+=item *
+
+Added HISTORY and INSTALLATION section to POD.
+
+=back
+
+=item *
+
+0.05, 2001-08-08
+
+=over 4
+
+=item *
+
+Don't send signon_done until after we get buddylist.
+
+=item *
+
+Added signoff method.
+
+=item *
+
+Fixed typo in documentation
+
+=item *
+
+Fixed chat_invite parm count
+
+=item *
+
+Added Scalar::Utils::dualvar variables, especially to Common.pm.
+dualvar variables return different values in numeric and string context.
+
+=item *
+
+Added url method for Net::OSCAR::Chat (closes #31)
+
+=item *
+
+Divide evil by 10 in extract_userinfo (closes #30)
+
+=item *
+
+chat_invite now exposes chatname (closes #32)
+
+=item *
+
+Removed unnecessary and warning-generating session length from extract_userinfo
+
+=back
+
+=item *
+
+0.01, 2001-08-02
+
+=over 4
+
+=item *
+
+Initial release.
+
+=back
+
+=back
+
+=head1 SUPPORT
+
+See http://www.zevils.com/programs/net-oscar/ for support, including
+a mailing list and bug-tracking system.
+
+=head1 AUTHOR
+
+Matthew Sachs E<lt>matthewg@zevils.comE<gt>.
+
+=head1 CREDITS
+
+John "VBScript" for a lot of technical assistance, including the explanation of rates.
+
+Adam Fritzler and the libfaim team for their documentation and an OSCAR implementation that
+was used to help figure out a lot of the protocol details.  E<lt>http://www.zigamorph.net/faim/protocol/E<gt>
+
+Mark Doliner for help with remote buddylists.  E<lt>http://kingant.net/libfaim/ReadThis.htmlE<gt>
+
+Sam Wong E<lt>sam@uhome.netE<gt> for a patch implementing ICQ2000 support.
+
+The gaim team - the source to their libfaim client was also very helpful.  E<lt>http://gaim.sourceforge.net/E<gt>
+
+The users of aimirc for being reasonably patient while this module was developed.  E<lt>http://www.zevils.com/programs/aimirc/E<gt>
+
+Jayson Baker for some last-minute debugging help.
+
+Rocco Caputo for helping to work out the hooks that let use be used with
+POE.  E<lt>http://poe.perl.org/E<gt>
+
+AOL, for creating the AOL Instant Messenger service, even though they aren't terribly helpful to
+developers of third-party clients.
+
+=head1 LEGAL
+
+Copyright (c) 2001 Matthew Sachs.  All rights reserved.
+This program is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.  B<AOL> and B<AMERICA ONLINE> are registered trademarks
+owned by America Online, Inc.  The B<INSTANT MESSENGER> mark is owned by America
+Online, Inc.  B<ICQ> is a trademark and/or servicemark of ICQ.  C<Net::OSCAR> is not
+endorsed by, or affiliated with, America Online, Inc or ICQ.
+
+=cut
+
+1;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Buddylist.pm b/plugins/Net-OSCAR/Net/OSCAR/Buddylist.pm
new file mode 100644
index 0000000..968a402
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Callbacks.pm b/plugins/Net-OSCAR/Net/OSCAR/Callbacks.pm
new file mode 100644
index 0000000..5032201
--- /dev/null
+++ b/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;
+
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Chat.pm b/plugins/Net-OSCAR/Net/OSCAR/Chat.pm
new file mode 100644
index 0000000..c89db1d
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Common.pm b/plugins/Net-OSCAR/Net/OSCAR/Common.pm
new file mode 100644
index 0000000..968ae2d
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Connection.pm b/plugins/Net-OSCAR/Net/OSCAR/Connection.pm
new file mode 100644
index 0000000..0225fec
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/OldPerl.pm b/plugins/Net-OSCAR/Net/OSCAR/OldPerl.pm
new file mode 100644
index 0000000..52096e7
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Net-OSCAR/Net/OSCAR/Screenname.pm b/plugins/Net-OSCAR/Net/OSCAR/Screenname.pm
new file mode 100644
index 0000000..a5ff0c1
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/TLV.pm b/plugins/Net-OSCAR/Net/OSCAR/TLV.pm
new file mode 100644
index 0000000..80636a4
--- /dev/null
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net/OSCAR/_BLInternal.pm b/plugins/Net-OSCAR/Net/OSCAR/_BLInternal.pm
new file mode 100644
index 0000000..4220250
--- /dev/null
+++ b/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;
diff --git a/plugins/Sound.pl b/plugins/Sound.pl
new file mode 100644
index 0000000..a0dca21
--- /dev/null
+++ b/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();
+	}
+}
diff --git a/plugins/Templog.pl b/plugins/Templog.pl
new file mode 100644
index 0000000..9f6f4f7
--- /dev/null
+++ b/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";
+});
diff --git a/plugins/Tk-About/Milkbone/About.pm b/plugins/Tk-About/Milkbone/About.pm
new file mode 100644
index 0000000..6a06453
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-About/Tk-About.pl b/plugins/Tk-About/Tk-About.pl
new file mode 100644
index 0000000..a2e29a2
--- /dev/null
+++ b/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; };
\ No newline at end of file
diff --git a/plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm b/plugins/Tk-AddBuddy/Milkbone/AddBuddy.pm
new file mode 100644
index 0000000..3885590
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-AddBuddy/Milkbone/AddBuddyGroup.pm b/plugins/Tk-AddBuddy/Milkbone/AddBuddyGroup.pm
new file mode 100644
index 0000000..8afdb6b
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-AddBuddy/Tk-AddBuddy.pl b/plugins/Tk-AddBuddy/Tk-AddBuddy.pl
new file mode 100644
index 0000000..2353604
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-BList/HTTP/Lite.pm b/plugins/Tk-BList/HTTP/Lite.pm
new file mode 100644
index 0000000..063b5a3
--- /dev/null
+++ b/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
diff --git a/plugins/Tk-BList/Milkbone/BList.pm b/plugins/Tk-BList/Milkbone/BList.pm
new file mode 100644
index 0000000..422f311
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-BList/Tk-BList.pl b/plugins/Tk-BList/Tk-BList.pl
new file mode 100644
index 0000000..a2e8adc
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-Chat/Milkbone/Chat.pm b/plugins/Tk-Chat/Milkbone/Chat.pm
new file mode 100644
index 0000000..5bc6359
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-Chat/Tk-Chat.pl b/plugins/Tk-Chat/Tk-Chat.pl
new file mode 100644
index 0000000..cbfcf36
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-Convo/Milkbone/Convo.pm b/plugins/Tk-Convo/Milkbone/Convo.pm
new file mode 100644
index 0000000..ff5ebc0
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-Convo/Tk-Convo.pl b/plugins/Tk-Convo/Tk-Convo.pl
new file mode 100644
index 0000000..17d0ead
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-File/Milkbone/File.pm b/plugins/Tk-File/Milkbone/File.pm
new file mode 100644
index 0000000..650d9a1
--- /dev/null
+++ b/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;
+}
\ No newline at end of file
diff --git a/plugins/Tk-File/Tk-File.pl b/plugins/Tk-File/Tk-File.pl
new file mode 100644
index 0000000..6704fc7
--- /dev/null
+++ b/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;
+}
\ No newline at end of file
diff --git a/plugins/Tk-GUI/Milkbone/BrowseEntry.pm b/plugins/Tk-GUI/Milkbone/BrowseEntry.pm
new file mode 100644
index 0000000..7e13ed8
--- /dev/null
+++ b/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__
+
diff --git a/plugins/Tk-GUI/Milkbone/Tree.pm b/plugins/Tk-GUI/Milkbone/Tree.pm
new file mode 100644
index 0000000..9c53a2a
--- /dev/null
+++ b/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) = @_;
+
+
+}
\ No newline at end of file
diff --git a/plugins/Tk-GUI/Tk-GUI.pl b/plugins/Tk-GUI/Tk-GUI.pl
new file mode 100644
index 0000000..34d94c5
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-GUI/Tk/BrowseEdit.pm b/plugins/Tk-GUI/Tk/BrowseEdit.pm
new file mode 100644
index 0000000..af23b31
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-GUI/Tk/Browser.pm b/plugins/Tk-GUI/Tk/Browser.pm
new file mode 100644
index 0000000..bb85abc
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-GUI/Tk/JBrowseEntry.pm b/plugins/Tk-GUI/Tk/JBrowseEntry.pm
new file mode 100644
index 0000000..d1bf357
--- /dev/null
+++ b/plugins/Tk-GUI/Tk/JBrowseEntry.pm
@@ -0,0 +1,1331 @@
+#
+# JBrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
+
+=head1 NAME
+
+JBrowseEntry is a full-featured "Combo-box" (Text-entry combined with drop-down 
+listbox.
+
+=head1 DESCRIPTION
+
+JBrowseEntry widgets allow one to specify a full combo-box, a "readonly" 
+box (text field allows user to type the 1st letter of an item to search for, 
+but user may only ultimately select one of the items in the list), or a 
+"textonly" version (drop-down list disabled), or a completely disabled 
+widget.  One may also specify whether or not the button which activates the 
+dropdown list via the mouse can take focus or not (-btntakesfocus) or 
+whether the widget itself can take focus or is skipped in the focusing 
+order.  The developer can also specify the maximum length of the dropdown 
+list such that if more than that number of items is added, a scrollbar is 
+automatically added (-height).  
+
+One can optionally specify a label (-label), similar to the "LabEntry" widget.  
+By default, the label appears packed to the left of the widget.  The 
+positioning can be specified via the "-labelPack" option.  For example, to 
+position the label above the widget, use "-labelPack => [-side => 'top']".
+
+This widget is similar to other combo-boxes, ie. 	JComboBox, but has good 
+keyboard bindings and allows for quick lookup/search within the listbox. 
+pressing <RETURN> in entry field displays the dropdown box with the 
+first entry most closly matching whatever's in the entry field highlighted. 
+<UP> and <DOWN> arrows work the listbox as well as pressing a key, which will 
+move the highlight to the next item starting with that letter/number, etc.  
+<UP> and <DOWN> arrows pressed within the entry field circle through the 
+various list options as well.  Pressing <RETURN> or <SPACE> in the listbox 
+selects the highlighted entry and copies it to the text field and removes the 
+listbox.  <ESC> removes the listbox from view.  
+
+=head1 EXAMPLES
+
+ It is easiest to illustrate this widget's capabilities via examples:
+ 
+ use Tk;
+ use Tk::JBrowseEntry;
+ 
+ $MainWin = MainWindow->new;
+ 
+ #SET UP SOME DEFAULT VALUES.
+ 
+ $dbname1 = 'cows';
+ $dbname2 = 'foxes';
+ $dbname3 = 'goats';
+ $dbname5 = 'default';
+ 
+ #HERE'S A NORMAL COMBO-BOX.
+ 
+ $jb1 = $MainWin->JBrowseEntry(
+ 	-label => 'Normal:',
+ 	-variable => \$dbname1,
+ 	-state => 'normal',
+ 	-choices => [qw(pigs cows foxes goats)],
+ 	-width  => 12);
+ $jb1->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #THIS ONE HAS THE DROPDOWN LIST DISABLED.
+ 
+ $jb2 = $MainWin->JBrowseEntry(
+ 	-label => 'TextOnly:',
+ 	-variable => \$dbname2,
+ 	-state => 'textonly',
+ 	-choices => [qw(pigs cows foxes goats)],
+ 	-width  => 12);
+ $jb2->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #THIS ONE'S "READONLY" (USER MUST PICK FROM THE LIST, TEXT BOX ALLOWS QUICK 
+ #SEARCH.
+ 
+ $jb3 = $MainWin->JBrowseEntry(
+ 	-label => 'ReadOnly:',
+ 	-variable => \$dbname3,
+ 	-choices => [qw(pigs cows foxes goats)],
+ 	-state => 'readonly',
+ 	-width  => 12);
+ $jb3->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #THIS ONE'S COMPLETELY DISABLED!
+ 
+ $jb4 = $MainWin->JBrowseEntry(
+ 	-label => 'Disabled:',
+ 	-variable => \$dbname3,
+ 	-state => 'disabled',
+ 	-choices => [qw(pigs cows foxes goats)],
+ 	-width  => 12);
+ $jb4->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #HERE'S ONE WITH A SCROLLBAR (NOTE THE "-height" ATTRIBUTE).
+ 
+ $jb5 = $MainWin->JBrowseEntry(
+ 	-label => 'Scrolled List:',
+ 	-width => 12,
+ 	-default => $dbname5,
+ 	-height => 4,
+ 	-variable => \$dbname5,
+ 	-browsecmd => sub {print "-browsecmd!\n";},
+ 	-listcmd => sub {print "-listcmd!\n";},
+ 	-state => 'normal',
+ 	-choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
+ $jb5->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #HERE'S ONE THAT THE BUTTON TAKES KEYBOARD FOCUS.
+ 
+ $jb6 = $MainWin->JBrowseEntry(
+ 	-label => 'Button Focus:',
+ 	-btntakesfocus => 1,
+ 	-arrowimage => $MainWin->Getimage('balArrow'),   #SPECIFY A DIFFERENT BUTTON IMAGE.
+ 	-farrowimage => $MainWin->Getimage('cbxarrow'),  #OPTIONAL 2ND IMAGE FOR BUTTON WHEN FOCUSED. 
+ 	-width => 12,
+ 	-height => 4,
+ 	-variable => \$dbname6,
+ 	-browsecmd => sub {print "-browsecmd!\n";},
+ 	-listcmd => sub {print "-listcmd!\n";},
+ 	-state => 'normal',
+ 	-choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
+ $jb6->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ #HERE'S ONE THAT DOWS NOT TAKE KEYBOARD FOCUS.
+ 
+ $jb7 = $MainWin->JBrowseEntry(
+ 	-label => 'Skip Focus:',
+ 	-takefocus => 0,
+ 	-width => 12,
+ 	-height => 4,
+ 	-variable => \$dbname7,
+ 	-browsecmd => sub {print "-browsecmd!\n";},
+ 	-listcmd => sub {print "-listcmd!\n";},
+ 	-state => 'normal',
+ 	-choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
+ $jb7->pack(
+ 	-side   => 'top', -pady => '10', -anchor => 'w');
+ 
+ $jb7->choices([qw(First Second Fifth Sixth)]);   #REPLACE LIST CHOICES!
+ $jb7->insert(2, 'Third', 'Fourth');              #ADD MORE AFTER 1ST 2.
+ $jb7->insert('end', [qw(Seventh Oops Eighth)]);  #ADD STILL MORE AT END.
+ $jb7->delete(7);                                 #REMOVE ONE.
+ 
+ $b = $MainWin->Button(-text => 'Quit', -command => sub {exit(); });
+ $b->pack(-side => 'top');
+ $jb1->focus;   #PICK ONE TO START WITH KEYBOARD FOCUS.
+ 
+ MainLoop;
+
+=cut
+
+package Tk::JBrowseEntry;
+
+use vars qw($VERSION);
+$VERSION = '4.22'; # $Id$
+
+use Tk;
+use Carp;
+use strict;
+
+require Tk::Frame;
+require Tk::LabEntry;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'JBrowseEntry';
+
+my ($BITMAP, $FOCUSEDBITMAP);
+
+sub ClassInit
+{
+	my($class,$mw) = @_;
+
+	unless(defined($BITMAP))
+	{
+		$BITMAP = __PACKAGE__ . "::downarrwow";
+
+		if ($Tk::platform =~ /Win32/)
+		{
+			my $bits = pack("b10"x10,
+					"..........",
+					"..........",
+					"..........",
+					".#########",
+					"..#######.",
+					"...#####..",
+					"....###...",
+					".....#....",
+					"..........",
+					".........."
+					);
+			$mw->DefineBitmap($BITMAP => 10,10, $bits);
+		}
+		else
+		{
+			my $bits = pack("b11"x12,
+					"....###....",
+					"....###....",
+					"....###....",
+					"....###....",
+					".#########.",
+					"..#######..",
+					"...#####...",
+					"....###....",
+					".....#.....",
+					"...........",
+					".#########.",
+					".#########."
+			);
+			$mw->DefineBitmap($BITMAP => 11,12, $bits);
+		}
+		$FOCUSEDBITMAP = __PACKAGE__ . "::fdownarrow";
+
+		if ($Tk::platform =~ /Win32/)
+		{
+			my $bits = pack("b10"x10,
+					".#.#.#.#.#",
+					".#.......#",
+					"..........",
+					".#########",
+					"..#######.",
+					".#.#####.#",
+					"....###...",
+					".#...#...#",
+					"..........",
+					".##.#.#.##"
+			);
+			$mw->DefineBitmap($FOCUSEDBITMAP => 10,10, $bits);
+		}
+	}
+}
+
+sub Populate
+{
+	my ($w, $args) = @_;
+#print "-args=".join('|',@_);
+#foreach (keys %{$_[1]}) {print "-value($_)=$_[1]->{$_}=\n";};
+#print "-default=$_[1]->{'-default'}=\n";
+	$w->{btntakesfocus} = 0;
+	$w->{btntakesfocus} = delete ($args->{-btntakesfocus})  if (defined($args->{-btntakesfocus}));
+	$w->{arrowimage} = $args->{-arrowimage}  if (defined($args->{-arrowimage}));
+	$w->{farrowimage} = delete ($args->{-farrowimage})  if (defined($args->{-farrowimage}));
+	$w->{arrowimage} ||= $w->{farrowimage}  if ($w->{farrowimage});
+	$w->{takefocus} = 1;
+	$w->{takefocus} = delete ($args->{-takefocus})  if (defined($args->{-takefocus}));
+	$w->{-listwidth} = $args->{-width}  if (defined($args->{-width}));
+	$w->{-foreground} = $args->{-foreground}  if (defined($args->{-foreground}));
+	$w->{-background} = $args->{-background}  if (defined($args->{-background}));
+	$w->{-borderwidth} = delete($args->{-borderwidth})  if (defined($args->{-borderwidth}));
+	$w->{-relief} = delete($args->{-relief})  if (defined($args->{-relief}));
+	$w->SUPER::Populate($args);
+
+	# ENTRY WIDGET AND ARROW BUTTON
+
+	my $lpack = delete $args->{-labelPack};
+	unless (defined $lpack)
+	{
+		$lpack = [-side => "left", -anchor => "e"];
+	}
+	my $labelvalue = $args->{-label};
+#foreach my $x (%$args) {print "-arg($x)=$args->{$x}=\n";};
+	my $ll = $w->Label(-text => delete $args->{-label});
+	my $tf = $w->Frame(-borderwidth => ($w->{-borderwidth} || 2), -highlightthickness => 1, 
+			-relief => ($w->{-relief} || 'sunken'));
+	my $e = $tf->LabEntry(-borderwidth => 0, -relief => 'flat');
+	# FOR SOME REASON, E HAS TO BE A LABENTRY, JUST PLAIN ENTRY WOULDN'T TAKE KEYBOARD EVENTS????
+	my $b = $tf->Button(-borderwidth => 1, -takefocus => $w->{btntakesfocus}, 
+			#-bitmap => '@' . Tk->findINC("balArrow.xbm"));
+			-bitmap => $BITMAP);
+			#-bitmap => '@' . Tk->findINC("cbxarrow.xbm"));
+	#$ll->packForget()  unless ($labelvalue);
+	if ($labelvalue)
+	{
+		$ll->pack(@$lpack);
+	}
+	else
+	{
+		$ll->packForget();   # REMOVE LABEL, IF NO VALUE SPECIFIED.
+	}
+	$w->Advertise("entry" => $e);   #TEXT PART.
+	$w->Advertise("arrow" => $b);   #ARROW BUTTON PART.
+	$w->Advertise("frame" => $tf);  #SURROUNDING FRAME PART.
+	my ($ee) = $w->Subwidget("entry");
+	$w->Advertise("textpart" => $ee);   #TEXT COMPONENT OF LABENTRY WIDGET.
+	$tf->pack(-side => "right", -padx => 0, -pady => 0, -fill => 'x', -expand => 1);
+	$b->pack(-side => "right", -padx => 0, -pady => 0);
+	$e->pack(-side => "right", -fill => 'x', -padx => 0, -pady => 0, -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/ );
+
+	# PROPOGATE FORE & BACKGROUND COLORS TO ALL WIDGETS, IF SPECIFIED.
+
+	if (defined($w->{-foreground}))
+	{
+		$e->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
+		$tf->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
+		$sl->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
+		$b->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
+	}
+	if (defined($w->{-background}))
+	{
+		$e->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
+		$tf->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
+		$sl->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
+		$b->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
+	}
+	elsif ($^O =~ /Win/i)   # SET BACKGROUND TO WINDOWS DEFAULTS (IF NOT SPECIFIED)
+	{
+		$sl->configure( -background => 'SystemWindow' );
+	}
+	if ($^O =~ /Win/i)
+	{
+		$sl->configure( -borderwidth => 1);
+		$c->configure( -borderwidth => ($w->{-borderwidth}||0), -relief => 'ridge' );
+	}
+	$w->Advertise("choices" => $c);   #LISTBOX POPUP MAIN WINDOW PART.
+	$w->Advertise("slistbox" => $sl); #ACTUAL LISTBOX ITSELF.
+	$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],
+			-height      => [qw/PASSIVE  height      Height/,      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],
+			-default   => "-textvariable", 
+			-imgname   => '',
+			-img0      => '',
+			-img1      => '',
+	DEFAULT      => [$e] );
+
+	my $var_ref = $w->cget( "-textvariable" );
+
+	#SET UP DUMMY SO IT DISPLAYSS IF NO VARIABLE SPECIFIED.
+
+	unless (defined($var_ref) && ref($var_ref))
+	{
+		$var_ref = '';
+		$w->configure(-textvariable => \$var_ref);
+	}
+
+	eval { $w->{'default'} = $_[1]->{'-default'} || ${$_[1]->{-variable}}; }; 
+
+
+#print "??? w=$w=\n";
+#foreach (keys %{$w->{ConfigSpecs}}) {print "-value($_)=$w->{ConfigSpecs}->{$_}=\n";};
+}
+
+sub focus
+{
+	my ($w) = shift;
+	my ($state) = $w->cget( "-state" );
+#print "-focus! state=$state= tf=$w->{takefocus}=\n";
+
+	if ($state eq 'disabled')   #MOVE FOCUS ON TO NEXT WIDGET (DON'T TAKE FOCUS).
+	{
+		eval {$w->focusNext->focus; };
+	}
+	else
+	{
+		if ($state eq 'readonly')   #FRAME GETS FOCUS IF READONLY.
+		{
+			$w->Subwidget("frame")->focus;
+		}
+		else                        #OTHERWISE, TEXT ENTRY COMPONENT DOES.
+		{
+			$w->Subwidget("entry")->focus;
+		}
+
+		#BUTTON GETS FOCUS IF BUTTON TAKES FOCUS, BUT WIDGET ITSELF DOESN'T.
+
+		$w->Subwidget("arrow")->focus  if ($state eq 'normal' && !$w->{takefocus} && $w->{btntakesfocus});
+		$w->Subwidget("entry")->selectionRange(0,'end'); #  unless ($state eq 'readonly' && $w->{btntakesfocus});
+	}
+}
+
+sub SetBindings
+{
+	my ($w) = @_;
+
+	my $e = $w->Subwidget("entry");
+	my $f = $w->Subwidget("frame");
+	my $b = $w->Subwidget("arrow");
+	my $sl = $w->Subwidget("slistbox");
+	my $l = $sl->Subwidget("listbox");
+
+	local *returnFn = sub   #HANDLES RETURN-KEY PRESSED IN ENTRY AREA.
+	{
+		my ($state) = $w->cget( "-state" );
+	
+		&LbFindSelection($w);
+		unless ($w->{"popped"})
+		{
+			$w->BtnDown;
+			return if ($state eq 'textonly' || $state eq 'disabled');
+			$w->{'savefocus'} = $w->focusCurrent;
+			$w->Subwidget("slistbox")->focus;
+		}
+		else
+		{
+			$w->LbCopySelection;
+			$e->selectionRange(0,'end');
+			Tk->break;
+		}
+	};
+
+	local *downFn = sub   #HANDLES DOWN-ARROW PRESSED IN ENTRY AREA.
+	{
+		my ($state) = $w->cget( "-state" );
+		&LbFindSelection($w); 
+		if ($w->{"popped"})
+		{
+			return if ($state eq 'textonly' || $state eq 'disabled');
+			&LbFindSelection($w); 
+			$w->{'savefocus'} = $w->focusCurrent;
+			$w->Subwidget("slistbox")->focus;
+		}
+		else
+		{
+			&LbFindSelection($w); 
+			my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+			my (@listsels) = $l->get('0','end');
+			my $index = $w->LbIndex;
+			if (&LbFindSelection($w) == 1)
+			{
+				$index += 1;
+				$index = 0  if ($index > $#listsels);
+			}
+			my $var_ref = $w->cget( "-textvariable" );
+			$$var_ref = $listsels[$index];
+		}
+	};
+	
+	local *upFn = sub   #HANDLES UP-ARROW PRESSED IN ENTRY AREA.
+	{
+		my ($state) = $w->cget( "-state" );
+		if ($w->{"popped"})
+		{
+			return if ($state eq 'textonly' || $state eq 'disabled');
+			&LbFindSelection($w);
+			$w->{'savefocus'} = $w->focusCurrent;
+			$w->Subwidget("slistbox")->focus;
+		}
+		else
+		{
+			&LbFindSelection($w);
+			my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+			my (@listsels) = $l->get('0','end');
+			my $index = $w->LbIndex - 1;
+			$index = $#listsels  if ($index < 0);
+			my $var_ref = $w->cget( "-textvariable" );
+			$$var_ref = $listsels[$index];
+		}
+	};
+
+	local *escapeFn = sub   #HANDLES ESCAPE-KEY PRESSED IN ENTRY AREA.
+	{
+		if ($w->{"popped"})
+		{
+			$w->Popdown;
+		}
+		else
+		{
+			my $var_ref = $w->cget( "-textvariable" );
+			if ($$var_ref eq $w->{'default'} && $w->cget( "-state" ) ne "readonly")
+			{
+				$$var_ref = '';
+			}
+			else
+			{
+				$$var_ref = $w->{'default'};
+			}
+		}
+		$e->selectionRange(0,'end');   #ADDED 20020716
+		# Tk->break;
+	};
+
+	local *spacebarFn = sub   #HANDLES RETURN-KEY PRESSED IN ENTRY AREA.
+	{
+		my ($state) = $w->cget( "-state" );
+	
+		if ($state eq 'readonly')
+		{
+			&LbFindSelection($w);
+			unless ($w->{"popped"})
+			{
+				$w->BtnDown;
+				return if ($state eq 'textonly' || $state eq 'disabled');
+				$w->{'savefocus'} = $w->focusCurrent;
+				$w->Subwidget("slistbox")->focus;
+			}
+			else
+			{
+				$w->LbCopySelection;
+				$e->selectionRange(0,'end');
+				Tk->break;
+			}
+		}
+	};
+
+	# SET BIND TAGS
+
+	$w->bindtags([$w, 'Tk::JBrowseEntry', $w->toplevel, "all"]);
+	$e->bindtags([$e, $e->toplevel, "all"]);
+
+	# IF USER-SPECIFIED IMAGE(S), CHANGE BUTTON IMAGE WHEN GETTING/LOSING FOCUS.
+
+	$b->bind("<FocusIn>", sub
+	{
+		$b = shift;
+		my $img = $w->{farrowimage} || $b->cget('-image');
+		if ($img)
+		{
+			unless ($w->{img0})
+			{
+				$w->{img0} = $img;
+			}
+			$b->configure(-image => $w->{img0});					
+		}
+		elsif ($^O =~ /Win/i)
+		{
+			$w->{img0} = $FOCUSEDBITMAP;
+			$b->configure(-bitmap => $w->{img0});
+		}
+		$w->{imgname} = 'cbfarrow';
+	}
+	);
+	$b->bind("<FocusOut>", sub
+	{
+		$b = shift;
+		my $img = $w->{arrowimage} || $b->cget('-image');
+		if ($img)
+		{
+			unless ($w->{img1})
+			{
+				$w->{img1} = $img;
+			}
+			$b->configure(-image => $w->{img1});					
+		}
+		elsif ($^O =~ /Win/i)
+		{
+			$w->{img1} = $BITMAP;
+			$b->configure(-bitmap => $w->{img1});
+		}
+		$w->{imgname} = 'cbxarrow';
+	}
+	);
+
+	$b->bind('<1>', sub   #MOUSE CLICKED ON BUTTON.
+	{
+		my ($state) = $w->cget( "-state" );
+		&LbFindSelection($w); 
+		$w->BtnDown;    #POPS UP LISTBOX!
+		if ($state eq 'readonly')
+		{
+	     		$w->{'savefocus'} = $w->focusCurrent;
+ 	    		$w->Subwidget("slistbox")->focus;
+		}
+		else
+		{
+			$e->focus;
+		}
+		Tk->break;
+	}
+	);
+	$b->toplevel->bind("<ButtonRelease-1>", sub {$w->ButtonHack;});
+#$e->bind("<ButtonRelease-1>", sub {print "-ebind!\n"; $w->LbClose;});
+#JWT: UNCOMMENTING ABOVE LINE WILL UNPOST LISTBOX IF MOUSE CLICKED IN TEXTAREA, 
+#BUT WILL ELIMINATE ABILITY TO SELECT, TYPE, AND HAVE SELECTED MENU ITEM CHANGE 
+#WHILE TYPING!!!
+
+	$b->bind("<space>", sub
+	{
+		my ($state) = $w->cget( "-state" );
+		return if ($state eq 'textonly' || $state eq 'disabled');
+
+		&LbFindSelection($w);
+		$w->BtnDown;
+		$w->{'savefocus'} = $w->focusCurrent;
+		$w->Subwidget("slistbox")->focus;
+	}
+	);
+	$b->bind("<Return>", sub
+	{
+		my ($state) = $w->cget( "-state" );
+		return if ($state eq 'textonly' || $state eq 'disabled');
+
+		&LbFindSelection($w);
+		$w->BtnDown;
+		$w->{'savefocus'} = $w->focusCurrent;
+		$w->Subwidget("slistbox")->focus;
+		Tk->break;
+	}
+	);
+
+	$b->bind("<Down>", sub
+	{
+		my ($state) = $w->cget( "-state" );
+		return if ($state eq 'textonly' || $state eq 'disabled');
+
+		&LbFindSelection($w);
+		$w->BtnDown;
+		$w->{'savefocus'} = $w->focusCurrent;
+		$w->Subwidget("slistbox")->focus;
+		Tk->break;
+	}
+	);
+
+	$e->bind("<Return>", \&returnFn);
+	$f->bind("<Return>", \&returnFn);
+
+	$e->bind("<Down>", \&downFn);
+	$f->bind("<Down>", \&downFn);
+
+	$e->bind("<space>", \&spacebarFn);
+	$f->bind("<space>", \&spacebarFn);
+
+	$e->bind("<Up>", \&upFn);
+	$f->bind("<Up>", \&upFn);
+
+	$e->bind('<Escape>' => \&escapeFn);
+	$f->bind('<Escape>' => \&escapeFn);
+
+	$e->bind("<Left>", sub {Tk->break;});
+	$e->bind("<Right>", sub {Tk->break;});
+	$f->bind("<Left>", sub {Tk->break;});
+	$f->bind("<Right>", sub {Tk->break;});
+	$e->bind("<Tab>", sub
+	{
+		$w->Popdown  if  ($w->{"popped"});   #UNDISPLAYS LISTBOX.
+		eval { shift->focusNext->focus; };
+	}
+	);
+	$f->bind("<Tab>", sub
+	{
+		$w->Popdown  if  ($w->{"popped"});
+		eval { shift->focusNext->focus; };
+	}
+	);
+
+	# KEYBOARD BINDINGS FOR LISTBOX
+
+	$l->configure(-selectmode => 'browse');
+	$l->configure(-takefocus => 1); 
+	$l->bind("<ButtonRelease-1>", sub
+	{
+		$w->ButtonHack;
+		LbChoose($w, $l->XEvent->x, $l->XEvent->y);
+	}
+	);
+	$l->bind('<Escape>' => sub
+	{
+		$w->LbClose;
+		Tk->break;
+	}
+	);
+	$l->bind('<Return>' => sub
+	{
+		$w->LbCopySelection;
+		$e->selectionRange(0,'end');
+		Tk->break;
+	}
+	);
+	$l->bind('<space>' => sub
+	{
+		my ($state) = $w->cget( "-state" );
+		$w->LbCopySelection;
+		$e->selectionRange(0,'end');
+		Tk->break;
+	}
+	);
+
+	$l->bind('<Tab>' => sub
+	{
+		my ($state) = $w->cget( "-state" );
+		$w->Popdown  if ($^O !~ /Win/i && !$w->{takefocus});  #WINDUHS LOWERS LISTBOX BEHIND CALLER (HIDES IT)!
+		$w->Popdown  if ($^O =~ /Win/i || $state eq 'readonly');  #WINDUHS LOWERS LISTBOX BEHIND CALLER (HIDES IT)!
+		$e->focus()  unless ($state eq 'readonly');  #SO WE'LL POP IT DOWN FIRST! (RAISE WOULDN'T WORK :-()
+		$w->BtnDown  if ($^O =~ /Win/i && $state ne 'readonly' && $w->{takefocus});
+		Tk->break;
+	}
+	);
+	$l->bind('<Key>' => [\&keyFn,$w,$e,$l,1]);  
+			#if $w->cget( "-state" ) eq "readonly";
+	$e->bind('<Key>' => [\&keyFn,$w,$e,$l]);
+	$f->bind('<Key>' => [\&keyFn,$w,$e,$l]);
+			#unless $w->cget( "-state" ) eq "readonly";
+	$e->bind('<1>' => sub { 
+		my ($state) = $w->cget( "-state" );
+		if ($state eq 'readonly')
+		{
+			&LbFindSelection($w);
+			$w->BtnDown;
+	     		$w->{'savefocus'} = $w->focusCurrent;
+ 	    		$w->Subwidget("slistbox")->focus;
+ 	    		Tk->break;
+		}
+		else
+		{
+			$e->focus;
+ 	    		Tk->break;
+		}
+	});
+
+	# ALLOW CLICK OUTSIDE THE POPPED UP LISTBOX TO POP IT DOWN.
+
+	$w->bind("<1>", sub {$w->BtnDown; Tk->break});
+	$w->parent->bind("<1>", sub
+	{
+		if ($w->{"popped"})
+		{
+			$w->Popdown(1);
+		}
+	}
+	);
+	$w->bind("<FocusIn>", \&focus);
+	$w->bind('<Alt-f>', sub {print "-focus=".$w->focusCurrent()."=\n";});
+	$w->bind('<ButtonRelease-2>', sub {print "-focus=".$w->focusCurrent()."=\n";});
+}
+
+sub keyFn   #JWT: TRAP LETTERS PRESSED AND ADJUST SELECTION ACCORDINGLY.
+{
+#print "-keyfn: parms=".join('|',@_)."=\n";
+	my ($x,$w,$e,$l,$flag) = @_;
+#print "-keyfn($x,$w,$e,$l,$flag)\n";
+	my $mykey = $x->XEvent->A;
+#print "-keyFn: pressed=$mykey=\n";
+	if ($w->cget( "-state" ) eq "readonly")  #ADDED 20020711 TO ALLOW TYPING 1ST LETTER TO SELECT NEXT VALID ITEM!
+	{
+		&LbFindSelection($w,$mykey)  if ($mykey);  #JUMP TO 1ST ITEM STARTING WITH THIS KEY
+		$w->LbCopySelection(1);
+#		unless ($w->{"popped"})   #THIS WILL CAUSE LISTBOX TO BE DISPLAYED AS WELL.
+#		{
+#			$w->BtnDown;
+#		}
+#		$w->{'savefocus'} = $w->focusCurrent;
+#		$w->Subwidget("slistbox")->focus;
+
+		$w->Subwidget("entry")->selectionRange(0,'end')  unless ($w->{"popped"});;
+	}
+	elsif ($flag == 1)      #LISTBOX HAS FOCUS.
+	{
+		&LbFindSelection($w,$mykey)  if ($mykey);  #JUMP TO 1ST ITEM STARTING WITH THIS KEY
+	}
+	else  #TEXT FIELD HAS FOCUS.
+	{
+		&LbFindSelection($w)  if ($mykey);  #JUMP TO 1ST ITEM MATCHING TEXT FIELD.
+	}
+
+}
+
+sub BtnDown
+{
+	my ($w) = @_;
+	my ($state) = $w->cget( "-state" );
+
+	return if ($state eq 'textonly' || $state eq 'disabled');
+
+	#JWT:   NEXT 2 LINES PREVENT POPPING EMPTY LIST!
+
+	my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+	return  unless ($l->get('0','end'));
+
+	if ($w->{"popped"})
+	{
+		$w->Popdown(1);
+		$w->{"buttonHack"} = 0;
+	}
+	else
+	{
+		$w->PopupChoices;
+		$w->{"buttonHack"} = 1;
+	}
+}
+
+sub PopupChoices
+{
+	my ($w) = @_;
+
+	my $first;
+
+	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 $wheight = $w->cget("-height");
+		my (@hh);
+		$hh[0]=$w->height;
+		$hh[1]=$w->reqheight;
+		$hh[2]=$e->height;
+		$hh[3]=$e->reqheight;
+		$hh[4]=$c->height;
+		$hh[5]=$c->reqheight;
+		$hh[6]=$s->height;
+		$hh[7]=$s->reqheight;
+
+		my $sll = $s->Subwidget("listbox");
+		my $rw = $c->width; 
+		$first = 1  if ($rw <= 1);
+		my ($itemcnt) = $sll->index('end');
+		$wheight = 10  unless ($wheight);
+		$wheight = $itemcnt  if ($itemcnt < $wheight);
+		$wheight = $itemcnt  unless ($wheight);
+		$wheight = $itemcnt  unless ($wheight || $itemcnt > 10);
+		if ($wheight)
+		{
+			$sll->configure(-height => ($wheight * $w->height));
+			$w->update;
+		}
+
+		my $y1 = $e->rooty + $e->height + 3;
+		my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
+		my ($unitpixels, $ht, $x1, $ee, $width, $x2);
+		if ($^O =~ /Win/i)
+		{
+			#$y1 -= 3;
+#print "-bw=$w->{-borderwidth}= y1 was=$y1=\n";
+			$y1 -= 3 - ($w->{-borderwidth} || 2);
+#print "-bw=$w->{-borderwidth}= y1 now=$y1=\n";
+			#$unitpixels = $e->height - ((2 * $bd) + 1) + 6;
+			$unitpixels = $e->height + 1;
+			#$ht = ($wheight * $unitpixels) + 10;
+			$ht = ($wheight * $unitpixels) + (2 * $bd) + 4;
+#print "-???- eheight=$e->height= BD=$bd= up=$unitpixels= wh=$wheight= HT=$ht=\n";
+			#$ee = $w->Subwidget("textpart");
+			$ee = $w->Subwidget("frame");
+			$x1 = $ee->rootx;
+			$x2 = $a->rootx + $a->width;
+			$width = $x2 - $x1;
+			$rw = $width + $w->{-borderwidth};
+			$x1 += 1;  #FUDGE MORE FOR WINDOWS (THINNER BORDER) TO MAKE DROPDOWN LINE UP VERTICALLY W/ENTRY&BUTTON.
+		}
+		else
+		{
+			$y1 -= 3 - ($w->{-borderwidth} || 2);
+			#$unitpixels = $e->height - ((2 * $bd) + 1) + 4;
+			$unitpixels = $e->height - 1;
+			#$ht = ($wheight * $unitpixels) + 10;
+			$ht = ($wheight * $unitpixels) + (2 * $bd) + 4;
+			#$x1 = $e->rootx;
+			#$ee = $w->Subwidget("textpart");
+			$ee = $w->Subwidget("frame");
+			$x1 = $ee->rootx;
+			$x2 = $a->rootx + $a->width;
+			$width = $x2 - $x1;
+			if ($rw < $width)
+			{
+				$rw = $width;
+			}
+			else
+			{
+				$rw = $width * 3  if ($rw > $width * 3);
+				$rw = $w->vrootwidth  if ($rw > $w->vrootwidth);
+			}
+			$width = $rw;
+			if ($first)
+			{
+				#$rw += 4;
+				$rw += 1 + int($w->{-borderwidth} / 2);
+				$first = 0;
+			}
+
+			# IF LISTBOX IS TOO FAR RIGHT, PULL IT BACK TO THE LEFT
+
+			if ($x2 > $w->vrootwidth)
+			{
+				$x1 = $w->vrootwidth - $width;
+			}
+			$x1 += 1;  #FUDGE MORE FOR WINDOWS (THINNER BORDER) TO MAKE DROPDOWN LINE UP VERTICALLY W/ENTRY&BUTTON.
+		}
+
+		# 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->focus;
+		$w->{"popped"} = 1;
+
+		&LbFindSelection; 
+		$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");
+	$l->configure(-selectmode => 'browse');
+	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;
+	}
+}
+
+# CLOSE THE LISTBOX AFTER CLEARING SELECTION.
+
+sub LbClose
+{
+	my ($w) = @_;
+	my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+	$l->configure(-selectmode => 'browse');
+	$l->selection("clear", 0, "end");
+	$w->Popdown;
+}
+
+# COPY THE SELECTION TO THE ENTRY, AND CLOSE LISTBOX (UNLESS JUSTCOPY SET).
+
+sub LbCopySelection
+{
+	my ($w, $justcopy) = @_;
+	my $index = $w->LbIndex;
+	if (defined $index)
+	{
+		$w->{"curIndex"} = $index;
+		my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+		$l->configure(-selectmode => 'browse');
+		my $var_ref = $w->cget( "-textvariable" );
+		$$var_ref = $l->get($index);
+	}
+	$w->Popdown  if ($w->{"popped"} && !$justcopy);
+	$w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get);
+}
+
+# GRAB TEXT TYPED IN AND FIND NEAREST ENTRY IN LISTBOX AND SELECT IT.
+# LETTERSEARCH SET MEANS SEARCH FOR *NEXT* MATCH OF SPECIFIED LETTER,
+# CLEARED MEANS SEARCH FOR *1ST* ITEM STARTING WITH CURRENT TEXT ENTRY VALUE.
+
+sub LbFindSelection
+{
+	my ($w, $srchval) = @_;
+
+	my $lettersearch = 0;
+	if ($srchval)
+	{
+		$lettersearch = 1;
+	}
+	else
+	{
+		my $var_ref = $w->cget( "-textvariable" );
+		$srchval = $$var_ref;
+	}
+	my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
+	$l->configure(-selectmode => 'browse');
+	my (@listsels) = $l->get('0','end');
+	unless ($lettersearch)
+	{
+		foreach my $i (0..$#listsels)   #SEARCH FOR TRUE EQUALITY.
+		{
+			if ($listsels[$i] eq $srchval)
+			{
+				$l->selectionClear('0','end');
+				$l->activate($i);
+				$l->selectionSet($i);
+				$l->update();
+				$l->see($i);
+				return 1;
+			}
+		}
+	}
+	my $index = $w->LbIndex;   #ADDED 20020711 TO ALLOW WRAPPING IF SAME LETTER PRESSED AGAIN!
+
+	foreach my $i (0..$#listsels)   #SEARCH W/O REGARD TO CASE, START W/CURRENT SELECTION.
+	{
+		++$index;
+		$index = 0  if ($index > $#listsels);
+		if ($listsels[$index] =~ /^$srchval/i)
+		{
+			$l->selectionClear('0','end');
+			$l->activate($index);
+			$l->selectionSet($index);
+			$l->update();
+			$l->see($index);
+			return -1;
+		}
+	}
+	return 0;
+}
+
+sub LbIndex
+{
+	my ($w, $flag) = @_;
+	my $sel = $w->Subwidget("slistbox")->Subwidget("listbox")->curselection 
+	|| $w->Subwidget("slistbox")->Subwidget("listbox")->index('active');
+
+	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, $flag) = @_;
+	my ($state) = $w->cget( "-state" );
+
+	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;
+		$w->Subwidget("entry")->focus  unless ($flag);
+		$w->Subwidget("entry")->selectionRange(0,'end');
+	}
+}
+
+# THIS HACK IS TO PREVENT THE UGLINESS OF THE ARROW BEING DEPRESSED.
+
+sub ButtonHack
+{
+	my ($w) = @_;
+	my $b = $w->Subwidget("arrow");
+
+#JWT: NEXT 6 LINES ADDED TO UNPOP MENU IF BUTTON PRESSED OUTSIDE OF LISTBOX.
+
+	my $s = $w->Subwidget("slistbox");
+	my $e = $s->XEvent;
+	unless (defined($e))
+	{
+		$w->LbClose;
+	}
+
+	if ($w->{"buttonHack"})
+	{
+		$b->butUp;
+	}
+}
+
+sub choices
+{
+	my $w = shift;
+	unless( @_ )   #NO ARGS, RETURN CURRENT CHOICES.
+	{
+		return( $w->get( qw/0 end/ ) );
+	}
+	else           #POPULATE DROPDOWN LIST WITH THESE CHOICES.
+	{
+		my $choices = shift;
+		if( $choices )
+		{
+			$w->delete( qw/0 end/ );
+			$w->Subwidget("slistbox")->insert( "end", @$choices );
+		}
+
+		#NO WIDTH SPECIFIED, CALCULATE TEXT & LIST WIDTH BASED ON LONGEST CHOICE.
+
+		unless ($w->{-listwidth})
+		{
+			my @l = $w->Subwidget("slistbox")->get(0, 'end');
+			my $width = 0;
+			for (my $i=0;$i<=$#l;$i++)
+			{
+				$width = length($l[$i])  if ($width < length($l[$i]));
+			}
+			$w->Subwidget("entry")->configure(-width => $width);
+		}
+		return( "" );
+	}
+}
+
+# INSERT NEW ITEMS INTO DROPDOWN LIST.
+
+sub insert
+{
+	my $w = shift;
+	my $pos = shift || 'end';    #POSITION IN LIST TO INSERT.
+	my $item = shift;            #POINTER TO OR LIST OF ITEMS TO INSERT.
+	if (ref($item))
+	{
+		$w->Subwidget("slistbox")->insert($pos, @$item);
+	}
+	else
+	{
+		$w->Subwidget("slistbox")->insert($pos, ($item, @_));
+	}
+
+	#NO WIDTH SPECIFIED, (RE)CALCULATE TEXT & LIST WIDTH BASED ON LONGEST CHOICE.
+
+	unless ($w->{-listwidth})
+	{
+		my @l = $w->Subwidget("slistbox")->insert(0, 'end');
+		my $width = 0;
+		for (my $i=0;$i<=$#l;$i++)
+		{
+			$width = length($l[$i])  if ($width < length($l[$i]));
+		}
+		$w->Subwidget("entry")->configure(-width => $width);
+	}
+}
+
+sub curselection  #RETURN CURRENT LISTBOX SELECTION.
+{
+	return shift->Subwidget("slistbox")->curselection;
+}
+
+# CHANGE APPEARANCES BASED ON CHANGES IN "-STATE" OPTION.
+
+sub _set_edit_state
+{
+	my( $w, $state ) = @_;
+	my $entry  = $w->Subwidget( "entry" );
+	my $frame  = $w->Subwidget( "frame" );
+	my $button = $w->Subwidget( "arrow" );
+	my ($color, $txtcolor, $framehlcolor, $texthlcolor);  # MAKE ENTRY FIELDS LOOK WINDOSEY!
+
+	unless ($w->{-background})
+	{
+		if ($^O =~ /Win/i)   # SET BACKGROUND TO WINDOWS DEFAULTS (IF NOT SPECIFIED)
+		{
+			#if ($state eq 'disabled' || $state eq 'readonly')
+			if ($state eq 'disabled')
+			{
+				$color = "SystemButtonFace";
+			}
+			else
+			{# Not Editable
+				$color = $w->cget( -background );
+				$color = 'SystemWindow'  if ($color eq 'SystemButtonFace');
+			}
+			$entry->configure( -background => $color );
+		}
+		else
+		{
+			if ($w->cget( "-colorstate" ))
+			{
+				if( $state eq "normal" )
+				{# Editable
+					$color = "gray95";
+				}
+				else
+				{# Not Editable
+					$color = $w->cget( -background ) || "lightgray";
+				}
+				$entry->configure( -background => $color );
+			}
+		}
+	}
+
+	$txtcolor = $w->{-foreground} || $w->cget( -foreground )  unless ($state eq "disabled");
+
+	$texthlcolor = $w->{-background} || $entry->cget( -background );
+	$framehlcolor = $w->{-foreground} || $entry->cget( -foreground );
+	if( $state eq "readonly" )
+	{
+		$framehlcolor = $w->{-foreground} || $entry->cget( -foreground );
+		$entry->configure( -state => "disabled", -takefocus => 0, 
+				-foreground => $txtcolor, -highlightcolor => $texthlcolor);
+		if ($^O =~ /Win/i)
+		{
+			$button->configure( -state => "normal", -takefocus => 0, -relief => 'raised');
+			$frame->configure(-relief => ($w->{-relief} || 'groove'), 
+					-takefocus => 1, -highlightcolor => $framehlcolor);
+		}
+		else
+		{
+			$button->configure( -state => "normal", -takefocus => 0, -relief => 'flat');
+			$frame->configure(-relief => ($w->{-relief} || 'raised'), 
+					-takefocus => 1, -highlightcolor => $framehlcolor);
+		}
+	}
+	elsif ($state eq "textonly" )
+	{
+		$framehlcolor = $w->{-background} || 'SystemButtonFace'
+				if ($^O =~ /Win/i);
+		$button->configure( -state => "disabled", -takefocus => 0, 
+				-relief => 'raised');
+		$frame->configure(-relief => ($w->{-relief} || 'sunken'), 
+				-takefocus => 0, -highlightcolor => $framehlcolor);
+		$entry->configure( -state => 'normal', 
+				-takefocus => (1 & ($w->{takefocus} || $w->{btntakesfocus})), 
+				-foreground => $txtcolor, -highlightcolor => $texthlcolor);
+	}
+	elsif ($state eq "disabled" )
+	{
+		$entry->configure( -state => "disabled", -takefocus => 0, 
+				-foreground => 'gray50', -highlightcolor => $texthlcolor);
+		if ($^O =~ /Win/i)
+		{
+			$framehlcolor = $w->{-background} || 'SystemButtonFace';
+			$button->configure(-state => "disabled",  -takefocus => 0, 
+					-relief => 'flat');
+			$frame->configure(-relief => ($w->{-relief} || 'sunken'), 
+					-takefocus => 0, -highlightcolor => $framehlcolor);
+		}
+		else
+		{
+			$frame->configure(-relief => ($w->{-relief} || 'groove'), 
+					-takefocus => 0, -highlightcolor => $framehlcolor);
+		}
+		$button->configure(-state => "disabled",  -takefocus => 0, 
+				-relief => 'raised');
+	}
+	else   #NORMAL.
+	{
+		$framehlcolor = $w->{-background} || 'SystemButtonFace'
+				if ($^O =~ /Win/i);
+		#$entry->configure( -state => $state, -takefocus => (1 & $w->{takefocus}), 
+		$entry->configure( -state => $state, -takefocus => 0, 
+				-foreground => $txtcolor, -highlightcolor => $texthlcolor);
+		$button->configure( -state => $state, -relief => 'raised', 
+				-takefocus => $w->{btntakesfocus});
+		$frame->configure(-relief => ($w->{-relief} || 'sunken'), 
+				-takefocus => (1 & $w->{takefocus}), 
+				-highlightcolor => $framehlcolor);
+	}       
+}
+
+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 );
+}
+
+sub setstate
+{
+	my ($w) = shift;
+	my ($state) = shift;
+
+	$w->configure(-state => $state);
+	if ($state eq 'textonly')
+	{
+		$w->Button->configure(-state => 'disabled');
+	}
+	else
+	{
+		$w->Button->configure(-state => $state);
+	}
+}
+
+1;
+
+__END__
diff --git a/plugins/Tk-GUI/edit_test.pl b/plugins/Tk-GUI/edit_test.pl
new file mode 100644
index 0000000..3d81ba9
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-GUI/test.pl b/plugins/Tk-GUI/test.pl
new file mode 100644
index 0000000..9fc8331
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-Logon/Milkbone/Logon.pm b/plugins/Tk-Logon/Milkbone/Logon.pm
new file mode 100644
index 0000000..3b33e04
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-Logon/Tk-Logon.pl b/plugins/Tk-Logon/Tk-Logon.pl
new file mode 100644
index 0000000..35109e5
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-PluginsConf/Milkbone/PluginLoad.pm b/plugins/Tk-PluginsConf/Milkbone/PluginLoad.pm
new file mode 100644
index 0000000..6f05b89
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-PluginsConf/Milkbone/PluginsConf.pm b/plugins/Tk-PluginsConf/Milkbone/PluginsConf.pm
new file mode 100644
index 0000000..86cf431
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-PluginsConf/Tk-PluginsConf.pl b/plugins/Tk-PluginsConf/Tk-PluginsConf.pl
new file mode 100644
index 0000000..ee2e1a6
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/Tk-Profile/Milkbone/Profile.pm b/plugins/Tk-Profile/Milkbone/Profile.pm
new file mode 100644
index 0000000..f1bb70c
--- /dev/null
+++ b/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);
+}
diff --git a/plugins/Tk-Profile/Tk-Profile.pl b/plugins/Tk-Profile/Tk-Profile.pl
new file mode 100644
index 0000000..c1e939c
--- /dev/null
+++ b/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;
diff --git a/plugins/Tk-Splash.pl b/plugins/Tk-Splash.pl
new file mode 100644
index 0000000..5097993
--- /dev/null
+++ b/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;
diff --git a/plugins/Win32-Tray.pl b/plugins/Win32-Tray.pl
new file mode 100644
index 0000000..5483c42
--- /dev/null
+++ b/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;
diff --git a/plugins/Win32X.pl b/plugins/Win32X.pl
new file mode 100644
index 0000000..299f68e
--- /dev/null
+++ b/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;
\ No newline at end of file
diff --git a/plugins/XAMP.pl b/plugins/XAMP.pl
new file mode 100644
index 0000000..0933e7d
--- /dev/null
+++ b/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;
+	});
+	
+});
+
+
+
+
+
+	    
diff --git a/plugins/stats.pl b/plugins/stats.pl
new file mode 100644
index 0000000..f6da3b7
--- /dev/null
+++ b/plugins/stats.pl
@@ -0,0 +1,6 @@
+package Stats;
+
+open(STATS, user_file('stats.txt');
+
+
+1;
\ No newline at end of file
diff --git a/sounds/buddy_out.wav b/sounds/buddy_out.wav
new file mode 100644
index 0000000..d083f87
Binary files /dev/null and b/sounds/buddy_out.wav differ
diff --git a/sounds/error.wav b/sounds/error.wav
new file mode 100644
index 0000000..fd4df5a
Binary files /dev/null and b/sounds/error.wav differ
diff --git a/sounds/go_away.wav b/sounds/go_away.wav
new file mode 100644
index 0000000..c1410bd
Binary files /dev/null and b/sounds/go_away.wav differ
diff --git a/sounds/msg_in.wav b/sounds/msg_in.wav
new file mode 100644
index 0000000..cc96169
Binary files /dev/null and b/sounds/msg_in.wav differ
diff --git a/sounds/signed_in.wav b/sounds/signed_in.wav
new file mode 100644
index 0000000..fd66289
Binary files /dev/null and b/sounds/signed_in.wav differ