package XChatAutoGreet;

use strict;
use lib IRC::get_info(4);
use XChatPerlEval;
use vars qw( $cfname %conf %runque $debug );

$cfname = 'autogreet';
%runque = ();
%conf = ();
$debug = 0; # set this to 1 to enable debugging messages

### INITIALIZATION

XChatPerlEval::load( $cfname, \%conf, 'AutoGreet' );
IRC::register("AutoGreet","v0.02","","");
IRC::add_command_handler("autogreet","XChatAutoGreet::set_greeting");
IRC::add_command_handler("listgreetings","XChatAutoGreet::list_greetings");
IRC::add_print_handler("join","XChatAutoGreet::greet");


### SUBROUTINES


=head1 user_info 

Returns information about a single user.
Workaround of broken IRC::user_info in XChat2.

=cut

sub user_info {
    my ( $nick, $channel, $network ) = @_;
    my @userlist = IRC::user_list($channel,$network);
    unless( @userlist ) {
	IRC::print("Empty user_list for '$network$channel'\n");
	return;
    }
    my @result;
    foreach( @userlist ) {
	if( $_ eq ':' ) { # record separator hit
	    return @result # return info of correct nick
		if $result[0] eq $nick;
	    @result = (); # wrong nick, clear cache
	    next;
	}
	push @result, $_; # cache data
    }
    return @result # return info of correct nick
	if $result[0] eq $nick;
    # not found
    return ();
}


=head1 list_greetings

See /LISTGREETINGS ?

=cut

sub list_greetings {
  if( $_[0] eq '?' ) {
    IRC::print("/LISTGREETINGS [channel] [nick!user\@host]\n");
    IRC::print("parameters are matched as regular expressions.\n");
    return 1;
  }
  @_ = split /\s+/, $_[0];
  my $i = 0;
  foreach my $chan ( sort keys %conf ) {
      next if @_>0 and not $chan =~ /$_[0]/;
      $i++;
      IRC::print("Greet on $chan:\n");
      my $chanhosts = $conf{$chan};
      my %users = ();
      foreach my $host ( keys %$chanhosts ) {
	  my $hostusers = $chanhosts->{$host};
	  foreach my $user ( keys %$hostusers ) {
	      my $usernicks = $hostusers->{$user};
	      foreach my $nick ( keys %$usernicks ) {
		  next if @_>1 and not "$nick!$user\@$host" =~ /$_[1]/;
		  $users{"$nick!$user\@$host"} = $usernicks->{$nick};
	      }
	  }
      }
      foreach( sort keys %users ) {
	  my $h = $users{$_};
	  IRC::print( "  $_" .
		      ( $h->{'mode'} ? " ($h->{'mode'})" : '' ) .
		      ( $h->{'run'} ? ": $h->{'run'}" : '' ) . "\n" );
      }
  }
  IRC::print("No greetings found.\n") unless $i;
  return 1;
}


=head1 save_matchop

  save_matchop( $data, $value, 
		$network, $channel, $nick, $user, $host, 
		@tail );

Saves value into data structure by the given names.

=cut

sub save_matchop {
  my ( $data, $value, $network, $channel, $nick, $user, $host, @tail ) = @_;
  my $netchan = "$network$channel";
  my $who = "'$nick!$user\@$host' on '$netchan'";

  my @keys = ( $netchan, $host, $user, $nick, @tail );
  if( $value ) {
    my $data = \%conf;
    my $key = pop @keys;
    foreach( @keys ) {
      $data = $data->{$_} ||= {};
    }
    $data->{$key} = $value;
    IRC::print("Set to greet $who with '$value'\n");
  } else {
    # clear command and any empty containing hashes
    my ( $data, $key );
    do {
      $data = \%conf;
      $key = pop @keys;
      foreach( @keys ) {
	$data = $data->{$_} or return;
      }
      delete $data->{$key};
    } while( @keys and not keys(%$data) );
    IRC::print("Greeting for $who cleared.\n");
  }
}


=head1 set_greeting

See /AUTOGREET ?

Data structure is written to disk immediately.

=cut

sub set_greeting {
  if( $_[0] =~ /^[\s?]*$/ ) {
    IRC::print("/AUTOGREET [channel/]nick [+mode] greeting\n");
    IRC::print("nick     is a nickname or *nick!*user@*.host\n");
    IRC::print("channel  can be empty, #channel or network#channel\n");
    IRC::print("mode     can be empty to clear, +o for ops, +v for voice\n");
    IRC::print("greeting is a list of commands: /cmd1 ...; /cmd2 ...\n");
    IRC::print("It may contain following variables:\n");
    IRC::print("\$nick \$user \$host \$channel \$network \$mynick \$myop\n");
    return 1;
  }

  my ( $name, $cmd ) = ( shift =~ /^(\S*)\s*(.*)$/ );
  my ( $channel, $network, $nick, $autohost, $ircserver );

  eval {
      if( $name =~ m|^(.*?)(\#.*?)/(.*)$| ) {
	  ( $network, $channel, $name ) = ( $1, $2, $3 );
      } else {
	  $channel = IRC::get_info(2) || die "No channel\n";
	  $network = IRC::get_info(6) || '';
	  $network = '' if $network eq 'Error2'; # unsupported in old versions
      }
      $network ||= '*'; # any network
      $ircserver = IRC::get_info(3);

      my $userhost = $name;
      if( $name =~ m|^(.*?)!(.*)$| ) {
	  ( $name, $userhost ) = ( $1, $2 );
	  $nick = $name;
      }

      if( $userhost !~ /\@/ ) {
	  $userhost = (user_info($name,$channel,$ircserver))[1] 
	      or die "No user '$nick'\n";
	  $autohost = 1;
      }

      my ( $user, $host ) = split '@', $userhost;

      if( $autohost ) {
        my @host = split /\./, $host;
        $host =~ s/^.*?\./*./ if @host > 3;
	$user =~ s/^\W+//;
	$user = "*$user";
      }

      $nick = '*' unless( $nick ); # quicknick

      my @keychain = ( $network, $channel, $nick, $user, $host );

      save_matchop( \%conf, $1, @keychain, 'mode' )
	if $cmd =~ s/^\+(\w*)\s*//; # separate mode
      save_matchop( \%conf, $cmd, @keychain, 'run' );

      XChatPerlEval::save( $cfname, \%conf, 'AutoGreet' );
  };

  IRC::print("Failed: $@") if $@;
  return 1;
}


=head1 get_by_channel

Returns data from a hash for a given network-channel pair,
accounting possible catchalls:

  '' for network    == any network
  '#*' for channel  == any channel on given network
  '#*'              == all channels on all networks

=cut

sub get_by_channel {
  my ( $data, $network, $channel ) = @_;
  return
      $data->{"$network$channel"} ||
	  $data->{"*$channel"} ||
	      $data->{"$network#*"} ||
		  $data->{"#*"};
}


=head1 get_by_host

Returns data from a hash for given hostname.

  '*.' prefix in a key matches all hosts under the named network.

=cut

sub get_by_host {
  my ( $data, $host ) = @_;
  my $match = $data->{$host} || undef;
  until( defined $match ) {
      $host =~ s/^.*?\.// or return $data->{'*'}; # no matching hostname
      $match = $data->{"*.$host"} || undef;
  }
  return $match;
}


=head1 get_by_name

Returns data from a nested hash by a list of names.
Keys in hash may be prefixed with '*' to match any beginning.

=cut

sub get_by_name {
  my ( $data, $name, @names ) = @_;
  my $match = $data->{$name} || undef;
  unless( defined $match ) {
      until( defined( $match = $data->{"*$name"} || undef ) ) { 
	  $name =~ s/^.// or return; # no matching name
      }
  }
  return @names ? get_by_name( $match, @names ) : $match;
}


=head1 get_matching

  get_matching( $data, $network, $channel, $nick, $user, $host );

Returns data from a structure for context specified by given names.

=cut

sub get_matching {
  my ( $data, $network, $channel, $nick, $user, $host ) = @_;
  unless( $data = get_by_channel( $data, $network, $channel ) ) {
      IRC::print("No channel matching '$network$channel/$nick!$user\@$host'\n")
	  if $debug;
      return;
  }
  unless( $data = get_by_host( $data, $host ) ) {
      IRC::print("No host matching '$network$channel/$nick!$user\@$host'\n")
	  if $debug;
      return;
  }
  unless( $data = get_by_name( $data, $user, $nick ) ) {
      IRC::print("No name matching '$network$channel/$nick!$user\@$host'\n")
	  if $debug;
      return;
  }
  return $data;
}


=head1 run

Runs commands with embedded variables.

=cut

sub run {
  my ( $data, @commands ) = @_;
  foreach my $cmd ( @commands ) {
    next unless $cmd;
    $cmd =~ s/\$(\w+)/$data->{$1}/g;
    next unless $cmd;
    IRC::command( $cmd );
  }
}


=head1 pushque

Queues commands to run at a later time.

=cut

sub pushque {
  my ( $delay, $data, @commands ) = @_;
  my $time = time() + $delay;
  push @{$runque{$time} ||= []}, [ $data, @commands ];
  IRC::add_timeout_handler(500,"XChatAutoGreet::pollque");
}


=head1 pollque

Executes queued commands.

=cut

sub pollque {
    my $now = time();
    foreach my $time ( sort keys %runque ) {
	last if $time > $now;
	foreach my $cmd ( @{$runque{$time}} ) {
	    my $sub = ref $cmd->[0] eq 'CODE' ? shift(@$cmd) : \&run;
	    $sub->( @$cmd );
	}
	delete $runque{$time};
    }
    IRC::add_timeout_handler(500,"XChatAutoGreet::pollque")
	if keys %runque;
}


=head1 greet

Handler to run commands for users joining channels.

=cut

sub now_greet {
  IRC::print "Greet '$_[0]'\n" if $debug;
  my ( $nick, $channel, $userhost ) = split /\s+/, $_[0];
  my $ircserver = IRC::get_info(3);
  my $network = '*';

  my ( $user, $host ) = split '@', $userhost;
  my $data = get_matching( \%conf, $network, $channel, $nick, $user, $host );
  if( ! $data ) {
      IRC::print("No greeting for $_[0]\n") if $debug;
      return 0;
  }

  my @userinfo = user_info($nick, $channel, $ircserver);

  unless( @userinfo ) {
    IRC::print("Not greeting missing '$network$channel/$nick'\n") if $debug;
    return 0;
  }

  # found. run it.

  IRC::print("Greeting '$network$channel/$nick'\n") if $debug > 1;

  my $mynick = IRC::get_info(1);
  my $myop = (user_info($mynick,$channel,$ircserver))[-2];
  my %var = (
	     'network' => $network || '',
	     'ircserver' => $ircserver || '',
	     'channel' => $channel || '',
	     'nick' => $nick || '',
	     'user' => $user || '',
	     'host' => $host || '',
	     'mynick' => $mynick || '',
	     'myop' => $myop || '',
	     );

  if( $data->{'run'} ) {
    IRC::print("Greeting '$nick' with '$data->{'run'}'\n");
      foreach( split /\s*;\s*/, $data->{'run'} ) {
	run(\%var, $_);
      }
  }

  if( $myop and $data->{'mode'} ) {
    # target must not be operator yet
    next if $userinfo[-2];
    IRC::print("Greeting '$nick' with mode +$data->{'mode'}\n");
    IRC::command( "/mode $channel +$data->{'mode'} $nick" );
  }

  return 0;
}

=head1 greet

Handler to run commands for users joining channels.

=cut

sub greet {
    pushque( 1, \&now_greet, @_ );
    return 0;
}

1;