File Coverage

lib/XT/Files.pm

Criterion	Covered	Total	%
statement	207	207	100.0
branch	81	82	98.7
condition	16	18	88.8
subroutine	37	37	100.0
pod	15	16	93.7
total	356	360	98.8

package XT::Files;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.002';

use Class::Tiny 1;

use Role::Tiny::With ();

Role::Tiny::With::with 'XT::Files::Role::Logger';

use Carp           ();
use File::Basename ();
use File::Find     ();
use Module::Load   ();
use Scalar::Util   ();
use version 0.77 ();

use XT::Files::File;

use constant MODULE_NAME_RX => qr{ ^ [A-Za-z_] [0-9A-Za-z_]* (?: :: [0-9A-Za-z_]+ )* $ }xs;    ## no critic (RegularExpressions::RequireLineBoundaryMatching)

#
# CLASS METHODS
#

sub BUILD {
    my ( $self, $args ) = @_;

    $self->{_excludes} = [];
    $self->{_file}     = {};

    if ( exists $args->{'-config'} ) {
        if ( defined $args->{'-config'} ) {
            $self->_load_config( $args->{'-config'} );
        }

        # -config exists but is not defined, no configuration requested
    }
    else {
        # We did not get "config => undef" and therefore try to load the
        # default config file
        $self->_load_default_config();
    }

    return;
}

{
    # The XT::Files singleton
    my $xtf;

    sub initialize {
        my $class = shift;

        Carp::croak( __PACKAGE__ . q{ is already initialized} ) if $class->_is_initialized;

        $xtf = $class->new(@_);
        return $xtf;
    }

    sub instance {
        my ($class) = @_;

        if ( !$class->_is_initialized ) {

            # ignore args
            $class->initialize;
        }

        return $xtf;
    }

    sub _is_initialized {
        my ($class) = @_;

        return 1 if defined $xtf;
        return;
    }
}

#
# OBJECT METHODS
#

sub plugin {
    my ( $self, $plugin_name, $plugin_version, $keyvals_ref ) = @_;

    my $plugin_pkg = $self->_expand_config_plugin_name($plugin_name);

    Module::Load::load($plugin_pkg);

    if ( defined $plugin_version ) {
        $self->log_fatal("Not a valid version '$plugin_version'") if !version::is_lax($plugin_version);
        $self->log_fatal( "$plugin_pkg version $plugin_version required--this is only version " . $plugin_pkg->VERSION ) if version->parse( $plugin_pkg->VERSION ) < version->parse($plugin_version);
    }

    $self->log_fatal("$plugin_pkg doesn't have a run method") if !$plugin_pkg->can('run');
    $self->log_fatal("$plugin_pkg doesn't have a new method") if !$plugin_pkg->can('new');

    my $plugin = $plugin_pkg->new( xtf => $self );

    $plugin->run($keyvals_ref);

    return;
}

sub files {
    my ($self) = @_;

    my $exclude_regex;
    my @excludes = @{ $self->{_excludes} };
    if (@excludes) {
        $exclude_regex = join q{|}, @excludes;
    }

    my @result;
  RESULT_FILE:
    for my $name ( sort keys %{ $self->{_file} } ) {

        # skip ignored files
        next RESULT_FILE if !defined $self->{_file}->{$name};

        # skip excluded files
        next RESULT_FILE if defined $exclude_regex && File::Basename::fileparse($name) =~ $exclude_regex;

        # skip non-existing files
        next RESULT_FILE if !-e $name;

        push @result, $self->{_file}->{$name};
    }

    return @result;
}

#
# File
#

sub bin_file {
    my ( $self, $name ) = @_;

    my $file = XT::Files::File->new( name => $name, is_script => 1 );
    $self->file( $name, $file );
    return;
}

sub file {
    my ( $self, $name, $file ) = @_;

    if ( @_ > 2 ) {
        if ( defined $file ) {
            $self->log_fatal(q{File is not of class 'XT::Files::File'}) if !defined Scalar::Util::blessed($file) || !$file->isa('XT::Files::File');
        }

        $self->{_file}->{$name} = $file;
    }

    return $self->{_file}->{$name};
}

sub ignore_file {
    my ( $self, $name ) = @_;

    $self->file( $name, undef );
    return;
}

sub module_file {
    my ( $self, $name ) = @_;

    my $file = XT::Files::File->new( name => $name, is_module => 1 );
    $self->file( $name, $file );
    return;
}

sub pod_file {
    my ( $self, $name ) = @_;

    my $file = XT::Files::File->new( name => $name, is_pod => 1 );
    $self->file( $name, $file );
    return;
}

sub remove_file {
    my ( $self, $name ) = @_;

    delete $self->{_file}->{$name};
    return;
}

sub test_file {
    my ( $self, $name ) = @_;

    my $file = XT::Files::File->new( name => $name, is_test => 1, is_script => 1 );
    $self->file( $name, $file );
    return;
}

#
# Directory
#

sub bin_dir {
    my ( $self, $name ) = @_;

    for my $file ( $self->_find_new_files($name) ) {
        $self->bin_file( $file, $name );
    }

    return;
}

sub module_dir {
    my ( $self, $name ) = @_;

    for my $file ( $self->_find_new_files($name) ) {
        if ( $file =~ m{ [.] pm $ }xsm ) {
            $self->module_file( $file, $name );
        }
        elsif ( $file =~ m{ [.] pod $ }xsm ) {
            $self->pod_file( $file, $name );
        }
    }

    return;
}

sub test_dir {
    my ( $self, $name ) = @_;

    for my $file ( $self->_find_new_files($name) ) {
        if ( $file =~ m{ [.] t $ }xsm ) {
            $self->test_file( $file, $name );
        }
    }

    return;
}

#
# Excludes
#

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

    push @{ $self->{_excludes} }, $exclude;
    return;
}

#
# PRIVATE METHODS
#

sub _expand_config_plugin_name {
    my ( $self, $plugin_name ) = @_;

    my $package_name = $plugin_name;
    if ( $package_name !~ s{ ^ = }{}xsm ) {
        $package_name = "XT::Files::Plugin::$plugin_name";
    }

    $self->log_fatal("'$plugin_name' is not a valid plugin name") if $package_name !~ MODULE_NAME_RX;

    return $package_name;
}

sub _find_new_files {
    my ( $self, $dir ) = @_;

    my @files;

    if ( !-d $dir ) {
        $self->log_debug("Directory $dir does not exist or is not a directory");
        return;
    }

    File::Find::find(
        {
            no_chdir => 1,
            wanted   => sub {
                return if -l $File::Find::name || !-f _;
                push @files, $File::Find::name;
            },
        },
        $dir,
    );

    @files = grep { !exists $self->{_file}->{$_} } @files;

    return @files;
}

sub _global_keyval {    ## no critic  (Subroutines::RequireFinalReturn)
    my ( $self, $key, $value ) = @_;

    if ( $key eq ':version' ) {
        $self->log_fatal("Not a valid version '$value'") if !version::is_lax($value);
        $self->log_fatal( __PACKAGE__ . " version $value required--this is only version " . __PACKAGE__->VERSION ) if version->parse( __PACKAGE__->VERSION ) < version->parse($value);
        return;
    }

    $self->log_fatal("Invalid entry '$key = $value'");
}

sub _load_config {
    my ( $self, $config ) = @_;

    my $type_section = 1;
    my $type_keyval  = 2;

    open my $fh, '<', $config or $self->log_fatal("Cannot read file '$config': $!");

    my $in_global_section = 1;
    my @lines;
    my $line_counter = 0;
  LINE:
    while ( defined( my $line = <$fh> ) ) {
        $line_counter++;

        # skip empty lines or comment
        next LINE if $line =~ m{ ^ \s* (?: [#;] | $ ) }xsm;

        # remove leading whitespace
        $line =~ s{ ^ \s* }{}xsm;

        # remove tailing whitespace
        $line =~ s{ \s* $ }{}xsm;

        if ( $line =~ m{ ^ \[ }xsm ) {
            $self->log_fatal("Syntax error in config on line $line_counter") if $line !~ m{ ^ \[ ( .+ ) \] $ }xsm;
            my $section = $1;    ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
            push @lines, [ $type_section, $line_counter, $section ];
            $in_global_section = 0;
            next LINE;
        }

        my ( $key, $value ) = split /\s*=\s*/xsm, $line, 2;
        $self->log_fatal("Syntax error in config on line $line_counter") if !defined $key || !defined $value || $key eq q{} || $value eq q{};
        #
        if ($in_global_section) {
            $self->_global_keyval( $key, $value );
            next LINE;
        }

        push @lines, [ $type_keyval, $line_counter, $key, $value ];
    }
    close $fh or $self->logger->log_fatal("Cannot read file '$config': $!");

    while (@lines) {
        my $section = ${ $lines[0] }[2];
        shift @lines;

        my @keyvals;
        my $plugin_version;

      LINE_KEYVAL:
        while (@lines) {
            last LINE_KEYVAL if $lines[0][0] == $type_section;

            if ( $lines[0][2] eq ':version' ) {
                $plugin_version = $lines[0][3];
            }
            else {
                push @keyvals, [ @{ $lines[0] }[ 2, 3 ] ];
            }

            shift @lines;
        }

        $self->plugin( $section, $plugin_version, \@keyvals );
    }

    return;
}

sub _load_default_config {
    my ($self) = @_;

    my $config;
    if ( exists $ENV{XT_FILES_DEFAULT_CONFIG_FILE} ) {
        $config = $ENV{XT_FILES_DEFAULT_CONFIG_FILE};
        $self->log_fatal("XT_FILES_DEFAULT_CONFIG_FILE points to non-existing default config file '$config'") if !-f $config;
    }
    else {

      FILE:
        for my $file ( '.xtfilesrc', 'xtfiles.ini' ) {
            next FILE if !-e $file;
            $self->log_fatal("Multiple default config files found: '$config' and '$file'") if defined $config;
            $config = $file;
        }

        if ( !defined $config ) {
            my $default_config = '[Default]';
            $config = \$default_config;
        }
    }

    return $self->_load_config($config);
}

1;

__END__