#! perl
package Config::Eggdrop::Userfile;

=head1 NAME

Config::Eggdrop::Userfile - parse userfiles generated by Eggdrop

=head1 SYNOPSIS

If you want to read from a file handle, you can use something like this:

  use Config::Eggdrop::Userfile;
  open my $fh, '<', '/path/to/eggdrop/userfile';
  my $parsed = Config::Eggdrop::Userfile::parse_file $fh;

Or, provided that you have a userfile read into $content, you can read from a string:

  use Config::Eggdrop::Userfile;
  my $parsed = Config::Eggdrop::Userfile::parse_string $content;

=head1 DESCRIPTION

This is a fairly simple regex-based parser module for Eggdrop userfiles.
Eggdrop userfiles contain information (including passwords) about eggdrop
partyline user accounts.

=cut

use v5.10.1;
use strict;
use warnings;
use Carp qw/croak carp/;
use feature qw/switch/;

our $VERSION = 0.01;
my $BADNICKCHARS = '-,+*=:!.@#;$%&'; # from eggdrop1.6.21/src/eggdrop.h:62

# TODO
#  - implement at least the lines that could be written by eggdrop 1.6. Older
#    userfiles shouldn't be very relevant anymore
#  - This means fix all FIXMEs below
#  - add a limited mode that only searches for a certain user/password you're
#    looking for rather than taking apart the whole userfile as they can become
#    relatively big. => OO module with callbacks?
#  - write documentation
#  - put on CPAN

=head2 Functions

These functions are in C<@EXPORT_OK>.

=cut

BEGIN {
	use base 'Exporter';
	our @EXPORT_OK = qw/parse_file parse_string/;
}

################################################################################
# This module currently only understands a subset of the userfile entries
# defined by eggdrop as follows. The best compatible eggdrop version with this
# module is the most recent one, at the time of writing.
# If your userfile can not be parsed correctly, please file a bug report..
#
# Sadly, eggdrop's userfile parser seems to be a bit messy, so this module will
# probably not provide 100% identical features
#
# from eggdrop1.6.21/src/users.c:637:
#
# tagged lines in the user file:
# * OLD:
# #  (comment)
# ;  (comment)
# -  hostmask(s)
# +  email
# *  dcc directory
# =  comment
# :  info line
# .  xtra (Tcl)
# !  channel-specific
# !! global laston
# :: channel-specific bans
# NEW:
# *ban global bans
# *ignore global ignores
# ::#chan channel bans
# - entries in each
# <handle> begin user entry
# --KEY INFO - info on each
# NEWER:
# % exemptmask(s)
# @ Invitemask(s)
# *exempt global exempts
# *Invite global Invites
# && channel-specific exempts
# &&#chan channel exempts
# $$ channel-specific Invites
# $$#chan channel Invites
################################################################################

sub parse_xtra {
	my ($user, $key, $value) = @_;

	# FIXME add special cases for other "well known" values here which are not
	# defined by modules/scripts (they can save XTRA fields to the userfile,
	# but all caps only??)

	if ($key eq 'created') {
		$user->{created} = int($value);
	} else {
		$user->{extra}->{$key} = $value;
	}
}

sub parse_user {
	my ($data, $user, $line, $lineno) = @_;

	given ($line) {
		when (/^([^$BADNICKCHARS\s]+)\s*-\s*(\S+)/) {
		# FIXME is an eggdrop handle only required not to start with
		# BADNICKCHARS, or does it have to be BADNICKCHARS all the way?
			$user = $data->{users}->{lc $1} ||= {};
			$user->{case}  = $1;
			$user->{flags} = $2 eq '-' ? '' : $2;
		}
		when (/^! (\S+)\s*(\d+)\s*(\S+)/) {
			$user->{channels}->{$1}->{laston} = int($2);
			$user->{channels}->{$1}->{flags} = $3 eq '-' ? '' : $3;
		}
		when (/^--HOSTS (\S+)/) {
			$user->{hosts} ||= [];
			unshift @{$user->{hosts}}, $1;
		}
		when (/^--LASTON (\d+) (\S+)/) {
			$user->{laston}->{time} = int($1);
			$user->{laston}->{channel} = $2;
		}
		when (/^--XTRA (\S+) (\S+)/) {
			parse_xtra $user, $1, $2;
		}
		when (/^--PASS (\S+)/) {
			$user->{pass} = $1;
		}
		when (/^--/) {
			warn "Unknown user flag field in line $lineno";
		}
		default {
			return
		}
	}
	return $user
}

sub parse_bans {
	# FIXME not done yet
	my ($data, $bans, $line, $lineno) = @_;
	
	given ($line) {
		when (/^::(\S+) bans/) {
			$bans = $data->{bans}->{$1} ||= [];
		}
		when (/^- /) {
			warn "Unimplemented ban line in line $lineno. Please report a bug.";
		}
		default {
			return
		}
	}
	return $bans
}

sub parse_exempts {
	my ($data, $exempts, $line, $lineno) = @_;

	given ($line) {
		when (/^\*exempt - -/) {
			$exempts = $data->{exempts}->{global} ||= [];
		}
		when (/^\&\&(\S+) exempts/) {
			$exempts = $data->{exempts}->{$1} ||= [];
		}
		# Yuck..
		when (/^% ([^:]+):(\+?)(\d+)(\*?):\+(\d+):([^:]+):([^:]+):(\S+)/) {
			#                          ^ this plus means that 3 more records follow
			unshift @{$exempts}, { # FIXME or use push?
				hostmask => $1,
				perm     => $2 eq '+',
				expire   => int($3),
				sticky   => $4 eq '*',
				last     => int($5),
				#???     => int($6), # FIXME what's this?
				creator  => $7,
				reason   => $8
			};
		}

		# FIXME
		# This variant does not have the +, but I haven't seen it in my
		# userfiles, and I'm not in the mood to read that bit of eggdrop..
		when (/^% ([^:]+):(\+)?(\d+)(\*?):(\d+):([^:]+):([^:]+):(\S+)/) {
		#	What were they smoking? :(
			# TODO
			warn "Unimplemented exempt line in line $lineno. Please report a bug.";
		}
		when (/^%/) {
			warn "Malformed(?) exempt line in line $lineno, please report a bug.";
		}
		default {
			return
		}
	}
	return $exempts
}

sub parse_invites {
	my ($data, $invites, $line, $lineno) = @_;
	
	given ($line) {
		when (/^\$\$(\S+) invites/) {
			# FIXME untested
			$invites = $data->{invites}->{$1} ||= [];
		}
		when (/^@/) {
			# TODO
			warn "Unimplemented invite line in line $lineno, please report a bug.";
		}
		when (/^\$\$/) {
			warn "Malformed(?) invite line in line $lineno, please report a bug.";
		}
		default {
			return
		}
	}
	return $invites
}

=head3 parse_file()

Parses a file from a file handle and returns a hashref with the following layout:

   {
      'botnetnick' => 'foo', # eggdrop nickname as mentioned in the comment in line 1
      'invites' => { # invites configured in the bot
          '#foo' => [...],
          '#bar' => [...],
          'global' => [...]
      },
      'version' => 'v1.6.21', # eggdrop version
      'bans' => { # bans configured in the bot
          '#foo' => [...],
          '#bar' => [...]
      },
      'lines' => 25, # number of lines in this user file
      'exempts' => { # ban exempts configured in the bot
          '#foo' => [...],
          'global' => [ # global exempts (on all channels)
               {
                  'hostmask' => '*!something@something', # exempt hostmask
                  'creator' => 'someone', # handle of the person who created this exempt
                  'sticky' => 1, # sticky exempt?
                  'reason' => 'paranoia',
                  'last' => 1366930011,
                  'expire' => 0,
                  'perm' => 1 # permanent exempt?
               },
               ...
          ],
          ...
      },
      'users' => {
          'somebody' => { # eggdrop handle as lowercase
              'case' => 'SomeBodY', # correct case of the handle as stored in the user file
              'created' => 1356108279,
              'hosts' => [
                  '*!*@example.com',
                  ...
              ],
              'pass' => 'encrypted password',
              'channels' => {
                  '#foo' => {
                       'flags' => 'lo', # channel flags
                       'laston' => 1367584282 # when were they last on this channel
                  },
                  ...
              },
              'flags' => '', # global flags
              'laston' => {
                      'time' => 1367584282, # global laston time
                      'channel' => '#foo' # on which channel were they seen?
              }
          },
      }
   };

Depending on the entries present in the user file, some of these indexes may be undefined.

=cut

sub parse_file {
	my $fh = shift;
	my $data = {};
	my $lineno = 0;
	my ($user, $bans, $exempts, $invites);

	while (<$fh>) {
		$lineno++;

		if ($lineno == 1) {
			croak "Unknown userfile format" unless /^#4v: eggdrop (\S+) -- (\S+) --/;
			# FIXME apparently this is a comment. Ignore it?
			($data->{version}, $data->{botnetnick}) = ($1, $2);
			next
		}
		$user    = parse_user    $data, $user,    $_, $lineno;
		$bans    = parse_bans    $data, $bans,    $_, $lineno   unless defined $user;
		$exempts = parse_exempts $data, $exempts, $_, $lineno   unless defined $bans;
		$invites = parse_invites $data, $invites, $_, $lineno   unless defined $exempts;

		carp "unable to parse line $lineno" # apparently this line is neither of the above, annoy the user a bit..
			unless defined $user || defined $bans || defined $exempts || defined $invites;
	}

	$data->{lines} = $lineno;

	return $data
}

=head3 parse_string()

Does the same, but takes its input from a string

=cut

sub parse_string {
	my $str = shift;
	open my $fh, '<', \$str;
	my $data = parse_file $fh;
	close $fh;
	return $data;
}

=head1 AUTHOR

Moritz Wilhelmy <mw@barfooze.de>

=head1 SEE ALSO

L<Authen::Passphrase::EggdropBlowfish> for authenticating against Eggdrop
passwords.

=head1 COPYRIGHT

Copyright © 2013-2015 by Moritz Wilhelmy

This module may be copied and distributed under the same terms as perl 5 itself.

=head1 DEVELOPMENT

See the development homepage at L<https://bitbucket.org/wilhelmy/p5-config-eggdrop-userfile/> for recent changes.

=cut

1
