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


line stmt bran cond sub pod time code
1             package Config::Find::Any;
2              
3             our $VERSION = '0.29';
4              
5 6     6   28 use strict;
  6         10  
  6         263  
6 6     6   68 use warnings;
  6         11  
  6         251  
7              
8 6     6   28 use Carp;
  6         8  
  6         398  
9 6     6   33 use File::Spec;
  6         6  
  6         118  
10 6     6   24 use File::Which;
  6         6  
  6         309  
11 6     6   3647 use IO::File;
  6         44690  
  6         8407  
12              
13             # private methods
14              
15             sub _find {
16 6     6   11 my ($class, $write, $global, @names)=@_;
17            
18 6         10 for my $n (@names) {
19 8         4 my $fn;
20 8 50       17 if ($n=~/^(.*?)\/(.*)$/) {
21 0         0 my ($dir, $file)=($1, $2);
22 0         0 $fn=$class->look_for_dir_file($dir, $file, $write, $global);
23             } else {
24 8         21 $fn=$class->look_for_file($n, $write, $global);
25             }
26 8 100       27 return $fn if defined $fn;
27             }
28              
29 1         5 return undef;
30             }
31              
32             sub _open {
33 0     0   0 my ($class, $write, $global, $fn)=@_;
34            
35 0 0       0 if ($write) {
36 0         0 $class->create_parent_dir($fn);
37 0         0 return IO::File->new($fn, 'w');
38             }
39              
40 0 0       0 defined($fn) ? IO::File->new($fn, 'r') : undef;
41             }
42              
43             sub _install {
44 0     0   0 my ($class, $orig, $write, $global, $fn)=@_;
45 0 0       0 croak "install mode has to be 'write'" unless $write;
46              
47 0 0       0 my $oh=IO::File->new($orig, 'r')
48             or croak "unable to open '$orig'";
49 0 0       0 my $fh=$class->_open($write, $global, $fn)
50             or croak "unable to create config file '$fn'";
51            
52 0         0 while(<$oh>) { $fh->print($_) }
  0         0  
53            
54 0 0       0 close $fh
55             or die "unable to write config file '$fn'";
56 0 0       0 close $oh
57             or die "unable to read '$orig'";
58 0         0 return $fn;
59             }
60              
61             sub _temp_dir {
62 0     0   0 my ($class, $name, $more_name, $scope)=@_;
63              
64 0         0 my $stemp=$class->system_temp;
65              
66 0 0       0 if ($scope eq 'global') {
    0          
    0          
    0          
67 0         0 $class->my_catdir($stemp, $name, $more_name)
68             } elsif ($scope eq 'user') {
69 0         0 $class->my_catdir($stemp, $class->my_getlogin, $name, $more_name)
70             } elsif ($scope eq 'app') {
71 0         0 $class->my_catdir($class->app_dir($name), 'tmp', $more_name)
72             } elsif ($scope eq 'process') {
73 0         0 $class->my_catdir($stemp, $class->my_getlogin, $name, $$, $more_name)
74             } else {
75 0         0 croak "scope '$scope' is not valid for temp_dir method";
76             }
77             }
78              
79             # public methods, to be overridden
80              
81             sub look_for_file {
82 0     0 1 0 my $class=shift;
83 0         0 die "unimplemented virtual method $class->look_for_file() called";
84             }
85              
86             sub look_for_dir_file {
87 0     0 1 0 my $class=shift;
88 0         0 die "unimplemented virtual method $class->look_for_dir_file() called";
89             }
90              
91             # public methods, inherited by sub-classes
92              
93             sub guess_full_script_name {
94 14     14 1 116 my $path = (File::Spec->splitpath($0))[1];
95 14 50       24 if ($path eq '') {
96 0 0       0 if (my $script = File::Which::which($0)) {
97 0         0 return File::Spec->rel2abs($script);
98             }
99             }
100              
101 14 50       287 return File::Spec->rel2abs($0) if -e $0;
102              
103 0         0 carp "unable to determine script '$0' location";
104             }
105              
106             sub guess_script_name {
107 0     0 1 0 my $name;
108 0         0 (undef, undef, $name)=File::Spec->splitpath($0);
109 0 0       0 $name=~/^(.+)\..*$/ and return $1;
110 0 0       0 return undef if $name eq '';
111 0         0 return $name;
112             }
113              
114             sub guess_script_dir {
115 14     14 1 7 my $class=shift;
116 14         26 my $script=$class->guess_full_script_name;
117 14         84 my ($unit, $dir)=File::Spec->splitpath($script, 0);
118 14         70 File::Spec->catpath($unit, $dir, '');
119             }
120              
121 7     7 1 22 sub is_one_liner { return $0 eq '-e' }
122              
123             sub add_extension {
124 7     7 1 7 my ($class, $name, $ext)=@_;
125 7 50       14 return $name if ($name=~/\./);
126 7         18 return $name.'.'.$ext;
127             }
128              
129             sub create_parent_dir {
130 0     0 1 0 my ($class, $fn)=@_;
131 0         0 my $parent=$class->parent_dir($fn);
132 0 0       0 if (-e $parent) {
133 0 0       0 -d $parent
134             or croak "'$parent' exists but is not a directory";
135 0 0       0 -W $parent
136             or croak "not allowed to write on directory '$parent'";
137             } else {
138 0         0 $class->create_parent_dir($parent);
139 0 0       0 mkdir $parent
140             or die "unable to create directory '$parent' ($!)";
141             }
142             }
143              
144             sub parent_dir {
145 14     14 1 13 my ($class, $dir)=@_;
146             # print "creating dir $dir\n";
147 14         57 my @dirs=File::Spec->splitdir($dir);
148 14 50       29 pop(@dirs) eq '' and pop(@dirs);
149 14 50       151 File::Spec->catfile(@dirs ? @dirs : File::Spec->rootdir);
150             }
151              
152             sub create_dir {
153 0     0 1   my ($class, $dir)=@_;
154 0 0         if (-e $dir) {
155 0 0         -d $dir or croak "'$dir' exists but is not a directory";
156             } else {
157 0           $class->create_parent_dir($dir);
158 0 0         mkdir $dir
159             or die "unable to create directory '$dir' ($!)";
160             }
161 0           $dir;
162             }
163              
164             sub my_catfile {
165 0     0 1   my $class=shift;
166 0 0         pop @_ unless defined $_[-1];
167 0           File::Spec->catfile(@_);
168             }
169              
170             sub my_catdir {
171 0     0 1   my $class=shift;
172 0 0         pop @_ unless defined $_[-1];
173 0           File::Spec->catdir(@_);
174             }
175              
176             sub my_getlogin {
177 0     0 1   my $login=getlogin();
178 0 0         $login = '_UNKNOW_' unless defined $login;
179 0           $login;
180             }
181              
182             1;
183              
184             __END__