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 => 'hey'); + # }); + + # hook("after", -time => 1500, -code => sub { + # hook("protocol_send_im", -dest => 'thatguy', + # -msg => 'hey there'); + + 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