File Coverage

File:local/lib/perl5/File/HomeDir.pm
Coverage:22.4%

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