package Config::Simple;

require 5.003;

use strict;
use Carp;
use File::Copy;
use IO::File;
use Fcntl qw(:DEFAULT :flock);

require Exporter;
use vars qw($VERSION @ISA @EXPORT $MD5 $errstr $LOCK_FILE);

@ISA = qw(Exporter);

$VERSION = "2.5";

eval {
    for ( @Fcntl::EXPORT ) {
        /^(O_|LOCK_)/   or next;
        push @EXPORT, $_;
    }
    Fcntl->import(@EXPORT);
};


$MD5 = 1;

eval {  require Digest::MD5 };

if ( $@ ) {
    $MD5 = 0;
    carp "Please install Digest::MD5 from your nearest CPAN mirror: perl -MCPAN -e 'install Digest::MD5')";
}








sub new {
    my $class = shift;
    $class = ref($class) || $class;

    my $self = {
        _options    =>  {
            filename    => undef,
            mode        => O_RDONLY|O_CREAT,
            lockfile    => "",
            c           => 1,
            @_,
        },
        _cfg        => {},
        _checksum   => undef,
        _tied_access => undef,
    };

    # deciding a name for a lock file
    unless ( $self->{_options}{lockfile} ) {
        $self->{_options}{lockfile} = $self->{_options}{filename} . ".lock";
    }

    $self->{_options}{filename} ||=$self->{_options}{_filename};


    # creating a digest of the file...
    if ( $MD5 and -e $self->{_options}{filename} ) {
        my $fh = new IO::File $self->{_options}->{filename}, O_RDONLY  or carp "Couldn't open $self->{_options}{filename}, $!";
        flock ($fh, LOCK_SH|LOCK_NB) or carp "Couldn't acquire a lock on $self->{_options}{filename}, $!";

        my $md5 = Digest::MD5->new();
        $md5->addfile(\$fh);
        $self->{_checksum} = $md5->hexdigest();
        $fh->close();
    }

    bless $self => $class;

    $self->_init() or return undef;

    return $self;
}




sub DESTROY {   }



sub _init {
    my $self = shift;

    my $mode = $self->{_options}->{mode};
    my $file = $self->{_options}{filename};


    my $fh = new IO::File ($file, $mode) or $errstr = "Couldn't open $file, $!", return undef;
    flock ($fh, LOCK_SH|LOCK_NB) or $errstr = "Couldn't get lock on $file, $!", return undef;

    my $title = "";
    my $after_dot = 0;
    local $/ = "\n";
    while ( <$fh> ) {

        $after_dot  and $self->{'.'} .= $_, next;
        /^(;|\n|\#)/    and next;   # deal with \n and comments
        /^\[([^\]]+)\]/ and $title = $1, next;
        /^([^=]+)=(.+)/ and $self->{_cfg}->{$title}{$1} = $2, $self->{_named}{"$title.$1"} = $2, next;
        /^\./           and $after_dot = 1, next;   # don't read anything after the sole dot (.)

        chomp ($_);
        my $msg = "Syntax error in line $. of $file: \"$_\"";
        $self->{_options}{c}    and croak $msg;

    }

    $fh->close();
    return 1;
}



sub _tied_access {
    my $self = shift;

    $self->{_tied_access} = shift;
}


sub _get_block {
    my $self = shift;

    my ($block) =  @_;
    my %hash = ();

    for my $key ( keys %{ $self->{_cfg}{$block} } ) {
        $hash{$key} = $self->_get_single_param($block, $key)
    }

    return \%hash;
}


sub _create_block {
    my $self = shift;
    my ($block, $values) = @_;

    for my $key ( keys %{$values} ) {
        $self->_set_single_param($block, $key, $values->{$key});
    }

}



sub _get_single_param {
    my $self = shift;
    my ($block, $key) = @_;

    my $value = $self->{_cfg}->{$block}->{$key} || "";
    $value =~ s/\\n/\n/g;

    return $value;
}



sub _set_single_param {
    my $self = shift;

    my ($block, $key, $value) = @_;

    $value =~ s/\n/\\n/g;
    $self->{_cfg}->{$block}->{$key} = $value;
    $self->{_named}->{"$block.$key"} = $value;

}


sub param {
    my $self = shift;

    # @b = $config->param();
    unless ( scalar(@_) ) {
        return keys %{$self->{_cfg}};
    }

    # $config->param('author.f_name');
    if ( scalar(@_) == 1 ) {
        my ($block, $key) = split /\./, $_[0];
        return $self->_get_single_param($block, $key);
    }


    # implementing verion 2.0 API
    my $args = {};
    if ( scalar(@_) == 2 ) {
        # $config->param('author.f_name', 'Shezrod');
        my ($block, $key) = split /\./, $_[0];
        if ( $block && $key ) {
            $self->_set_single_param($block, $key, $_[1]);
        }

        $args = {
            -block  => "",
            -name   => "",
            @_,
        };

        # $config->param(-block=>'author');
        if ( $args->{'-block'} ) {
            return $self->_get_block($args->{'-block'});
        }

        # $config->param(-name=>'author.f_name');
        if ( $args->{'-name'} ) {
            my ($block, $key) = split /\./, $args->{'-name'};
            if ($block && $key) {
                return $self->_get_single_param($block, $key);
            }
        }
    }


    $args = {
        -block  => "",
        -values => {},
        -name   => "",
        -value  => "",
        @_,
    };

    if ( $args->{'-block'} and $args->{'-values'} ) {
        # checking if `-values` is actually a hashref
        unless ( ref( $args->{'-values'} ) eq 'HASH' ) {
            croak "'-values' option requires a hash reference";
        }
        $self->_create_block($args->{'-block'}, $args->{'-values'});
        return 1;
    }


    if ( $args->{'-name'} && $args->{'-value'} ) {
        my ($block, $key) = split /\./, $args->{'-name'};
        if ( $block && $key) {
            $self->_set_single_param($block, $key, $args->{'-value'});
            return 1;
        }
    }
}






# for backward compatability...
sub set_param {
    my $self = shift;

    my ($name, $value) = @_;
    my ($block, $key) = split /\./, $name;
    $self->_set_single_param($block, $key, $value);

}



sub param_hash {
    my $self = shift;

    my %hash = ();
    for my $block ( keys %{$self->{_cfg}} ) {
        $block =~ m/^\./    and next;
        for my $key ( keys %{ $self->{_cfg}{$block} } ) {
            $hash{ $block . '.' . $key } = $self->_get_single_param($block, $key);
        }
    }

    return %hash;
}



sub write {
    my $self = shift;

    my $new_file = $_[0];
    my $file = $self->{_options}->{filename};
    my $lock = $self->{_options}->{lockfile};
    my $mode = $self->{_options}->{mode};

    # checking if anything was changed manually while
    # program was running...
    if ( $MD5 and !$new_file ) {

        my $checksum = new IO::File($self->{_options}->{filename}) or carp "Couldn't open $self->{_options}{filename} for reading, $!";
        flock ($checksum, LOCK_SH|LOCK_NB) or carp "Couldn't acquire lock on $self->{_options}{filename}, $!";
        my $md5 = Digest::MD5->new();
        $md5->addfile(\$checksum);
        $checksum->close();

        if ( ($self->{_checksum} ne $md5->hexdigest) and (not $self->{_tied_access} ) ) {
            carp "File's contents have been modified by the third party. Creating a backup copy of the old one";
            File::Copy::copy($file, $file . ".bk");
        }
    }

    my $lck = new IO::File($lock, O_RDONLY|O_CREAT) or $errstr = "Couldn't access $lock, $!", return undef;
    flock($lck, LOCK_EX) or $errstr = "Couldn't get exclusive lock on $lock, $!", return undef;

    $file = $new_file || $file;

    my $fh = new IO::File($file, O_RDWR|O_CREAT|O_TRUNC, 0751) or $errstr = "Couldn't truncate $file, $!", return undef;
    select ($fh);

    print "; Maintained by Config::Simple/$VERSION\n";
    print "; Get the latest version from http://www.CPAN.org or your nearest CPAN mirror\n";
    print "; ", "-" x 70, "\n\n";

    while ( my($block, $values) = each %{ $self->{_cfg} } ) {

        print "[$block]\n";
        while ( my ($key, $value) = each %{$values} ) {
            print "$key=$value\n";
        }
        print "\n";
    }

    if ( defined $self->{'.'} )  {
        print ".\n";
        print $self->{'.'};
    }

    select (STDOUT);
    $fh->close();
    $lck->close();
    unlink $lock;

}




sub load {
    my $self = shift;

    # $config->load($cgi);
    if ( scalar @_ == 1 ) {
        unless ( ref($_[0]) ) {
            $errstr = "load() didn't get expected CGI object";
            return undef;
        }

        my $cgi = $_[0];
        while ( my ($block, $values) = each %{ $self->{_cfg} } ) {
            for my $key ( keys %{$values} ) {
                $cgi->param(-name=>$block . '.' . $key, -value=>$values->{$key});
            }
        }
        return $cgi;
    }

    # $config->load($cgi, $block);
    if ( scalar @_== 2 ) {

        unless ( ref ($_[0]) ) {
            $errstr =  "load() didn't get expcted CGI object as the first argument";
            return undef;
        }

        my $cgi = $_[0];
        while ( my ($key, $value) = each %{$self->{_cfg}{$_[1]} } ) {
            $cgi->param(-name=>$_[1] . '.' . $key, -value=>$value);
        }
        return $cgi;
    }

    $errstr = "Didn't understand the usage. Please refer to online docs of Config::Simple";
    return undef;
}



# not sure if it's the right way. Let me know
sub clone {
    my $self = shift;

    return bless $self, ref($self);
}





sub error {
    my $self = shift;

    return $errstr;

}




sub dump {
    my $self = shift;

    require Data::Dumper;
    return Data::Dumper::Dumper($self);
}






package Config::Simple::Tie;

require Tie::Hash;
use vars qw(@ISA);

@ISA = qw(Config::Simple Tie::StdHash);



# TIEHASH patch submited by Scott.Weinstein@lazard.com
# on Tue, 2 Apr 2002 13:47:34 -0500
sub TIEHASH {
    my $class = shift;
    $class = ref($class) || $class;

    my ($file, $mode, $check) = @_;

    my $self = $class->Config::Simple::new(
        filename=>  $file,
        mode    =>  $mode,
        c       =>  $check
    );

    $self->_tied_access(1) if ($self);

    return $self;
}



sub DESTROY {
    my $self = shift;

    $self->_tied_access(0);
}


sub FETCH {
    my $self = shift;
    my $key = shift;

    return $self->param($key);
}


sub STORE {
    my $self = shift;
    my $key = shift;
    my $value = shift;

    $self->param($key, $value);
    return $self->write();
}


sub FIRSTKEY {
    my $self = shift;

    my $temp = keys %{$self->{_named}};
    return scalar each %{$self->{_named}};
}


sub NEXTKEY {
    my $self = shift;

    return scalar each %{$self->{_named}};
}


sub DELETE {
    my $self = shift;
    my $name = shift;

    my ($block, $key) = split /\./, $name;

    delete $self->{_named}{$name};
    delete $self->{_cfg}->{$block}->{$key};

    $self->write();
}




sub EXISTS {
    my $self = shift;

    return exists $self->{_named}{shift};
}



sub CLEAR {
    my $self = shift;

    for (keys %{$self->{_named}} ) {
        $self->{_named} = {};
        $self->{_cfg} = {};
    }
}



1;

=pod

=head1 NAME

Config::Simple - Simple Configuration File Class

=head1 SYNPOSIS

in the app.cfg configuration file:

    [mysql]
    host=ultracgis.com
    login=sherzodr
    password=secret

    [profile]
    first name=Sherzod
    last name=Ruzmetov
    email=sherzodr@cpan.org


in your Perl application:

    use Config::Simple;
    my $cfg = new Config::Simple(filename=>"app.cfg");

    print "MySQL host: ", $config->param("mysql.host"), "\n";
    print "MySQL login: ", $config->param("mysql.login"), "\n";

    # to get just [mysql] block:
    my $mysql = $cfg->param(-block=>"mysql");

    print "MySQL host: ", $mysql->{host}, "\n";
    print "MySQL login: ", $mysql->{login}, "\n";

    $cfg->write();

    # Tied hash access...

    tie my %Config, "Config::Simple::Tie", "app.cfg", O_RDONLY|O_CREAT or die $Config::Simple::errstr;

    print "MySQL host: ", $Config{'mysql.host'}, "\n";

    # setting new MySQL host value

    $Config{'mysql.host'} = "new.localhost";    # this also updates the file
    delete $Config{'mysql.RaiseError'};         # also updates the file





=head1 NOTE

This documentation refers to version 2.5 of Config::Simple. If you have a version
older than this, please update it to the latest release.

=head1 DESCRIPTION

This Perl5 library  makes it very easy to parse INI-styled configuration files
and create once on the fly. It optionally requires L<Digest::MD5|Digest::MD5> module.

C<Config::Simple> modules defines too classes, C<Config::Simple> and C<Config::Simple::Tie>.
Latter will allow accessing the Configuration files via tied hash variables. In this case,
modifications to the values of the hash will reflect in the configuration file right away.

Unlike the case with C<Config::Simple::Tie>, C<Config::Simple> classes uses simple
OO style, and requires calling method L<write()> if you want to update the contents of
the file. Otherwise all the manipulations will take place in memory.

Syntax for Config::Simple::Tie is:

    tie my %Hash, "Config::Simple::Tie", "file.cfg" [,mode] [,c] or die $Config::Simple::errstr;

We'll give you a brief example that makes use of C<Config::Simple::Tie> and we'll continue on
with C<Config::Simple> methods.

    use Config::Simple;     # notice, you still have to load Config::Simple
                            # not Config::Simple::Tie!!!

    tie my %Config, "Config::Simple::Tie", "app.cfg" or die "app.cfg: $Config::Simple::errstr";

    my $host = $Config{'mysql.host'};
    my $login = $Config{'mysql.login'};

    delete $Config{'mysql.password'};   # deletes from the file as well

    $Config{'mysql.login'} = "marley01"; # updates the file

    untie %Config;          # destroys the connection;


As you see, after you tie a hash variable to C<Config::Simple::Tie> class, you can
use it as an ordinary HASH, but in the background it will be dealing with a real
file.


=head2 CONFIGURATION FILE

Configuration file that Config::Simple uses is similar to Window's *.ini file syntax.
Example.,

    ; sample.cfg

    [block1]
    key1=value1
    key2=value2
    ...

    [block2]
    key1=value1
    key2=value2
    ...

It can have infinite number of blocks and infinite number of key/value pairs in each block.
Block and key names are case sensitive. i.e., [block1] and [Block1] are two completely different
blocks. But this might change in the subsequent releases of the library. So please use with caution!

Lines that start with either ';' (semi colon) or '#' (pound) are assumed to be comments
till the end of the line. If a line consists of a sole '.' (dot), then all the lines
till eof are ignored (it's like __END__ Perl token)

When you create Config::Simple object with $cfg = new Config::Simple(filename=>"sample.cfg")
syntax, it reads the above sample.cfg config file, parses the contents, and creates
required data structure, which you can access through its public L<methods|/"METHODS">.

In this documentation when I mention "name", I'll be referring to block name and key delimited with a dot (.).
For example, from the above sample.cfg file, following names could be retrieved:
block1.key1, block1.key2, block2.key1 and block2.key2 etc.

Here is the configuration file that I use in most of my CGI applications, and I'll be using it
in most of the examples throughout this manual:

    ;app.cfg

    [mysql]
    host=ultracgis
    login=sherzodr
    password=secret
    db_name=test
    RaiseError=1
    PrintError=1

=head2 fcntl.h Constants

by default Config::Simple exports C<O_RDONLY>, C<O_RDWR>, C<O_CREAT>, C<O_EXCL> L<fcnl.h|Fcntl> (file control) constants.
When you create Config::Simple object by passing it a filename, it will try to read the file.
If it fails it creates the file. This is a default behavior. If you want to control this behavior,
you'll need to pass mode with your desired fcntl O_* constants to the constructor:

    $config = new Config::Simple(filename=>"app.cfg", mode=>O_RDONLY);
    $config = new Config::Simple(filename=>"app.cfg", mode=>O_RDONLY|O_CREAT); # default
    $config = new Config::Simple(filename=>"app.cfg", mode=>O_EXCL);

    # tied hash access method:

    $config = tie %Config, "Config::Simple::Tie", "app.cfg", O_RDONLY;
    $config = tie %Config, "Config::Simple::Tie", "app.cfg", O_RDONLY|O_CREAT;
    $config = tie %Config, "Config::Simple::Tie", "app.cfg", O_EXCL;


Note: in the tied hash access method, you can ignore the return value of tie() (which is a Config::Simple object).
You will not be using it any ways. In case you'll need this at any time in the future, you
can always acquire it by calling tied() Perl built-in function:

    $config = tied(%Config);




fcntl constants:

    +===========+============================================================+
    | constant  |   description                                              |
    +===========+============================================================+
    | O_RDONLY  |  opens a file for reading only, fails if doesn't exist    |
    +-----------+------------------------------------------------------------+
    | O_RDWR    |  opens a file for reading and writing                      |
    +-----------+------------------------------------------------------------+
    | O_CREAT   |  creates a file                                            |
    +-----------+------------------------------------------------------------+
    | O_EXCL    |  creates a file if it doesn't already exist                |
    +-----------+------------------------------------------------------------+











=head1 METHODS

=over 2

=item new( filename=>$scalar [, mode=>O_*] [, lockfile=>$scalar] [,c=>$boolean] )

Constructor method. Requires filename to be present and picks up defaults for the rest
if omitted. mode is used while opening the file, lockfile while updating the file.

It returns Config::Simple object if successful. If it fails, sets the error message to
$Config::Simple::errstr variable, and returns undef.

mode can accept any of the above described L<fcntl|Fcntl> constants. Default is C<O_RDONLY E<verbar> O_CREAT>.
Default lockfile is the name of the configuration file with ".lock" extension

If you set the value of C<c> to 1 (true), then it checks the configuration file for proper
syntax, and throws an exception if it finds a syntax error. Error message looks
something like C<Syntax error in line 2 of sample.cfg: "this is just wrong" at t/default.t line 11>.
If you set it to 0 (false), those lines will just be ignored.

=item param([args])

If called without any arguments, returns the list of all the available blocks in the
config. file.

If called with arguments, this method supports several  different syntax,
and we'll discuss them all separately.

=over 4

=item param($name))

returns the value of $name. $name is block and key separated with a dot. For example,
to retrieve the mysql login name from the app.cfg, we could use the following
syntax:

    $login = $cfg->param("mysql.login");

=item param(-name=>$name)

the same as L<"param($name)">

=item param($name, $value)

updates the value of $name to $value. For example, to set the value of "RaiseError" to 0, and
create an new "AutoCommit" key with a true value:

    $cfg->param("mysql.RaiseError", 0);
    $cfg->param("mysql.AutoCommit", 1);

As I implied above, if either the block or the key does not exist, it will be created for you.
So

    $cfg->param("author.f_name", "Sherzod");

would create an [author] block with "f_name=Sherzod" key/value pair.

=item param(-name=>$name, -value=>$value)

the same as L<"param($name, $value)">

=item param(-block=>$block)

returns the whole block as a hash reference. For example, to get the whole [mysql] block:

    $mysql = $cfg->param(-block=>'mysql');

    $login = $mysql->{login};
    $psswd = $mysql->{password};

=item param(-block=>$block, -values=>{key1=>value1, key2=>value2})

creates a new block with the specified values,
or overrides existing block. For example, to add the [site] block to the above app.cfg with
"title=UltraCgis.com" and "description=The coolest site" key/values we could use the following syntax:

    $cfg->param(-block=>"site", -values=>{
                    title=> "UltraCgis.com",
                    description=>"The coolest site",
                    author=>"Sherzod B. Ruzmetov",
                    });

note that if the [site] block already exists, its contents will be cleared and then re-created with
the new values.

=back

=item set_param($name, $value)

This method is provided for backward compatibility with 1.x version of Config::Simple. It is identical
to param($name, $value) syntax.

=item param_hash()

handy method to save the contents of the config. file into a hash variable.

    %Config = $cfg->param_hash();

Structure of %Config looks like the following:

    %Config = (
        'mysql.PrintError'  => 1,
        'mysql.db_name'     => 'test',
        'mysql.login'       => 'sherzodr',
        'mysql.password'    => 'secret',
        'mysql.host'        => 'ultracgis.com',
        'mysql.RaiseError'  => 1,
    );

=item write([$new_filename])

Notice, that all the above manipulations take place in the object's memory, i.e., changes you
make with param() and set_param() methods do not reflect in the actual config. file.
To update the config file in the end, you'll need to call L<"write()"> method with no arguments.

If you want to save newly updated/created configuration into a new file, pass the new filename
as the first argument to the write() method, and the original config. file will not be
touched.

If it detects that configuration file was updated by a third party while Config::Simple was working
on the file, it throws a harmless warning to STDERR, and will copy the original file to a new location
with the .bk extension, and updates the configuration file with its own contents.

L<"write()"> returns true if successful, undef, otherwise. Error message can be accessed either
vi $Config::Simple::errstr variable, or by calling L<"error()"> method.

=item error()

Returns the value of $Config::Simple::errstr

=back

=head1 BUGS

Hopefully none.

Please send them to my email if you detect any with a sample code
that triggers that bug. Even if you don't have any, just let me know that you are using it.
It just makes me feel good ;-)

=head1 CREDITS

=over 4

=item Scott Weinstein (Scott.Weinstein@lazard.com)

Submited the patch for the C<TIEHASH()> method in C<Config::Simple::Tie> class.

=back

=head1 COPYRIGHT

    Copyright (C) 2002  Sherzod Ruzmetov <sherzodr@cpan.org>

    This program is free software; you can redistribute it and/or
    modify it under the same terms as Perl itself

=head1 AUTHOR

    Sherzod B. Ruzmetov <sherzodr@cpan.org>
    http://www.ultracgis.com

=head1 SEE ALSO

L<perl>


=cut
