File Coverage

blib/lib/Config/Find/Any.pm

Criterion	Covered	Total	%
statement	40	98	40.8
branch	8	62	12.9
condition			n/a
subroutine	12	23	52.1
pod	13	13	100.0
total	73	196	37.2

package Config::Find::Any;

use strict;
use warnings;

use Carp;
use File::Spec;
use File::Which;
use IO::File;

# private methods

sub _find {
    my ($class, $write, $global, @names)=@_;

    for my $n (@names) {
        my $fn;
        if ($n=~/^(.*?)\/(.*)$/) {
            my ($dir, $file)=($1, $2);
            $fn=$class->look_for_dir_file($dir, $file, $write, $global);
        } else {
            $fn=$class->look_for_file($n, $write, $global);
        }
        return $fn if defined $fn;
    }

    return undef;
}

sub _open {
    my ($class, $write, $global, $fn)=@_;

    if ($write) {
        $class->create_parent_dir($fn);
        return IO::File->new($fn, 'w');
    }

    defined($fn) ? IO::File->new($fn, 'r') : undef;
}

sub _install {
    my ($class, $orig, $write, $global, $fn)=@_;
    croak "install mode has to be 'write'" unless $write;

    my $oh=IO::File->new($orig, 'r')
        or croak "unable to open '$orig'";
    my $fh=$class->_open($write, $global, $fn)
        or croak "unable to create config file '$fn'";

    while(<$oh>) { $fh->print($_) }

    close $fh
        or die "unable to write config file '$fn'";
    close $oh
        or die "unable to read '$orig'";
    return $fn;
}

sub _temp_dir {
    my ($class, $name, $more_name, $scope)=@_;

    my $stemp=$class->system_temp;

    if ($scope eq 'global') {
        $class->my_catdir($stemp, $name, $more_name)
    } elsif ($scope eq 'user') {
        $class->my_catdir($stemp, $class->my_getlogin, $name, $more_name)
    } elsif ($scope eq 'app') {
        $class->my_catdir($class->app_dir($name), 'tmp', $more_name)
    } elsif ($scope eq 'process') {
        $class->my_catdir($stemp, $class->my_getlogin, $name, $$, $more_name)
    } else {
        croak "scope '$scope' is not valid for temp_dir method";
    }
}

# public methods, to be overridden

sub look_for_file {
    my $class=shift;
    die "unimplemented virtual method $class->look_for_file() called";
}

sub look_for_dir_file {
    my $class=shift;
    die "unimplemented virtual method $class->look_for_dir_file() called";
}

# public methods, inherited by sub-classes

sub guess_full_script_name {
    my $path = (File::Spec->splitpath($0))[1];
    if ($path eq '') {
        if (my $script = File::Which::which($0)) {
            return File::Spec->rel2abs($script);
        }
    }

    return File::Spec->rel2abs($0) if -e $0;

    carp "unable to determine script '$0' location";
}

sub guess_script_name {
    my $name;
    (undef, undef, $name)=File::Spec->splitpath($0);
    $name=~/^(.+)\..*$/ and return $1;
    return undef if $name eq '';
    return $name;
}

sub guess_script_dir {
    my $class=shift;
    my $script=$class->guess_full_script_name;
    my ($unit, $dir)=File::Spec->splitpath($script, 0);
    File::Spec->catpath($unit, $dir, '');
}

sub is_one_liner { return $0 eq '-e' }

sub add_extension {
    my ($class, $name, $ext)=@_;
    return $name if ($name=~/\./);
    return $name.'.'.$ext;
}

sub create_parent_dir {
    my ($class, $fn)=@_;
    my $parent=$class->parent_dir($fn);
    if (-e $parent) {
        -d $parent
            or croak "'$parent' exists but is not a directory";
        -W $parent
            or croak "not allowed to write on directory '$parent'";
    } else {
        $class->create_parent_dir($parent);
        mkdir $parent
            or die "unable to create directory '$parent' ($!)";
    }
}

sub parent_dir {
    my ($class, $dir)=@_;
    # print "creating dir $dir\n";
    my @dirs=File::Spec->splitdir($dir);
    pop(@dirs) eq '' and pop(@dirs);
    File::Spec->catfile(@dirs ? @dirs : File::Spec->rootdir);
}

sub create_dir {
    my ($class, $dir)=@_;
    if (-e $dir) {
        -d $dir or croak "'$dir' exists but is not a directory";
    } else {
        $class->create_parent_dir($dir);
        mkdir $dir
            or die "unable to create directory '$dir' ($!)";
    }
    $dir;
}

sub my_catfile {
    my $class=shift;
    pop @_ unless defined $_[-1];
    File::Spec->catfile(@_);
}

sub my_catdir {
    my $class=shift;
    pop @_ unless defined $_[-1];
    File::Spec->catdir(@_);
}

sub my_getlogin {
    my $login=getlogin();
    $login = '_UNKNOW_' unless defined $login;
    $login;
}

1;

__END__