File Coverage

blib/lib/File/XDG.pm

Criterion	Covered	Total	%
statement	105	128	82.0
branch	42	60	70.0
condition	15	41	36.5
subroutine	25	26	96.1
pod	13	13	100.0
total	200	268	74.6

package File::XDG;

use strict;
use warnings;
use Carp ();
use Config;
use Ref::Util qw( is_coderef is_arrayref );
use if $^O eq 'MSWin32', 'Win32';

# ABSTRACT: Basic implementation of the XDG base directory specification
our $VERSION = '1.00_01'; # TRIAL VERSION
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)




sub new {
    my $class = shift;
    my %args = (@_);

    my $name = delete $args{name};
    Carp::croak('application name required') unless defined $name;

    my $api = delete $args{api};
    $api = 0 unless defined $api;
    Carp::croak("Unsupported api = $api") unless $api == 0 || $api == 1;

    my $path_class = delete $args{path_class};

    unless(defined $path_class) {
      if($api >= 1) {
        $path_class = 'Path::Tiny';
      } else {
        $path_class = 'Path::Class';
      }
    }

    my $file_class = $path_class eq 'Path::Class' ? 'Path::Class::File' : $path_class;
    my $dir_class  = $path_class eq 'Path::Class' ? 'Path::Class::Dir'  : $path_class;

    if(is_coderef($path_class))
    {
      $dir_class = $file_class = $path_class;
    }
    elsif(is_arrayref($path_class))
    {
      ($file_class, $dir_class) = @$path_class;
    }
    elsif($path_class eq 'Path::Tiny')
    {
      require Path::Tiny;
    }
    elsif($path_class eq 'Path::Class')
    {
      require Path::Class::File;
      require Path::Class::Dir;
    }
    elsif($path_class eq 'File::Spec')
    {
      require File::Spec;
      $file_class = sub { File::Spec->catfile(@_) };
      $dir_class  = sub { File::Spec->catdir(@_) };
    }
    else
    {
      Carp::croak("Unknown path class: $path_class");
    }

    my $strict = delete $args{strict};
    Carp::croak("XDG base directory specification cannot strictly implemented on Windows")
      if $^O eq 'MSWin32' && $strict;

    Carp::croak("unknown arguments: @{[ sort keys %args ]}") if %args;

    my $self = bless {
        name       => $name,
        api        => $api,
        file_class => $file_class,
        dir_class  => $dir_class,
        strict     => $strict,
        runtime    => $ENV{XDG_RUNTIME_DIR},
    }, $class;

    if($^O eq 'MSWin32') {
        my $local = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA(), 1);
        $self->{home}        = $local;
        $self->{data}        = $ENV{XDG_DATA_HOME}   || "$local\\.local\\share\\";
        $self->{cache}       = $ENV{XDG_CACHE_HOME}  || "$local\\.cache\\";
        $self->{config}      = $ENV{XDG_CONFIG_HOME} || "$local\\.config\\";
        $self->{state}       = $ENV{XDG_STATE_HOME}  || "$local\\.state\\";
        $self->{data_dirs}   = $ENV{XDG_DATA_DIRS}   || '';
        $self->{config_dirs} = $ENV{XDG_CONFIG_DIRS} || '';
    } else {
        my $home = $ENV{HOME} || [getpwuid($>)]->[7];
        $self->{home}        = $home;
        $self->{data}        = $ENV{XDG_DATA_HOME}   || "$home/.local/share/";
        $self->{cache}       = $ENV{XDG_CACHE_HOME}  || "$home/.cache/";
        $self->{state}       = $ENV{XDG_STATE_HOME}  || "$home/.state/";
        $self->{config}      = $ENV{XDG_CONFIG_HOME} || "$home/.config/";
        $self->{data_dirs}   = $ENV{XDG_DATA_DIRS}   || '/usr/local/share:/usr/share';
        $self->{config_dirs} = $ENV{XDG_CONFIG_DIRS} || '/etc/xdg';
    }

    return $self;
}

sub _dir {
  my $self = shift;
  is_coderef($self->{dir_class})
    ? $self->{dir_class}->(@_)
    : $self->{dir_class}->new(@_);
}

sub _file {
  my $self = shift;
  is_coderef($self->{dir_class})
    ? $self->{file_class}->(@_)
    : $self->{file_class}->new(@_);
}

sub _dirs {
    my($self, $type) = @_;
    return $self->{"${type}_dirs"} if exists $self->{"${type}_dirs"};
    Carp::croak('invalid _dirs requested');
}

sub _lookup_file {
    my ($self, $type, @subpath) = @_;

    Carp::croak('subpath not specified') unless @subpath;
    Carp::croak("invalid type: $type") unless defined $self->{$type};

    my @dirs = ($self->{$type}, split(/\Q$Config{path_sep}\E/, $self->_dirs($type)));
    my @paths = map { $self->_file($_, @subpath) } @dirs;
    my ($match) = grep { -f $_ } @paths;

    return $match;
}


sub data_home {
    my $self = shift;
    my $xdg = $self->{data};
    return $self->_dir($xdg, $self->{name});
}


sub config_home {
    my $self = shift;
    my $xdg = $self->{config};
    return $self->_dir($xdg, $self->{name});
}


sub cache_home {
    my $self = shift;
    my $xdg = $self->{cache};
    return $self->_dir($xdg, $self->{name});
}


sub state_home {
  my $self = shift;
  return $self->_dir($self->{state}, $self->{name});
}


sub runtime_home
{
  my($self) = @_;
  my $base = $self->_runtime_dir;
  defined $base ? $self->_dir($base, $self->{name}) : undef;
}

sub _runtime_dir
{
  my($self) = @_;
  if(defined $self->{runtime})
  {
    return $self->{runtime};
  }

  # the spec says only to look for the environment variable
  return undef if $self->{strict};

  my @maybe;

  if($^O eq 'linux')
  {
    push @maybe, "/run/user/$<";
  }

  foreach my $maybe (@maybe)
  {
    # if we are going rogue and trying to find the runtime dir
    # on our own, then we hould at least check that the directory
    # fufills the requirements of the spec: directory, owned by
    # us, with permission of 0700.
    next unless -d $maybe;
    next unless -o $maybe;
    my $perm = [stat $maybe]->[2] & oct('0777');
    next unless $perm == oct('0700');
    return $maybe;
  }

  return undef;
}


sub data_dirs {
    return shift->_dirs('data');
}


sub data_dirs_list {
    my $self = shift;
    return map { $self->_dir($_) } split /\Q$Config{path_sep}\E/, $self->data_dirs;
}


sub config_dirs {
    return shift->_dirs('config');
}


sub config_dirs_list {
    my $self = shift;
    return map { $self->_dir($_) } split /\Q$Config{path_sep}\E/, $self->config_dirs;
}


sub exe_dir
{
  my($self) = @_;
  -d "@{[ $self->{home} ]}/.local/bin"
  ? $self->_dir($self->{home}, '.local', 'bin')
  : undef;
}


sub lookup_data_file {
    my ($self, @subpath) = @_;
    unshift @subpath, $self->{name} if $self->{api} >= 1;
    return $self->_lookup_file('data', @subpath);
}


sub lookup_config_file {
    my ($self, @subpath) = @_;
    unshift @subpath, $self->{name} if $self->{api} >= 1;
    return $self->_lookup_file('config', @subpath);
}


1;

__END__