File Coverage

blib/lib/File/HomeDir.pm
Criterion Covered Total %
statement 47 77 61.0
branch 15 66 22.7
condition 4 9 44.4
subroutine 20 29 68.9
pod 17 17 100.0
total 103 198 52.0


line stmt bran cond sub pod time code
1             package File::HomeDir;
2              
3             # See POD at end for documentation
4              
5 7     7   422983 use 5.008003;
  7         68  
6 7     7   40 use strict;
  7         15  
  7         184  
7 7     7   36 use warnings;
  7         15  
  7         237  
8 7     7   59 use Carp ();
  7         15  
  7         140  
9 7     7   36 use Config ();
  7         16  
  7         202  
10 7     7   42 use File::Spec ();
  7         14  
  7         120  
11 7     7   3034 use File::Which ();
  7         7156  
  7         219  
12              
13             # Globals
14 7     7   48 use vars qw{$VERSION @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; ## no critic qw(AutomaticExportation)
  7         15  
  7         541  
15 7     7   47 use base qw(Exporter);
  7         16  
  7         1180  
16              
17             BEGIN
18             {
19 7     7   28 $VERSION = '1.004';
20              
21             # Inherit manually
22 7         40 require Exporter;
23 7         22 @EXPORT = qw{home};
24 7         10231 @EXPORT_OK = qw{
25             home
26             my_home
27             my_desktop
28             my_documents
29             my_music
30             my_pictures
31             my_videos
32             my_data
33             my_dist_config
34             my_dist_data
35             users_home
36             users_desktop
37             users_documents
38             users_music
39             users_pictures
40             users_videos
41             users_data
42             };
43             }
44              
45             # Inlined Params::Util functions
46             sub _CLASS ($) ## no critic qw(SubroutinePrototypes)
47             {
48 7 50 33 7   540 (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
49             }
50              
51             sub _DRIVER ($$) ## no critic qw(SubroutinePrototypes)
52             {
53 7 50 33 7   24 (defined _CLASS($_[0]) and eval "require $_[0]; 1" and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
54             }
55              
56             # Platform detection
57             if ($IMPLEMENTED_BY)
58             {
59             # Allow for custom HomeDir classes
60             # Leave it as the existing value
61             }
62             elsif ($^O eq 'MSWin32')
63             {
64             # All versions of Windows
65             $IMPLEMENTED_BY = 'File::HomeDir::Windows';
66             }
67             elsif ($^O eq 'darwin')
68             {
69             # 1st: try Mac::SystemDirectory by chansen
70             if (eval "require Mac::SystemDirectory; 1")
71             {
72             $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa';
73             }
74             elsif (eval "require Mac::Files; 1")
75             {
76             # 2nd try Mac::Files: Carbon - unmaintained since 2006 except some 64bit fixes
77             $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon';
78             }
79             else
80             {
81             # 3rd: fallback: pure perl
82             $IMPLEMENTED_BY = 'File::HomeDir::Darwin';
83             }
84             }
85             elsif ($^O eq 'MacOS')
86             {
87             # Legacy Mac OS
88             $IMPLEMENTED_BY = 'File::HomeDir::MacOS9';
89             }
90             elsif (File::Which::which('xdg-user-dir'))
91             {
92             # freedesktop unixes
93             $IMPLEMENTED_BY = 'File::HomeDir::FreeDesktop';
94             }
95             else
96             {
97             # Default to Unix semantics
98             $IMPLEMENTED_BY = 'File::HomeDir::Unix';
99             }
100              
101             unless (_DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver'))
102             {
103             Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY");
104             }
105              
106             #####################################################################
107             # Current User Methods
108              
109             sub my_home
110             {
111 6     6 1 5258 $IMPLEMENTED_BY->my_home;
112             }
113              
114             sub my_desktop
115             {
116 3 50   3 1 3572 $IMPLEMENTED_BY->can('my_desktop')
117             ? $IMPLEMENTED_BY->my_desktop
118             : Carp::croak("The my_desktop method is not implemented on this platform");
119             }
120              
121             sub my_documents
122             {
123 3 50   3 1 3017 $IMPLEMENTED_BY->can('my_documents')
124             ? $IMPLEMENTED_BY->my_documents
125             : Carp::croak("The my_documents method is not implemented on this platform");
126             }
127              
128             sub my_music
129             {
130 3 50   3 1 3480 $IMPLEMENTED_BY->can('my_music')
131             ? $IMPLEMENTED_BY->my_music
132             : Carp::croak("The my_music method is not implemented on this platform");
133             }
134              
135             sub my_pictures
136             {
137 3 50   3 1 3833 $IMPLEMENTED_BY->can('my_pictures')
138             ? $IMPLEMENTED_BY->my_pictures
139             : Carp::croak("The my_pictures method is not implemented on this platform");
140             }
141              
142             sub my_videos
143             {
144 3 50   3 1 3514 $IMPLEMENTED_BY->can('my_videos')
145             ? $IMPLEMENTED_BY->my_videos
146             : Carp::croak("The my_videos method is not implemented on this platform");
147             }
148              
149             sub my_data
150             {
151 3 50   3 1 3484 $IMPLEMENTED_BY->can('my_data')
152             ? $IMPLEMENTED_BY->my_data
153             : Carp::croak("The my_data method is not implemented on this platform");
154             }
155              
156             sub my_dist_data
157             {
158 0 0   0 1 0 my $params = ref $_[-1] eq 'HASH' ? pop : {};
159 0 0       0 my $dist = pop or Carp::croak("The my_dist_data method requires an argument");
160 0         0 my $data = my_data();
161              
162             # If datadir is not defined, there's nothing we can do: bail out
163             # and return nothing...
164 0 0       0 return undef unless defined $data;
165              
166             # On traditional unixes, hide the top-level directory
167 0 0       0 my $var =
168             $data eq home()
169             ? File::Spec->catdir($data, '.perl', 'dist', $dist)
170             : File::Spec->catdir($data, 'Perl', 'dist', $dist);
171              
172             # directory exists: return it
173 0 0       0 return $var if -d $var;
174              
175             # directory doesn't exist: check if we need to create it...
176 0 0       0 return undef unless $params->{create};
177              
178             # user requested directory creation
179 0         0 require File::Path;
180 0         0 File::Path::mkpath($var);
181 0         0 return $var;
182             }
183              
184             sub my_dist_config
185             {
186 0 0   0 1 0 my $params = ref $_[-1] eq 'HASH' ? pop : {};
187 0 0       0 my $dist = pop or Carp::croak("The my_dist_config method requires an argument");
188              
189             # not all platforms support a specific my_config() method
190 0 0       0 my $config =
191             $IMPLEMENTED_BY->can('my_config')
192             ? $IMPLEMENTED_BY->my_config
193             : $IMPLEMENTED_BY->my_documents;
194              
195             # If neither configdir nor my_documents is defined, there's
196             # nothing we can do: bail out and return nothing...
197 0 0       0 return undef unless defined $config;
198              
199             # On traditional unixes, hide the top-level dir
200 0 0       0 my $etc =
201             $config eq home()
202             ? File::Spec->catdir($config, '.perl', $dist)
203             : File::Spec->catdir($config, 'Perl', $dist);
204              
205             # directory exists: return it
206 0 0       0 return $etc if -d $etc;
207              
208             # directory doesn't exist: check if we need to create it...
209 0 0       0 return undef unless $params->{create};
210              
211             # user requested directory creation
212 0         0 require File::Path;
213 0         0 File::Path::mkpath($etc);
214 0         0 return $etc;
215             }
216              
217             #####################################################################
218             # General User Methods
219              
220             sub users_home
221             {
222 0 0   0 1 0 $IMPLEMENTED_BY->can('users_home')
223             ? $IMPLEMENTED_BY->users_home($_[-1])
224             : Carp::croak("The users_home method is not implemented on this platform");
225             }
226              
227             sub users_desktop
228             {
229 0 0   0 1 0 $IMPLEMENTED_BY->can('users_desktop')
230             ? $IMPLEMENTED_BY->users_desktop($_[-1])
231             : Carp::croak("The users_desktop method is not implemented on this platform");
232             }
233              
234             sub users_documents
235             {
236 0 0   0 1 0 $IMPLEMENTED_BY->can('users_documents')
237             ? $IMPLEMENTED_BY->users_documents($_[-1])
238             : Carp::croak("The users_documents method is not implemented on this platform");
239             }
240              
241             sub users_music
242             {
243 0 0   0 1 0 $IMPLEMENTED_BY->can('users_music')
244             ? $IMPLEMENTED_BY->users_music($_[-1])
245             : Carp::croak("The users_music method is not implemented on this platform");
246             }
247              
248             sub users_pictures
249             {
250 0 0   0 1 0 $IMPLEMENTED_BY->can('users_pictures')
251             ? $IMPLEMENTED_BY->users_pictures($_[-1])
252             : Carp::croak("The users_pictures method is not implemented on this platform");
253             }
254              
255             sub users_videos
256             {
257 0 0   0 1 0 $IMPLEMENTED_BY->can('users_videos')
258             ? $IMPLEMENTED_BY->users_videos($_[-1])
259             : Carp::croak("The users_videos method is not implemented on this platform");
260             }
261              
262             sub users_data
263             {
264 0 0   0 1 0 $IMPLEMENTED_BY->can('users_data')
265             ? $IMPLEMENTED_BY->users_data($_[-1])
266             : Carp::croak("The users_data method is not implemented on this platform");
267             }
268              
269             #####################################################################
270             # Legacy Methods
271              
272             # Find the home directory of an arbitrary user
273             sub home (;$) ## no critic qw(SubroutinePrototypes)
274             {
275             # Allow to be called as a method
276 3 50 66 3 1 13822 if ($_[0] and $_[0] eq 'File::HomeDir')
277             {
278 0         0 shift();
279             }
280              
281             # No params means my home
282 3 100       15 return my_home() unless @_;
283              
284             # Check the param
285 2         7 my $name = shift;
286 2 100       10 if (!defined $name)
287             {
288 1         202 Carp::croak("Can't use undef as a username");
289             }
290 1 50       6 if (!length $name)
291             {
292 0         0 Carp::croak("Can't use empty-string (\"\") as a username");
293             }
294              
295             # A dot also means my home
296             ### Is this meant to mean File::Spec->curdir?
297 1 50       5 if ($name eq '.')
298             {
299 0         0 return my_home();
300             }
301              
302             # Now hand off to the implementor
303 1         12 $IMPLEMENTED_BY->users_home($name);
304             }
305              
306             1;
307              
308             __END__