File Coverage

blib/lib/Tie/ConfigFile.pm

Criterion	Covered	Total	%
statement	91	101	90.1
branch	18	24	75.0
condition			n/a
subroutine	15	17	88.2
pod			n/a
total	124	142	87.3

package Tie::ConfigFile;

use strict;
use warnings;

use IO::File;
use Carp;

our $VERSION = '1.00';

sub __init {
    my $self = shift;

    $self->{_fh} = IO::File->new(
        $self->{filename},
        ($self->{readonly} ? O_RDONLY : O_RDWR) |
        ($self->{create_file} ? O_CREAT : 0)
    ) or croak sprintf('Unable to open file "%s".', $self->{filename});

    # we utf-8, baby
    $self->{_fh}->binmode(':utf8');

    # init cache
    $self->{_cache} = {};

    return 1;
}

sub __read {
    my $self = shift;

    # separator character
    my $SEP = '=';
    # comment character
    my $COMM = ';';

    my $cache = $self->{_cache};

    my $i = 0;
    while (defined(my $line = $self->{_fh}->getline)) {
        chomp $line;

        # is it comment?
        if ($line =~ /^\s*$COMM/) {
            push @{ $cache->{structure} },
                 {
                    type => 'comment',
                    value => $line,
                 };
        }
        # is it just whitespace?
        elsif ($line =~ /^\s*$/) {
            push @{ $cache->{structure} },
            {
                type => 'whitespace',
                value => $line,
            }
        }
        # is it key-value pair?
        elsif ($line =~ /$SEP/) {
            my($key, $value) = split /\s*$SEP\s*/, $line, 2;

            push @{ $cache->{structure} },
            {
                type => 'value',
                value => $line,
            };

            # these are needed for fast retrieval of values
            $cache->{values}{$key} = $value;
            $cache->{key_to_struct}{$key} = $cache->{structure}->[$i];
        }
        # we can't parse it
        else {
            croak sprintf(
                "Found garbage at <%s>, line %d.",
                $self->{filename}, $i + 1
            );
        }

        $i++;
    }

    return
}

sub __write {
    my $self = shift;

    my $cache = $self->{_cache};

    # clear the file before we write to it.
    $self->{_fh}->truncate(0);
    $self->{_fh}->seek(0, 0);

    for my $item (@{ $cache->{structure} }) {
        next if $item->{deleted};

        $self->{_fh}->print($item->{value}, "\n");
    }

    # Due to flushing, writes are reliable even if user forgets to untie hash.
    $self->{_fh}->flush;

    return;
}

sub TIEHASH {
    my($class, %args) = @_;

    my $self = {
        filename         => undef,
        readonly         => 1,
        create_file      => 0,
        %args
    };

    unless (defined $self->{filename}) {
        croak 'Filename is required.';
    }

    bless $self, $class;

    $self->__init;
    $self->__read;

    return $self;
}

sub FETCH {
    my($self, $key) = @_;

    my $cache = $self->{_cache};

    return $cache->{values}{$key};
}

sub STORE {
    my($self, $key, $value) = @_;

    my $cache = $self->{_cache};

    if ($self->{readonly}) {
        croak 'STORE is not allowed on read-only config file.';
    }

    if (exists $self->{_cache}{values}{$key}) {
        # key already exist, just update it
        $cache->{values}{$key} = $value;
        $cache->{key_to_struct}{$key}{value} = "$key=$value",
    }
    else {
        # create new key
        push @{ $cache->{structure} },
        {
            type => 'value',
            value => "$key=$value",
        };
        # index of element we just pushed
        my $index = $#{ $cache->{structure} };

        $cache->{values}{$key} = $value;
        $cache->{key_to_struct}{$key} = $cache->{structure}->[$index],
    }

    $self->__write;

    return;
}

sub DELETE {
    my($self, $key) = @_;

    my $cache = $self->{_cache};

    if ($self->{readonly}) {
        croak 'DELETE is not allowed on read-only config file.';
    }

    $cache->{key_to_struct}{$key}{deleted} = 1;
    delete $cache->{key_to_struct}{$key};
    delete $cache->{values}{$key};

    $self->__write;

    return;
}

sub CLEAR {
    my $self = shift;

    %{$self->{_cache}} = ();
    $self->__write;

    return;
}

sub EXISTS {
    my($self, $key) = @_;

    # Empty keys have '' value, so if value is undefined, key doesn't exist.
    return exists $self->{_cache}{values}{$key};
}

sub FIRSTKEY {
    my $self = shift;

    return (each %{ $self->{_cache}{values} } )
}

sub NEXTKEY {
    my $self = shift;

    return (each %{ $self->{_cache}{values} } )
}

sub UNTIE {
    my($self, $count) = @_;

    carp "untie attempted while $count inner references still exist" if $count;

    return
}

sub DESTROY {
    my $self = shift;

    $self->{_fh}->close;

    return
}

'thank you based god';

__END__