File: HomeDir.pm

package info (click to toggle)
grepmail 5.3111-4
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 2,420 kB
  • sloc: perl: 8,724; makefile: 6
file content (311 lines) | stat: -rw-r--r-- 7,595 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
#line 1
package File::HomeDir;

# See POD at end for documentation

use 5.008003;
use strict;
use warnings;
use Carp        ();
use Config      ();
use File::Spec  ();
use File::Which ();

# Globals
use vars qw{$VERSION @EXPORT @EXPORT_OK $IMPLEMENTED_BY};    ## no critic qw(AutomaticExportation)
use base qw(Exporter);

BEGIN
{
    $VERSION = '1.004';

    # Inherit manually
    require Exporter;
    @EXPORT    = qw{home};
    @EXPORT_OK = qw{
      home
      my_home
      my_desktop
      my_documents
      my_music
      my_pictures
      my_videos
      my_data
      my_dist_config
      my_dist_data
      users_home
      users_desktop
      users_documents
      users_music
      users_pictures
      users_videos
      users_data
    };
}

# Inlined Params::Util functions
sub _CLASS ($)    ## no critic qw(SubroutinePrototypes)
{
    (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
}

sub _DRIVER ($$)    ## no critic qw(SubroutinePrototypes)
{
    (defined _CLASS($_[0]) and eval "require $_[0]; 1" and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
}

# Platform detection
if ($IMPLEMENTED_BY)
{
    # Allow for custom HomeDir classes
    # Leave it as the existing value
}
elsif ($^O eq 'MSWin32')
{
    # All versions of Windows
    $IMPLEMENTED_BY = 'File::HomeDir::Windows';
}
elsif ($^O eq 'darwin')
{
    # 1st: try Mac::SystemDirectory by chansen
    if (eval "require Mac::SystemDirectory; 1")
    {
        $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa';
    }
    elsif (eval "require Mac::Files; 1")
    {
        # 2nd try Mac::Files: Carbon - unmaintained since 2006 except some 64bit fixes
        $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon';
    }
    else
    {
        # 3rd: fallback: pure perl
        $IMPLEMENTED_BY = 'File::HomeDir::Darwin';
    }
}
elsif ($^O eq 'MacOS')
{
    # Legacy Mac OS
    $IMPLEMENTED_BY = 'File::HomeDir::MacOS9';
}
elsif (File::Which::which('xdg-user-dir'))
{
    # freedesktop unixes
    $IMPLEMENTED_BY = 'File::HomeDir::FreeDesktop';
}
else
{
    # Default to Unix semantics
    $IMPLEMENTED_BY = 'File::HomeDir::Unix';
}

unless (_DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver'))
{
    Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY");
}

#####################################################################
# Current User Methods

sub my_home
{
    $IMPLEMENTED_BY->my_home;
}

sub my_desktop
{
    $IMPLEMENTED_BY->can('my_desktop')
      ? $IMPLEMENTED_BY->my_desktop
      : Carp::croak("The my_desktop method is not implemented on this platform");
}

sub my_documents
{
    $IMPLEMENTED_BY->can('my_documents')
      ? $IMPLEMENTED_BY->my_documents
      : Carp::croak("The my_documents method is not implemented on this platform");
}

sub my_music
{
    $IMPLEMENTED_BY->can('my_music')
      ? $IMPLEMENTED_BY->my_music
      : Carp::croak("The my_music method is not implemented on this platform");
}

sub my_pictures
{
    $IMPLEMENTED_BY->can('my_pictures')
      ? $IMPLEMENTED_BY->my_pictures
      : Carp::croak("The my_pictures method is not implemented on this platform");
}

sub my_videos
{
    $IMPLEMENTED_BY->can('my_videos')
      ? $IMPLEMENTED_BY->my_videos
      : Carp::croak("The my_videos method is not implemented on this platform");
}

sub my_data
{
    $IMPLEMENTED_BY->can('my_data')
      ? $IMPLEMENTED_BY->my_data
      : Carp::croak("The my_data method is not implemented on this platform");
}

sub my_dist_data
{
    my $params = ref $_[-1] eq 'HASH' ? pop : {};
    my $dist = pop or Carp::croak("The my_dist_data method requires an argument");
    my $data = my_data();

    # If datadir is not defined, there's nothing we can do: bail out
    # and return nothing...
    return undef unless defined $data;

    # On traditional unixes, hide the top-level directory
    my $var =
      $data eq home()
      ? File::Spec->catdir($data, '.perl', 'dist', $dist)
      : File::Spec->catdir($data, 'Perl',  'dist', $dist);

    # directory exists: return it
    return $var if -d $var;

    # directory doesn't exist: check if we need to create it...
    return undef unless $params->{create};

    # user requested directory creation
    require File::Path;
    File::Path::mkpath($var);
    return $var;
}

sub my_dist_config
{
    my $params = ref $_[-1] eq 'HASH' ? pop : {};
    my $dist = pop or Carp::croak("The my_dist_config method requires an argument");

    # not all platforms support a specific my_config() method
    my $config =
        $IMPLEMENTED_BY->can('my_config')
      ? $IMPLEMENTED_BY->my_config
      : $IMPLEMENTED_BY->my_documents;

    # If neither configdir nor my_documents is defined, there's
    # nothing we can do: bail out and return nothing...
    return undef unless defined $config;

    # On traditional unixes, hide the top-level dir
    my $etc =
      $config eq home()
      ? File::Spec->catdir($config, '.perl', $dist)
      : File::Spec->catdir($config, 'Perl',  $dist);

    # directory exists: return it
    return $etc if -d $etc;

    # directory doesn't exist: check if we need to create it...
    return undef unless $params->{create};

    # user requested directory creation
    require File::Path;
    File::Path::mkpath($etc);
    return $etc;
}

#####################################################################
# General User Methods

sub users_home
{
    $IMPLEMENTED_BY->can('users_home')
      ? $IMPLEMENTED_BY->users_home($_[-1])
      : Carp::croak("The users_home method is not implemented on this platform");
}

sub users_desktop
{
    $IMPLEMENTED_BY->can('users_desktop')
      ? $IMPLEMENTED_BY->users_desktop($_[-1])
      : Carp::croak("The users_desktop method is not implemented on this platform");
}

sub users_documents
{
    $IMPLEMENTED_BY->can('users_documents')
      ? $IMPLEMENTED_BY->users_documents($_[-1])
      : Carp::croak("The users_documents method is not implemented on this platform");
}

sub users_music
{
    $IMPLEMENTED_BY->can('users_music')
      ? $IMPLEMENTED_BY->users_music($_[-1])
      : Carp::croak("The users_music method is not implemented on this platform");
}

sub users_pictures
{
    $IMPLEMENTED_BY->can('users_pictures')
      ? $IMPLEMENTED_BY->users_pictures($_[-1])
      : Carp::croak("The users_pictures method is not implemented on this platform");
}

sub users_videos
{
    $IMPLEMENTED_BY->can('users_videos')
      ? $IMPLEMENTED_BY->users_videos($_[-1])
      : Carp::croak("The users_videos method is not implemented on this platform");
}

sub users_data
{
    $IMPLEMENTED_BY->can('users_data')
      ? $IMPLEMENTED_BY->users_data($_[-1])
      : Carp::croak("The users_data method is not implemented on this platform");
}

#####################################################################
# Legacy Methods

# Find the home directory of an arbitrary user
sub home (;$)    ## no critic qw(SubroutinePrototypes)
{
    # Allow to be called as a method
    if ($_[0] and $_[0] eq 'File::HomeDir')
    {
        shift();
    }

    # No params means my home
    return my_home() unless @_;

    # Check the param
    my $name = shift;
    if (!defined $name)
    {
        Carp::croak("Can't use undef as a username");
    }
    if (!length $name)
    {
        Carp::croak("Can't use empty-string (\"\") as a username");
    }

    # A dot also means my home
    ### Is this meant to mean File::Spec->curdir?
    if ($name eq '.')
    {
        return my_home();
    }

    # Now hand off to the implementor
    $IMPLEMENTED_BY->users_home($name);
}

1;

__END__

#line 721