runmodes work

lib/Milkbone.pm

@@ -15,7 +15,8 @@ require Exporter;
 
 # include the rest of the core
 use Milkbone::HookEntry;
-use Milkbone::Util qw(path slurp win32 nix nt loaded_files user_path strip_html);
+use Milkbone::Util qw(path slurp win32 nix nt loaded_files user_path 
+		      strip_html user_file);
 use Milkbone::Plugin;
 
 # equal to the version of the current milkbone release
@@ -313,12 +314,16 @@ sub deregister_hook
 }
 
 register_hook "mainloop", sub {
-	my $i = 0;
+    my $i = 0;
-	while(is_running)
+    while(is_running) {
-	{
+	
-		hook("tick");
+	eval {
-		# select(undef, undef, undef, $interval) if $i++ % 5 == 0 && $interval;
+	    hook("tick");
-	}
+	};
+	
+	error($@) if $@;
+	# select(undef, undef, undef, $interval) if $i++ % 5 == 0 && $interval;
+    }
 };
 
 # ------------------------------------------
@@ -336,6 +341,7 @@ sub pre_mainloop
 
 sub error
 {
+    print "IN THE ERROR SUB\n\n\n\n\n";
 	unlink "errlog.txt" and warn "errlog.txt has exceeded 500K." if -e "errlog.txt" && -s "errlog.txt" > 500 * 1024;
 	open(LOG, ">>errlog.txt") or die "Can't open error file: $!";
 	print LOG $ARGS{-short} . "\n" if $ARGS{-short};

lib/Milkbone/Util.pm

@@ -12,24 +12,24 @@ use Carp;
 
 our @ISA = qw(Exporter);
 our @EXPORT = qw();
-our @EXPORT_OK = qw(slurp win32 nix nt loaded_files user_path strip_html path);
+our @EXPORT_OK = qw(slurp win32 nix nt loaded_files user_path strip_html path
+		   user_file);
 
 # read a file in one big slurp
-sub slurp
+sub slurp {
-{
+    my ($file, $no_chomp) = @_;
-  my ($file, $no_chomp) = @_;
+    open(my $handle, $file) or die "Failed loading $file";
-  open(my $handle, $file) or die "Failed loading $file";
+    my @all = <$handle>;
-  my @all = <$handle>;
+    close($handle);
-  close($handle);
+
-
+    chomp @all unless $no_chomp;
-  chomp @all unless $no_chomp;
+
-
+    if(wantarray) {
-  if(wantarray) {
+	return @all;
-    return @all;
+    }
-  }
+    else {
-  else {
+	return join('', @all);
-    return join('', @all);
+    }
-  }
 }
 
 # general heuristic for removing html from a string
@@ -78,9 +78,9 @@ sub user_file
 	    (exists($ENV{APPDATA}) ? "$ENV{APPDATA}/milkbone" : "profiles"));
 
 	mkdir $dir unless -e $dir && -d $dir;
-	mkdir path("$dir/$user") unless -e path("$dir/$user") && -d path("$dir/$user");
+	mkdir "$dir/$user" unless -e path("$dir/$user") && -d path("$dir/$user");
 
-	return path("$dir/$user/$file");
+	return "$dir/$user/$file";
 }
 
 # Stolen from Devel::ptkdb - thanks!

milkbone

@@ -1,49 +1,12 @@
 #!/usr/bin/perl
 # -----------------------------------------------------------------------------
 # milkbone
-# Desc: This file is the heart of milkbone.  It brings up the core and calls
+# Desc: Loads up milkbone.pl
-# the appropriate guidance script.  There's nothing too complicated happening
-# here; most of it ought to be self-explanatory.
-# Quote: "A beginning is the time for taking the most delicate care
-# that the balances are correct."
-# 	- Dune
 # -----------------------------------------------------------------------------
 
-use strict;
+eval {
-use warnings;
+    require "milkbone.pl";
-
+};
-# Load the core.  This prepares @INC for guidance script detection, and
-# sets default values (e.g. $Milkbone::FatalLog).
-
-use lib 'lib';
-use Milkbone qw(slurp);
-
-# Launch the correct guidance script based on the command-line parameters.
-# Note that linking this script to milkbone-x and then invoking that link
-# is equivalent to running "milkbone x". If no arguments are supplied,
-# "tk" is used as the default guidance script.
-
-my $target;
-if($0 =~ /milkbone-(.*)/) {
-  $target = $1;
-  shift @ARGV;
-}
-elsif(defined($ARGV[0]) and $ARGV[0] !~ /-/) {
-  $target = $ARGV[0];
-  shift @ARGV;
-}
-else {
-  $target = "tk";
-}
-
-# We know the target name now - let's run it.  This eval block is the last
-# defense against exceptions.  If something doesn't get caught here, then
-# something must have gone terribly wrong.  Note that the guidance script
-# doesn't return until the user has closed milkbone.
-
-my $script = slurp("guid/" . $target . ".pl", 1);
-
-eval $script;
 
 # Really serious exceptions will get logged into the file pointed to by
 # $Milkbone::FatalLog.

milkbone.pl

@@ -27,15 +27,15 @@ use Milkbone qw(slurp);
 
 my $target;
 if($0 =~ /milkbone-(.*)/) {
-  $target = $1;
+    $target = $1;
-  shift @ARGV;
+    shift @ARGV;
 }
 elsif(defined($ARGV[0]) and $ARGV[0] !~ /-/) {
-  $target = $ARGV[0];
+    $target = $ARGV[0];
-  shift @ARGV;
+    shift @ARGV;
 }
 else {
-  $target = "tk";
+    $target = "tk";
 }
 
 # We know the target name now - let's run it.  This eval block is the last
@@ -43,7 +43,7 @@ else {
 # something must have gone terribly wrong.  Note that the guidance script
 # doesn't return until the user has closed milkbone.
 
-my $script = slurp("guid/" . $target . ".pl", 1);
+my $script = slurp("modes/" . $target . ".pl", 1);
 
 eval $script;
 
@@ -51,8 +51,10 @@ eval $script;
 # $Milkbone::FatalLog.
 
 if($@) {
-  print $@;
+    print $@;
-  open(my $log, ">" . $Milkbone::FatalLog);
+    open(my $log, ">" . $Milkbone::FatalLog);
-  print $log "\n" . $@;
+    print $log "\n" . $@;
-  close($log);
+    close($log);
 }
+
+1;

modes/demotk.pl

@@ -1,6 +1,6 @@
 # -----------------------------------------------------------------------------
 # tktest.pl
-# Desc: Testing guidance script; loads and intializes the Tk interface
+# Desc: Testing runmode; loads and intializes the Tk interface
 # -----------------------------------------------------------------------------
 
 use Milkbone qw(load_plugin);
@@ -22,10 +22,64 @@ load_plugin "Tk-Logon";
 load_plugin "Tk-PluginsConf";
 load_plugin "Tk-Profile";
 
-load_plugin "Net-Demo";
-
 # begin unit testing code
 
+register_hook "protocol_signon", sub {
+    hook("after", -time => 10, -code => sub { hook("signed_in") });
+	
+    register_hook "protocol_add_buddy", sub { hook("buddy_in", 
+						   -buddy => $ARGS{-buddy},
+						   -group => $ARGS{-group}); };
+
+    register_hook "protocol_get_groups", sub { return ["Buddies", "You"] };
+    register_hook "protocol_get_realname", sub { return lc $ARGS{-user} };
+    register_hook "protocol_request_info", sub {
+	hook("after", -time => 1000, -code => sub {
+		 hook("protocol_info_received_$ARGS{-user}",
+		      -profile => 'test', -away => 'test');
+	     });
+    };
+
+    register_hook "protocol_send_im", sub {
+	hook("after", -time => 500, -code => [sub {
+				hook("msg_sent_$_[0]",
+				     -user => $_[0],
+				     -msg => $_[1],
+				     -away => 0);
+				hook("after", -time => 500, sub {
+					 hook("msg_in", -user => $_[0], 
+					      -msg => $_[1], -away => 0);
+					 hook("msg_in_$_[0]", -user => $_[0], 
+					      -msg => $_[1], -away => 0);
+				     });
+			    }, $ARGS{-dest}, $ARGS{-msg}]);
+    };
+    register_hook "protocol_away_status", sub { 0 };
+		
+    hook("after", -time => 1000, -code => sub {
+	     hook("buddy_in", -group => 'Buddies', -buddy => 'test_user');
+	 });
+
+    # 	hook("after", -time => 1000, -code => sub {
+    # 		hook("msg_in", -user => 'thatguy', -msg => '<b>hey</b>');
+    # 	});
+
+    # 	hook("after", -time => 1500, -code => sub {
+    # 		hook("protocol_send_im", -dest => 'thatguy', 
+    #           -msg => '<b>hey there</b>');
+
+    hook("after", -time => 500, -code => sub {
+	     register_hook "protocol_chat_accept", sub {
+                 hook("protocol_chat_joined", -name => 'erer', -user => 'er',
+                      -url => 'ere');
+                 hook("protocol_chat_buddy_in_ere", -user => 'charles');
+	     };
+
+	     hook("protocol_chat_invited", -user => 'thatguy', 
+		  -url => 'er');
+	 });
+};
+
 protocol_signon -user => 'test', -pass => 'test';
 data("me") = "lala";
 
@@ -35,4 +89,4 @@ pre_mainloop;
 mainloop;
 post_mainloop;
 
-1;
+return 1;

modes/tk.pl

@@ -1,6 +1,6 @@
 # -----------------------------------------------------------------------------
 # tk.pl
-# Desc: Default guidance script; loads and intializes the Tk interface
+# Desc: Default runmode; loads and intializes the Tk interface
 # -----------------------------------------------------------------------------
 
 use strict;

plugins/Net-OSCAR/Net-OSCAR.pl

@@ -67,7 +67,6 @@ 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(

plugins/Tk-BList/Milkbone/BList.pm

@@ -237,7 +237,7 @@ sub init
 {
 	my ($self, $mw) = @_;
 	
-	$logo = $self->Photo(-file => path("images/logo.bmp"));
+	$logo = $self->Photo(-file => "images/logo.bmp");
 	$self->configure(-title => "$ARGS{-me}\ - milkbone");
 
 	my ($x, $y);
@@ -306,9 +306,9 @@ sub init
 	$self->{away}->pack(-side => 'bottom');
 
 	hook("tk_seticon", -wnd => $self);
-	$away = $self->Photo(-file => path("images/away.bmp"));
+	$away = $self->Photo(-file => "images/away.bmp");
-	$blank = $self->Photo(-file => path("images/blank.gif"));
+	$blank = $self->Photo(-file => "images/blank.gif");
-	$cell = $self->Photo(-file => path("images/cell.gif"));
+	$cell = $self->Photo(-file => "images/cell.gif");
 	$self->OnDestroy([\&on_destroy, $self]);
 	$self->{switching} = 0;
 

plugins/Tk-Logon/Milkbone/Logon.pm

@@ -13,7 +13,7 @@ Construct Tk::Widget 'MBLogon';
 
 my $mw = hook("tk_getmain");
 
-my $slogan = "earth!  wind!  water!  fire!  spirit!  MILKBONE!";
+my $slogan = "i am jack's core rewrite";
 
 sub ClassInit
 {
@@ -97,7 +97,7 @@ sub init
 	$self->configure(-title => "milkbone logon $Milkbone::VERSION");
 	
 	# WIDGET CREATION BEGIN
-	my $image = $self->Photo(-file => path("images/logon.bmp"));
+	my $image = $self->Photo(-file => "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