# Copyright (c) 2016, Mitchell Cooper
#
# Evented::Configuration:
#
# a configuration file parser and event-driven configuration class.
# Evented::Configuration is based on UICd::Configuration, the class of the UIC daemon.
# UICd's parser was based on juno5's parser, which evolved from juno4, juno3, and juno2.
# Early versions of Evented::Configuration were also found in several IRC bots, including
# foxy-java. Evented::Configuration provides several convenience fetching methods.
#
# Events:
#
# each time a configuration value changes, change:blocktype/blockname:key is fired. For unnamed
# blocks, the block type is omitted. For example, a block named 'chocolate' of type
# 'cookies' would fire the event 'change:cookies/chocolate:favorite' when its 'favorite' key
# is changed. An unnamed block of type 'fudge' would fire the event 'change:fudge:peanutbutter'
# when its 'peanutbutter' key is changed.
#
# If a value never existed, new values fire change events as well. If you want your
# listeners to respond to certain values even when the configuration is first loaded,
# simply add the listeners before calling parse_config(). If you wish for the opposite
# behavior, do the opposite: apply the handlers after calling parse_config().
#
# All events are fired with:
#    $old - first argument, the former value of this configuration key.
#    $new - second argument, the new value of this configuration key.
#
# The easiest way to attach configuration change events is with the on_change() method.
# It is also the safest way because event names could possibly change in the future.
# For example:
#
# $conf->on_change(['someBlockType', 'someBlockName'], 'key', sub {
#     my ($event, $old, $new) = @_;
#     ...
# });
#
# You can also add additional hash arguments for ->register_event() to the end.
#

package Evented::Configuration;

use warnings;
use strict;
use utf8;
use 5.010;
use parent 'Evented::Object';
use Scalar::Util qw(blessed);

our $VERSION = '4.00';

my ($true, $false) = (1, 0);
sub on  () { state $on  = bless \$true,  'Evented::Configuration::Boolean' }
sub off () { state $off = bless \$false, 'Evented::Configuration::Boolean' }

# create a new configuration instance.
sub new {
    my ($class, %opts) = (shift, @_);

    # if we have no defined conffile, we must give up now.
    return if !defined $opts{conffile};

    # if 'hashref' is provided, use it.
    $opts{conf} = $opts{hashref} || $opts{conf} || {};

    # return the new configuration object.
    return bless \%opts, $class;

}

# parse the configuration file.
sub parse_config {
    my ($conf) = @_;
    my $file = $conf->{conffile};

    # open for reading
    my $fh;
    if (not open $fh, '<', $file) {
        my $msg = "$file: Failed to open for reading: $!";
        return (undef, $msg);
    }

    my ($block, $name, @new_conf);
    my $err = sub {
        my ($i, $msg) = @_;
        $msg = "$file:$i: $msg; parsing aborted";
        close $fh;
        return wantarray ? (undef, $msg) : undef;
    };

    while (<$fh>) {
        my ($key, $val, $val_changed_maybe);

        # remove comments and excess whitespace.
        chomp;
        s/^\s*//;
        s/\s*(#.*)$//;
        next unless length;

        # a block with a name.
        if (m/^\[(.+?):(.+)\]$/) {
            $block = trim($1);
            $name  = trim($2);
        }

        # a nameless block.
        elsif (m/^\[(.+)\]$/) {
            $block = 'section';
            $name  = trim($1);
        }

        # a boolean key.
        elsif (m/^([\w:]+)$/) {
            $key = trim($1);
            $val = on;
            $val_changed_maybe++;

            # no block is set
            return $err->($., "Stray key '$key'")
                if !length $block;
        }

        # a key and value.
        elsif (m/^([\w:]+)\s*[:=]+(.+)$/) {
            $key = trim($1);
            my $val_str = trim($2);
            $val_changed_maybe++;

            # no block is set
            return $err->($., "Stray pair '$key = $val_str'")
                if !length $block;

            $val = eval $val_str;

            # error occured in eval
            return $err->($., "Invalid value '$val_str': $@")
                if $@;
        }

        # I don't know how to handle this.
        else {
            return $err->($., "Syntax error: '$_'");
        }

        # something may have changed.
        next unless $val_changed_maybe;

        # fetch the old value and set the new value.
        my $old = $conf->{conf}{$block}{$name}{$key};

        # push the events.
        push @new_conf, $block, $name, $key, $old, $val;
    }

    # we parsed the entire file successfully, so commit the changes.
    my @new_events;
    while (my @set = splice @new_conf, 0, 5) {
        push @new_events, $conf->_get_events(@set);
        $conf->{conf}{ $set[0] }{ $set[1] }{ $set[2] } = $set[4];
    }

    # now fire change events.
    $conf->fire_events_together(@new_events) if @new_events;

    close $fh;
    return 1;
}

# returns true if the block is found.
# supports unnamed blocks by get(block, key)
# supports   named blocks by get([block type, block name], key)
sub has_block {
    my ($conf, $block) = @_;
    my ($block_type, $block_name) = _block_parts($block);
    return 1 if $conf->{conf}{$block_type}{$block_name};
}

# returns a list of all the names of a block type.
# for example, names_of_block('listen') might return ('0.0.0.0', '127.0.0.1')
sub names_of_block {
    my ($conf, $block_type) = @_;
    return keys %{ $conf->{conf}{$block_type} };
}

# returns a list of all the keys in a block.
# for example, keys_of_block('modules') would return an array of every module.
# accepts block type or [block type, block name] as well.
sub keys_of_block {
    my ($conf, $block) = @_;
    my ($block_type, $block_name) = _block_parts($block);

    # not a hashref. return empty list.
    my $hashref = $conf->{conf}{$block_type}{$block_name};
    if (!$hashref || !ref $hashref || ref $hashref ne 'HASH') {
        return;
    }

    return keys %$hashref;
}

# returns a list of all the values in a block.
# accepts block type or [block type, block name] as well.
sub values_of_block {
    my ($conf, $block) = @_;
    my ($block_type, $block_name) = _block_parts($block);

    # not a hashref. return empty list.
    my $hashref = $conf->{conf}{$block_type}{$block_name};
    if (!$hashref || !ref $hashref || ref $hashref ne 'HASH') {
        return;
    }

    return map _value_to_perl($_), values %$hashref;
}

# returns the key:value hash of a block.
# accepts block type or [block type, block name] as well.
sub hash_of_block {
    my ($conf, $block) = @_;
    my ($block_type, $block_name) = _block_parts($block);

    # not a hashref. return empty list.
    my $hashref = $conf->{conf}{$block_type}{$block_name};
    if (!$hashref || !ref $hashref || ref $hashref ne 'HASH') {
        return;
    }

    return map { $_ => _value_to_perl($hashref->{$_}) } keys %$hashref;
}

# get a configuration value.
# supports unnamed blocks by get(block, key)
# supports   named blocks by get([block type, block name], key)
sub  get { _get(shift, 0, @_) }
sub _get {
    my ($conf, $bool_objs, $block, $key) = @_;
    my ($block_type, $block_name) = _block_parts($block);
    my $res = $conf->{conf}{$block_type}{$block_name}{$key};
    return $bool_objs ? $res : _value_to_perl($res);
}

# remove leading and trailing whitespace.
sub trim {
    my $string = shift;
    $string =~ s/\s+$//;
    $string =~ s/^\s+//;
    return $string;
}

# convert stored value to Perl representation.
sub _value_to_perl {
    my ($val) = @_;
    if (blessed $val && $val->isa('Evented::Configuration::Boolean')) {
        return $$val ? 1 : undef;
    }
    return $val;
}

# attach a configuration change listener.
# see notes at top of file for usage.
sub on_change {
    my ($conf, $block, $key, $code, %opts) = @_;
    my ($block_type, $block_name) = _block_parts($block);

    # determine the name of the event.
    $block = $block_type eq 'section' ? $block_name : $block_type.q(/).$block_name;
    my $event_name = "change:$block:$key";

    # register the event.
    return $conf->register_event($event_name => $code, %opts);
}

# get events for a change.
sub _get_events {
    my ($conf, $block, $name, $key, $old, $val) = @_;
    $old = _value_to_perl($old);
    $val = _value_to_perl($val);

    # determine the name of the event.
    my $eblock = $block eq 'section' ? $name : $block.q(/).$name;

    # return the events.
    return (

        # change                        => sub { my ($blockref, $key, $old, $new) }
        # change:namelessblock          => sub { my            ($key, $old, $new) }
        # change:named/theName          => sub { my            ($key, $old, $new) }
        # change:section:__ANY__        => sub { my ($the_type, $key, $old, $new) }
        # change:named:__ANY__          => sub { my ($the_name, $key, $old, $new) }
        # change:namelessblock:someKey  => sub { my                  ($old, $new) }
        # change:named/theName:someKey  => sub { my                  ($old, $new) }

        [ change                  => [ $block, $name ], $key, $old, $val ],
        [ "change:$eblock"        =>                    $key, $old, $val ],
        [ "change:$block:__ANY__" =>           $name,   $key, $old, $val ],
        [ "change:$eblock:$key"   =>                          $old, $val ]

    );
}

# handle 'unamed block' or [ 'block type', 'named block' ]
# returns a list (block type, block name)
sub _block_parts {
    my $block = shift;
    if (ref $block && ref $block eq 'ARRAY' && @$block >= 2) {
        return @$block;
    }
    return ('section', $block);
}

1;

=head1 NAME

B<Evented::Configuration> - an event-driven objective configuration class and parser for
Perl software built upon L<Evented::Object>.

=head1 SYNOPSIS

=head2 Example usage

 # create a new configuration instance.
 my $conf = Evented::Configuration->new(conffile => 'etc/some.conf');

 # attach a callback to respond to changes of the user:age key.
 $conf->on_change('user', 'name', sub {
     my ($event, $old, $new) = @_;
     say 'The user\'s age changed from ', $old || '(not born)', "to $new";
 });

 # parse the configuration file.
 $conf->parse_config();

=head2 Example configuration file

 # some.conf file

 # Comments

 # Hello, I am a comment.
 # I am also a comment.

 # Unnamed blocks

 [ someBlock ]

 someKey  = "some string"
 otherKey = 12
 another  = ['hello', 'there']
 evenMore = ['a'..'z']

 # Named blocks

 [ cookies: sugar ]

 favorites = ['sugar cookie', 'snickerdoodle']

 [ cookies: chocolate ]

 favorites = ['chocolate macadamia nut', 'chocolate chip']

=head1 DESCRIPTION

As the name suggests, event firing is what makes Evented::Configuration unique in
comparison to other configuration classes.

=head2 Blocks

Evented::Configuration's configuration is block-styled, with all keys and values
associated with a block. Blocks can be "named," meaning there are several blocks of one
type with different names, or they can be "unnamed," meaning there is only one block of
that type.

=head2 Objective

Evented::Configuration's objective interface allows you to store nothing more than the
configuration object. Then, make the object accessible where you need it.

=head2 Event-driven

Evented::Configuration is based upon the Evented::Object framework, firing events each time
a configuration changes. This allows software to respond immediately to changes of user
settings, etc.

=head2 Convenience

Most configuration parsers spit out nothing more than a hash reference of keys and values.
Evented::Configuration instead supplies several convenient methods for fetching
configuration data.

=head1 METHODS

Evented::Configuration provides several convenient methods for fetching configuration
values.

=head2 Evented::Configuration->new(%options)

Creates a new instance of Evented::Configuration.

 my $conf = Evented::Configuration->new(conffile => 'etc/some.conf');

B<Parameters>

=over 4

=item *

B<options>: a hash of constructor options.

=back

B<%options - constructor options>

=over 4

=item *

* B<conffile>: file location of a configuration file.

=item *

* B<hashref>: I<optional>, a hash ref to store configuration values in.

=back

=head2 $conf->parse_config()

Parses the configuration file. Used also to rehash configuration.

 $conf->parse_config();

=head2 $conf->get($block, $key)

Fetches a single configuration value.

 my $value = $conf->get('unnamedBlock', 'someKey');
 my $other = $conf->get(['blockType', 'namedBlock'], 'someKey');

B<Parameters>

=over 4

=item *

B<block>: for unnamed blocks, should be the string block type. for named blocks, should be
an array reference in the form of C<[block type, block name]>.

=item *

B<key>: the key of the configuration value being fetched.

=back

=head2 $conf->names_of_block($block_type)

Returns an array of the names of all blocks of the specified type.

 foreach my $block_name ($conf->names_of_block('cookies')) {
     print "name of this cookie block: $block_name\n";
 }

B<Parameters>

=over 4

=item *

B<block_type>: the type of the named block.

=back

=head2 $conf->keys_of_block($block)

Returns an array of all the keys in the specified block.

 foreach my $key ($conf->keys_of_block('someUnnamedBlock')) {
     print "someUnnamedBlock unnamed block has key: $key\n";
 }

 foreach my $key ($conf->keys_of_block('someNamedBlock', 'someName')) {
     print "someNamedBlock:someName named block has key: $key\n";
 }

B<Parameters>

=over 4

=item *

B<block>: for unnamed blocks, should be the string block type. for named blocks, should be
an array reference in the form of C<[block type, block name]>.

=back

=head2 $conf->on_change($block, $key, $code, %opts)

Attaches an event listener for the configuration change event. This event will be fired
even if the value never existed. If you want a listener to be called the first time the
configuration is parsed, simply add the listener before calling C<-E<gt>parse_config()>.
Otherwise, add listeners later.

 # an example with an unnamed block
 $conf->on_change('myUnnamedBlock', 'myKey', sub {
     my ($event, $old, $new) = @_;
     ...
 });

 # an example with a name block.
 $conf->on_change(['myNamedBlockType', 'myBlockName'], 'someKey', sub {
     my ($event, $old, $new) = @_;
     ...
 });

 # an example with an unnamed block and ->register_event() options.
 $conf->on_change('myUnnamedBlock', 'myKey', sub {
     my ($event, $old, $new) = @_;
     ...
 }, priority => 100, name => 'myCallback');

B<Parameters>

=over 4

=item *

B<block>: for unnamed blocks, should be the string block type. for named blocks, should be
an array reference in the form of C<[block type, block name]>.

=item *

B<key>: the key of the configuration value being listened for.

=item *

B<code>: a code reference to be called when the value is changed.

=item *

B<opts>: I<optional>, a hash of any other options to be passed to Evented::Object's
C<-E<gt>register_event()>.

=back

=head1 EVENTS

Evented::Configuration fires events when configuration values are changed.

In any case, events are fired with arguments C<(old value, new value)>.

Say you have an unnamed block of type C<myBlock>. If you changed the key C<myKey> in
C<myBlock>, Evented::Configuration would fire the event
C<change:myBlock:myKey>.

Now assume you have a named block of type C<myBlock> with name C<myName>. If you changed
the key C<myKey> in C<myBlock:myName>, Evented::Configuration would fire event
C<change:myBlock/myName:myKey>.

However, it is recommended that you use the C<-E<gt>on_change()> method rather than
directly attaching event callbacks. This will insure compatibility for later versions that
could possibly change the way events are fired.

=head1 SEE ALSO

=over 4

=item *

L<Evented::Object> - the event class that powers Evented::Configuration.

=back

=head1 AUTHOR

L<Mitchell Cooper|https://github.com/cooper> <cooper@cpan.org>

Copyright E<copy> 2014. Released under BSD license.

=over 4

=item *

B<IRC channel>: L<irc.notroll.net #k|irc://irc.notroll.net/k>

=item *

B<Email>: cooper@cpan.org

=item *

B<CPAN>: L<COOPER|http://search.cpan.org/~cooper/>

=item *

B<GitHub>: L<cooper|https://github.com/cooper>

=back

Comments, complaints, and recommendations are accepted. IRC is my preferred communication
medium. Bugs may be reported on
L<RT|https://rt.cpan.org/Public/Dist/Display.html?Name=Evented-Configuration>.
