view release on metacpan or  search on metacpan

lib/Acrux/Config.pm  view on Meta::CPAN

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<Config::General>, L<Acrux::Pointer>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

use Config::General qw//;
use Cwd qw/getcwd/;
use File::Spec qw//;
use File::Basename qw/basename/;
use Acrux::Pointer;
use Acrux::RefUtil qw/as_array is_array_ref is_hash_ref is_value/;
use Acrux::Util qw/clone/;

use constant DEFAULT_CG_OPTS => {
    '-ApacheCompatible' => 1, # Makes possible to tweak all options in a way that Apache configs can be parsed
    '-LowerCaseNames'   => 1, # All options found in the config will be converted to lowercase
    '-UTF8'             => 1, # All files will be opened in utf8 mode
    '-AutoTrue'         => 1, # All options in your config file, whose values are set to true or false values, will be normalised to 1 or 0 respectively
};

sub new {
    my $class = shift;
    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    my $self  = bless {
            default => $args->{defaults} || $args->{default} || {},
            file    => $args->{file} // '',
            root    => $args->{root} // '', # base path to default files/directories
            dirs    => $args->{dirs} || [],
            noload  => $args->{noload} || 0,
            options => {},
            error   => '',
            config  => {},
            pointer => Acrux::Pointer->new,
            files   => [],
            orig    => $args->{options} || $args->{opts} || {},
        }, $class;
    my $myroot = length($self->{root}) ? $self->{root} : getcwd();

    # Set dirs
    my @dirs = ();
    foreach my $dir (as_array($self->{dirs})) {
        unless (File::Spec->file_name_is_absolute($dir)) { # rel
            $dir = length($myroot)
                ? File::Spec->rel2abs($dir, $myroot)
                : File::Spec->rel2abs($dir);
        }
        push @dirs, $dir if -e $dir;
    }
    $self->{dirs} = [@dirs];

    # Set config file
    my $file = $self->{file};
       $file = sprintf("%s.conf", basename($0)) unless length $file;
    unless (File::Spec->file_name_is_absolute($file)) { # rel
        $file = length($myroot)
                ? File::Spec->rel2abs($file, $myroot)
                : File::Spec->rel2abs($file);
    }
    $self->{file} = $file;
    unless ($self->{noload}) {
        unless (-r $file) {
            $self->{error} = sprintf("Configuration file \"%s\" not found or unreadable", $file);
            return $self;
        }
    }

    # Config::General Options
    my $orig    = $self->{orig};
       $orig = {} unless is_hash_ref($orig);
    my %options = (%{DEFAULT_CG_OPTS()}, %$orig); # Merge everything
       $options{'-ConfigFile'} = $file;
       $options{"-ConfigPath"} ||= [@dirs] if scalar(@dirs);
    $self->{options} = {%options};

    # Load
    return $self if $self->{noload};
    return $self->load;
}
sub default {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{default} = shift;
        return $self;
    }
    return $self->{default};
}
sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    return $self->{error};
}
sub file {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{file} = shift;
        return $self;
    }
    return $self->{file};
}
sub dirs {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{dirs} = shift;
        return $self;
    }
    return $self->{dirs};
}
sub pointer { shift->{pointer} }
sub load {
    my $self = shift;
    my $opts = $self->{options};
    $self->{error} = "";

    # Load
    my $cfg = eval { Config::General->new(%$opts) };
    return $self->error(sprintf("Can't load configuration from file \"%s\": %s", $self->file, $@)) if $@;
    return $self->error(sprintf("Configuration file \"%s\" did not return a Config::General object", $self->file))
        unless ref $cfg eq 'Config::General';
    my %config = $cfg->getall;
    my @files = $cfg->files;

    # Merge defaults
    my $defaults = $self->default || {};
    %config = (%$defaults, %config) if is_hash_ref($defaults) && scalar keys %$defaults;

    # Add system values
    $config{'_config_files'} = [@files];
    $config{'_config_loaded'} = scalar @files;

    # Set config data
    $self->{config} = {%config}; # hash data
    $self->pointer->data(clone($self->{config}));

    return $self;
}
sub config {
    my $self = shift;
    my $key  = shift;
    return undef unless $self->{config};
    return $self->{config} unless defined $key and length $key;
    return $self->{config}->{$key};
}
sub conf { goto &config }
sub get {
    my $self = shift;
    my $key = shift;
    return $self->pointer->get($key);
}
sub first {
    my $self = shift;
    return undef unless defined($_[0]) && length($_[0]);
    my $node = $self->pointer->get($_[0]);
    if (is_array_ref($node)) { # Array ref
        return exists($node->[0]) ? $node->[0] : undef;
    } elsif (is_value($node)) { # Scalar value
        return $node;
    }
    return undef;
}
sub latest {
    my $self = shift;
    return undef unless defined($_[0]) && length($_[0]);
    my $node = $self->pointer->get($_[0]);
    if (is_array_ref($node)) { # Array ref
        return exists($node->[0]) ? $node->[-1] : undef;
    } elsif (is_value($node)) { # Scalar value
        return $node;
    }
    return undef;
}
sub array {
    my $self = shift;
    return undef unless defined($_[0]) && length($_[0]);
    my $node = $self->pointer->get($_[0]);
    if (is_array_ref($node)) { # Array ref
        return $node;
    } elsif (defined($node)) {
        return [$node];
    }
    return [];
}
sub list { goto &array }
sub hash {
    my $self = shift;
    return undef unless defined($_[0]) && length($_[0]);
    my $node = $self->pointer->get($_[0]);
    return $node if is_hash_ref($node);
    return {};
}
sub object { goto &hash }

1;

__END__