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

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.006';

    # 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__