<<q=~q>>;
	     script: Tabify
	     author: b0at
	       date: 21 Oct 2005
	     icense: public domain
	
	description: Show user-configurable events in their own tabs
	
	--Changes--
	001: first release

	--Instructions--
	Please use the latest version of X-Chat 2.
	
	No changes are necessary to this script unless it doesn't work.
	TRY IT FIRST.
q

### CONFIGURABLE OPTIONS ####

# None.

#############################

use strict;
use warnings;
use Storable qw( store retrieve ); # core
use Xchat qw( :all ); sub prnt { Xchat::print \@_ }

use constant CONFIG  => '_tabify.conf'; # requires wd to be xchatdir
chdir( get_info('xchatdir') );
my $CMD    = 'tabify';

register(
	my $NAME    = "Tabify",
	my $VERSION = "001",
	"Show events in the their own tabs (use /$CMD)"
);
prnt "\cB$NAME $VERSION\cB by b0at (use /$CMD)"; # announce
my $PREFIX = "\cB$NAME\cB\t";
my $USAGE  = <<USAGE;
Usage: $CMD <+|add|-|del>[q][c] <event>[, <event>[, ...]], add (+) or delete (-) text event(s) from tabify list
       $CMD <?|list>, list currently tabified events
		 For less verbose output, append 'q' to the operator. Errors will still display.
		 To copy and \cBnot\cB remove the event from the original context, append 'c' to the operator.
		 example: $CMD + Notice, Receive Wallops
					 $CMD +q Part, Join
					 $CMD +c Channel Msg Hilight
USAGE
hook_command($CMD, \&user_command, { help_text => $USAGE } );

# get event list from our own conf!
my %events;
if( open( my $pevents, '<', 
	'pevents.conf'
	) )
{ 
	%events = 
		map { chomp; s/\s*event_name\s*=\s*//; lc($_) => $_ } # parse out names
		grep{/event_name=/} <$pevents>; # event names
	close $pevents;
}
else { # can't get list, do our best
	prnt "$PREFIX Unable to open pevents.conf (tried '",get_info('xchatdir'),'/pevents.conf',"') to get event list. The script will still work, but all event names must have correct case ('tabify + Channel Message' will work, but 'tabify + channel message' will not).";
}
	
# tabified event hooks
my ($hooks, $config);
if( -e CONFIG ) { $hooks = retrieve(CONFIG) } # existing
elsif( open my $config, '>', CONFIG ) { # new
	close $config;
	store $hooks = {}, CONFIG;
	prnt "$PREFIX Successfully created new config file.";
}

if( not $hooks ) {
	prnt "$PREFIX Unable to open or create config file (tried '",get_info('xchatdir'),'/',CONFIG,"'). Changes will not persist.";
	$hooks = {};
} else { $config = 1 }

# rehook persisting events
for( keys %$hooks ) {
	my $copy = $hooks->{$_}{copy} ? 'c' : '';
	delete $hooks->{$_};
	command("$CMD +q$copy $_"); # quiet
#	command("$CMD listq");  # show change in events
}
command("$CMD listq");  # show events

# user command
sub user_command {
	my ($w, $e) = @_;
	my $events  = [split/\s*,\s*/, $e->[2]||''];
	my $action  = lc $w->[1];
	my $quiet   = ( $action and $action =~ s/q(c?)$/$1/i );
	my $copy    = ( $action and $action =~ s/c$//i );

	for( $action ) {
		# list events
		if( /^(l(|ist)|\?)$/ ) {
			if( %$hooks ) {
				prnt "$PREFIX Currently tabifying: ", join(', ', 
				map { my $c = $hooks->{$_}{copy}?" (copy)":''; $events{lc$_}.$c } 
				sort keys %$hooks);
			} elsif( not $quiet ) {
				prnt "$PREFIX Currently tabifying: no events";
			}
		}
		# add events
		elsif( /^(a(|dd?)|\+)$/ ) {
			prnt $USAGE unless @$events;
			prnt "$PREFIX There are no known events matching that pattern." unless $events = expand_events($events);

			for my $event (@$events) {
				if( not %events # account for missing pevents
					or exists( $events{lc $event} ) )
				{
					$hooks->{lc$event} = {
						hook =>
							hook_print( $events{lc$event}, # get proper name to work
							\&tabify, { data => { event => $events{lc$event}||$event , 
							emitted => 0, copy => $copy } } ) # not emitted: hooked.
					,	copy => $copy
					};
					prnt "$PREFIX Now tabifying '",$events{lc$event}||$event,"'." unless $quiet;
				}
				else { prnt "$PREFIX The event '$event' does not exist." }
			}
			store $hooks, CONFIG if $config; # update config
		}
		# delete events
		elsif( /^(d(|el(|ete))|-)$/ ) {
			prnt $USAGE unless @$events;
			prnt "$PREFIX There are no known events matching that pattern." unless $events = expand_events($events);

			for my $event (@$events) {
				if( exists $hooks->{lc$event} ) {
					for( lc$event ) { unhook $hooks->{$_}{hook}; delete $hooks->{$_}; }
					prnt "$PREFIX '",$events{lc$event}||$event,"' de-tabified." unless $quiet;
				}
				else { prnt "$PREFIX The event '$event' is not currently tabified." }
			}
			store $hooks, CONFIG if $config; # update config
		}
		else { prnt $USAGE }
	}
	return EAT_XCHAT;
}

sub tabify {
	my ($values, $data) = @_;

	$data->{emitted} = ! $data->{emitted};

	# avoid emit-hook loop: continue IFF not emitted
	if( $data->{emitted} ) { # if from original hook
		hook_timer(0, sub{ # emit after this handler
			set_context( get_or_open_context($data->{event}) );
			emit_print( $data->{event}, @$values ); 
			return Xchat::REMOVE;
		});
		if( $data->{copy} ) {
			# keep event in original context
			return EAT_NONE;
		} else {
			# hide/remove from original context
			return EAT_XCHAT;
		}
	} # if emitted
	return EAT_NONE; # keep in this context (the special tab)
}

sub get_or_open_context {
	# here we decide how to shorten the event name to fit on a tab
	( my $event = '('.shift().')' ) =~ y/ //d;
	for($event){
		s/Channel/Chn/;
		s/Message/Msg/;
		s/Notify/Nfy/;
		s/Private/Prv/;
		s/Receive//; # "Receive Wallops" -> "Wallops"
		s/Server/Svr/;
		#s/WhoIs/WI/;
		#s/Ignore/Ig/;
		s/Hi(?:gh|)li(?:gh|)te?/Hi/;
	}
	
	if( my $c = find_context( $event, get_info('server') ) ) {
		return $c;
	} else {
		command("query $event");
		return find_context( $event, get_info('server') );
	}
}

sub expand_events {
	my @re = map { $_ = wildcard($_); qr{^$_$}i } @{ shift() };
	my @events;
	
	for my $e ( keys %events ) {
INNER:for my $r ( @re ) {
			if( $e =~ $r ) {
				push @events, $e;
				last INNER;
			}
		}
	}
	@events? return \@events : return;
}

sub wildcard { # convert wc to re
	# quote meta characters coming in
	my $w = "\Q$_[0]\E"; # makes <*> -> <\*>

	# need to find and replace quotmeta'd '\\'.'\*' now, not just '\*'
	$w =~ s!\\\?     !\E(.)\Q!gx;   # one character
	$w =~ s!\\\*(?=.)!\E(.*?)\Q!gx; # non-greedy required here
	$w =~ s!\\\*    $!\E(.*)\Q!gx;  # greedy required here
	# bug fix: using .+ to find chars after '*' was skipping later wildcards,
	# should've used a look-ahead to begin with

	return $w;
}

__END__