milkbone/Milkbone.pm

# ----------------------------------------------------------------------
# Author(s)	:	Bill Atkins
# Title		:	MOS core
# Date		:	12.21.02
# Desc		:	the hamster that keep MOS going
# License	:	under the same terms as mos.pl
# ----------------------------------------------------------------------

package Milkbone;

use strict;
use warnings;

use Carp qw(longmess);
use Milkbone::HookEntry;
use Benchmark;

our $VERSION = "0.355";

require Exporter;

our @ISA = qw( Exporter );
our @EXPORT = qw( hook is_running abort queued_hook register_hook option path data %ARGS slurp
	deregister_hook strip_html user_file set_option MOSLoop set_interval unload_plugin load_plugin init_plugin reload_core);
our @EXPORT_OK = qw( );

my ($running, $dirty);
my $interval = 0.006;
our (%hooks, %options, %data, %plugins);
our (%ARGS) = ();

$running = 1;

$| = 1;

sub is_running
{
	$running;
}

sub set_interval
{
	$interval = shift;
}

sub abort
{
	$running = 0;
	die @_;
}

sub init
{
	# initialization
	register_hook("load_options", \&load_options);
	register_hook("load_plugins", \&load_plugins);
	register_hook("post_mainloop", \&post_mainloop);
	register_hook("pre_mainloop", \&pre_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);

	open(GLOBAL, "<mb.conf") 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;
}

sub load_plugin
{
	my ($plugin) = @_;

	return unless $plugin;

	if(-e path("plugins/$plugin.pl"))
	{
	}
        # PAR support - disabled in non-Mercury releases
	#elsif(-e path("plugins/$plugin.zip"))
	#{
	#	PAR->import(path("plugins/$plugin.zip"));
	#}
	elsif(-e path("plugins/$plugin") and -d path("plugins/$plugin"))
	{
		unshift @INC, path("plugins/$plugin");
	}
	else
	{
		die "Couldn't load plugin $plugin";
		return;
	}

        $plugins{$plugin} = 1;
}

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 init_plugin
{
	my ($plugin) = @_;
	eval "require \"$plugin.pl\";" or hook("error", -short => "Couldn't require $plugin.pl for $plugin: $! $@");
}

sub load_plugins
{
	
	my @plugins = grep({ $_ } (option("Modules"), option("Plugins")));
	push @INC, "./plugins";
	load_plugin($_) for @plugins;
	init_plugin($_) for(@plugins);
}

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; 
        print "$hook registered by $file\n";
}

sub deregister_hook
{
	my ($hook) = @_;
	my ($file, $package, $line) = caller;
	my @temp = @{$hooks{$hook}};

        print "$hook deregistered by $file\n";

	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) && ($_->{hook_name} ne $hook) } @{$hooks{$hook}};

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

sub MOSLoop
{
	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 -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");

        my $dir = (nix()  ? "$ENV{HOME}/.milkbone" : 
            (nt() ? "$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 => longmess(join(' ', @_)), -fatal => 1);
	print longmess(@_);
	abort;
};

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

1;