milkbone/lib/Milkbone.pm

# -----------------------------------------------------------------------------
# Milkbone.pm
# Desc: Contains the code for the hook system and plugin management.  Exports
# aliases to some of the other parts of the core.
# -----------------------------------------------------------------------------

package Milkbone;

use strict;
use warnings;

# standard modules
use Carp qw(longmess);
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 user_file);
use Milkbone::Plugin;

# equal to the version of the current milkbone release
our $VERSION = "0.37";

# initialition
# XXX: FatalLog needs to go to the config
our $FatalLog = "fatals.txt";
push @INC, "./plugins";

# exports
our @ISA = qw(Exporter);
our @EXPORT = (@Milkbone::Util::EXPORT, qw(hook is_running abort register_hook 
		 option data deregister_hook strip_html user_file set_option
		 unload_plugin reload_core reload_plugin
		 nix win32 %ARGS path));
our @EXPORT_OK = (@EXPORT, @Milkbone::Util::EXPORT_OK,
		  qw(load_plugin));

# global variables
my ($running, $dirty);
my $interval = 0.006;

our (%hooks, %options, %data, %plugins);
our (%ARGS) = ();

$running = 1;

# autoflushing on
$| = 1;

# This causes @EXPORT to be exported even when using import lists
sub import {
    Milkbone->export_to_level(1, @_, @EXPORT);
}

# returns a boolean indicating whether or not the core loop is running
sub is_running {
    $running;
}


# end the core loop and begin shutdown
sub abort {
    $running = 0;
    print @_;
    exit;
}

# initialize the core
sub init {
    register_hook("load_plugins", \&load_plugins);
    register_hook("pre_mainloop", \&pre_mainloop);
    register_hook("post_mainloop", \&post_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);
      my $file = $ARGS{-file} || "mb.conf";
      
      open(GLOBAL, "<$file") 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;
}

# prepare plugin for loading by adding it to @INC
sub prep_plugin
{
  my ($plugin) = @_;

  return unless $plugin;

  if(-e "plugins/$plugin.pl") {
    # single-file plugin - no need for @INC setting
  }
  elsif(-e "plugins/$plugin" and -d "plugins/$plugin") {
    # multi-file plugin - add its folder to @INC
    unshift @INC, "plugins/$plugin";
  }
  else {
    # plugin doesn't exist
    die "Couldn't load plugin $plugin";
    return;
  }

  # mark plugin as loaded
  $plugins{$plugin} = 1;
}

# call a plugin's initialization code
sub init_plugin
{
  my ($plugin) = @_;
  eval "require \"$plugin.pl\";";
  die "Couldn't require $plugin.pl for $plugin: $@" if $@;
}

# load one or more plugins
sub load_plugin
{
  for my $plugin (@_) {
    prep_plugin($plugin);
    init_plugin($plugin);
  }
}

# unload a plugin from the core
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(loaded_files())
	{
	   if(/^plugins\/$plugin/)
	   {
	     s/plugins\///;
	     s/\/$plugin\///;
	     delete $INC{$_};
	   } 
	}
}

sub plugin_list
{
    [keys(%plugins)];
}

sub load_plugins
{
	
	my @plugins = grep({ $_ } (option("Modules"), option("Plugins")));

	load_plugin($_) for @plugins;
	init_plugin($_) for(@plugins);
}

sub reload_plugin
{
    my ($plugin) = @_;
    unload_plugin($_);
    load_plugin($_);
    init_plugin($_);
}

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';" or warn "$@";
}

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 ($package, $file, $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) } @temp;

	@{$hooks{$hook}} = @temp;

#	 delete $hooks{$hook} unless @temp;
}

register_hook "mainloop", sub {
    my $i = 0;
    while(is_running) {
	
	eval {
	    hook("tick");
	};
	
	error($@) if $@;
	# select(undef, undef, undef, $interval) if $i++ % 5 == 0 && $interval;
    }
};

# ------------------------------------------
# Default Hooks
# ------------------------------------------

sub post_mainloop
{
	hook("save_options");
}

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};
	print LOG $ARGS{-long} . "\n" if $ARGS{-long};
	close(LOG);
}

# ------------------------------------------
# Utilities
# ------------------------------------------

sub data : lvalue
{
	$data{$_[0]};
}



# ------------------------------------------
# Overrrides
# ------------------------------------------

*CORE::GLOBAL::die = sub {
	return CORE::die(@_) if $_[0] =~ /TK_BREAK/;
	hook("error", -short => join(' ', @_), -long => join(' ', @_), -fatal => 1);
	print @_;
	abort;
};

*CORE::GLOBAL::warn = sub {
	hook("error", -short => join(' ', @_), -long => join(' ', @_));
	print @_;
};

1;