From 3c60f37db68bbe7599ffbae04acea0c370eb0e9e Mon Sep 17 00:00:00 2001
From: milkbone57 <milkbone57>
Date: Thu, 16 Oct 2003 19:16:34 +0000
Subject: [PATCH] runmodes work
---
lib/Milkbone.pm | 20 ++++++----
lib/Milkbone/Util.pm | 36 ++++++++---------
milkbone | 45 ++--------------------
milkbone.pl | 22 ++++++-----
modes/demotk.pl | 62 ++++++++++++++++++++++++++++--
modes/tk.pl | 2 +-
plugins/Net-OSCAR/Net-OSCAR.pl | 1 -
plugins/Tk-BList/Milkbone/BList.pm | 8 ++--
plugins/Tk-Logon/Milkbone/Logon.pm | 4 +-
9 files changed, 112 insertions(+), 88 deletions(-)
diff --git a/lib/Milkbone.pm b/lib/Milkbone.pm
index 9ebce38..e8f1047 100644
--- a/lib/Milkbone.pm
+++ b/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;
- while(is_running)
- {
- hook("tick");
- # select(undef, undef, undef, $interval) if $i++ % 5 == 0 && $interval;
- }
+ my $i = 0;
+ while(is_running) {
+
+ eval {
+ 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};
diff --git a/lib/Milkbone/Util.pm b/lib/Milkbone/Util.pm
index f11c15d..48a4fa5 100644
--- a/lib/Milkbone/Util.pm
+++ b/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
-{
- my ($file, $no_chomp) = @_;
- open(my $handle, $file) or die "Failed loading $file";
- my @all = <$handle>;
- close($handle);
-
- chomp @all unless $no_chomp;
-
- if(wantarray) {
- return @all;
- }
- else {
- return join('', @all);
- }
+sub slurp {
+ my ($file, $no_chomp) = @_;
+ open(my $handle, $file) or die "Failed loading $file";
+ my @all = <$handle>;
+ close($handle);
+
+ chomp @all unless $no_chomp;
+
+ if(wantarray) {
+ return @all;
+ }
+ else {
+ 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!
diff --git a/milkbone b/milkbone
index f1a2e8d..a5a1ff0 100755
--- a/milkbone
+++ b/milkbone
@@ -1,49 +1,12 @@
#!/usr/bin/perl
# -----------------------------------------------------------------------------
# milkbone
-# Desc: This file is the heart of milkbone. It brings up the core and calls
-# 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
+# Desc: Loads up milkbone.pl
# -----------------------------------------------------------------------------
-use strict;
-use warnings;
-
-# 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;
+eval {
+ require "milkbone.pl";
+};
# Really serious exceptions will get logged into the file pointed to by
# $Milkbone::FatalLog.
diff --git a/milkbone.pl b/milkbone.pl
index 8a9f837..2bcbbbe 100755
--- a/milkbone.pl
+++ b/milkbone.pl
@@ -27,15 +27,15 @@ use Milkbone qw(slurp);
my $target;
if($0 =~ /milkbone-(.*)/) {
- $target = $1;
- shift @ARGV;
+ $target = $1;
+ shift @ARGV;
}
elsif(defined($ARGV[0]) and $ARGV[0] !~ /-/) {
- $target = $ARGV[0];
- shift @ARGV;
+ $target = $ARGV[0];
+ 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 $@;
- open(my $log, ">" . $Milkbone::FatalLog);
- print $log "\n" . $@;
- close($log);
+ print $@;
+ open(my $log, ">" . $Milkbone::FatalLog);
+ print $log "\n" . $@;
+ close($log);
}
+
+1;
diff --git a/modes/demotk.pl b/modes/demotk.pl
index 8a71d4a..06e8deb 100644
--- a/modes/demotk.pl
+++ b/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;
diff --git a/modes/tk.pl b/modes/tk.pl
index 2d1bac0..65c7a6e 100644
--- a/modes/tk.pl
+++ b/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;
diff --git a/plugins/Net-OSCAR/Net-OSCAR.pl b/plugins/Net-OSCAR/Net-OSCAR.pl
index 9841d4b..f5e1ab9 100644
--- a/plugins/Net-OSCAR/Net-OSCAR.pl
+++ b/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(
diff --git a/plugins/Tk-BList/Milkbone/BList.pm b/plugins/Tk-BList/Milkbone/BList.pm
index f5aa684..34aa80e 100644
--- a/plugins/Tk-BList/Milkbone/BList.pm
+++ b/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"));
- $blank = $self->Photo(-file => path("images/blank.gif"));
- $cell = $self->Photo(-file => path("images/cell.gif"));
+ $away = $self->Photo(-file => "images/away.bmp");
+ $blank = $self->Photo(-file => "images/blank.gif");
+ $cell = $self->Photo(-file => "images/cell.gif");
$self->OnDestroy([\&on_destroy, $self]);
$self->{switching} = 0;
diff --git a/plugins/Tk-Logon/Milkbone/Logon.pm b/plugins/Tk-Logon/Milkbone/Logon.pm
index 8aa02ac..3e7c539 100644
--- a/plugins/Tk-Logon/Milkbone/Logon.pm
+++ b/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