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;

# 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 = qw(hook is_running abort register_hook option data slurp
		 deregister_hook strip_html user_file set_option
		 unload_plugin load_plugin reload_core reload_plugin
		 nix win32 %ARGS);

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

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

$running = 1;

# autoflushing on
$| = 1;

# 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 path("plugins/$plugin.pl")) {
    # single-file plugin - no need for @INC setting
  }
  elsif(-e path("plugins/$plugin") and -d path("plugins/$plugin")) {
    # multi-file plugin - add its folder to @INC
    unshift @INC, path("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\";";
  error("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)
	{
		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 -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 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");

	$ENV{HOME} ||= '';

	my $dir = (nix()  ? "$ENV{HOME}/.milkbone" : 
	    (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");

	return path("$dir/$user/$file");
}

# Stolen from Devel::ptkdb - thanks!
sub loaded_files
{
    my @fList = sort { 
    
	# sort comparison function block
	my $fa = substr($a, 0, 1) ;
	my $fb = substr($b, 0, 1) ;

	return $a cmp $b if ($fa eq '/') && ($fb eq '/') ;
	
	return -1 if ($fb eq '/') && ($fa ne '/') ;
	return 1 if ($fa eq '/' ) && ($fb ne '/') ;

	return $a cmp $b ;

    } grep s/^_<//, keys %main::;
}

# ------------------------------------------
# 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;