File Coverage

blib/lib/Config/PFiles/Path.pm

Criterion	Covered	Total	%
statement	87	92	94.5
branch	22	26	84.6
condition	10	13	76.9
subroutine	17	17	100.0
pod	1	1	100.0
total	137	149	91.9

# --8<--8<--8<--8<--
#
# Copyright (C) 2007 Smithsonian Astrophysical Observatory
#
# This file is part of Config::PFiles::Path
#
# Config::PFiles::Path is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package Config::PFiles::Path;

use strict;
use warnings;

use Symbol;
use Carp;
use Sub::Uplevel;

our $VERSION = '0.02';

use overload '""' => '_export' ;

my %is_mutator
  = map { $_ => 1 } qw( _append _prepend _replace _remove );

our $AUTOLOAD;

# allow the user to do thing when loading the package
sub import {

    my $package = shift;

    return unless @_;

    my $method = shift;

    croak( "Can't call method '$method' in this context\n" )
      unless $is_mutator{ "_$method" };

    $AUTOLOAD = $method;
    uplevel 1, \&AUTOLOAD, $package, @_;
}

sub AUTOLOAD {
    (my $method = our $AUTOLOAD) =~ s/.*:://;

    # we don't have a DESTROY method, so ignore it.
    return if $method =~ /DESTROY/;

    my $imethod = '_' . $method;

    my $subref = *{qualify_to_ref($imethod,__PACKAGE__)}{CODE};

    # make sure it's an existing method
    croak( qq{Can't locate object method "$method" via package "},
	   __PACKAGE__, q{"} )
      if $method =~ /^_/ || ! defined $subref;


    # is this an object invocation?
    if ( ref $_[0] && $_[0]->isa(__PACKAGE__) )
    {
	goto &$imethod;
    }

    # nope.  create default object based on $ENV{PFILES} and replace
    # the class name in the argument list with the new object
    my $package = shift;
    my $env = $package->new( $ENV{PFILES} );
    unshift @_, $env;


    # if the method will alter the path, make sure to update $ENV{PFILES}
    # after it has been run
    if ( $is_mutator{$imethod} )
    {
	# respect calling context
	my $wantarray = wantarray();

	# void
	if ( ! defined $wantarray )
	{
	    uplevel 1, $subref, @_;
	    $ENV{PFILES} = $env->_export;
	    return;
	}

	# list
	elsif ( $wantarray)
	{
	    my @results = uplevel 1, $subref, @_;
	    $ENV{PFILES} = $env->_export;
	    return @results;
	}

	# scalar
	else
	{
	    my $result = uplevel 1, $subref, @_;
	    $ENV{PFILES} = $env->_export;
	    return $result;
	}
    }

    # nope, just execute the method
    else
    {
	goto &$imethod;
    }
}

sub new {
    my ( $class, $pfiles ) = @_;

    my $self = bless {}, $class;

    $self->__init( $pfiles );

    return $self;
}

sub __init {
    my ( $self, $pfiles ) = @_;

    $pfiles ||= q{};

    my %dirs;
    @dirs{ qw( RW RO ) } =
      $pfiles =~ /^
                  ([^;]*)    # grab everything that's not a semicolon (RW)
                  (?:|;(.*)) # and everything that's after a semicolon (RO)
                  $/x;

    croak( "illegal path: too many semi-colons: $pfiles\n" )
      if defined $dirs{RO} && $dirs{RO} =~ /;/;

    # split and store non-empty paths
    $self->{$_} = [ grep { $_ ne '' } split( /:/, $dirs{$_} || q{} ) ]
      for qw( RW RO );

    return;
}

sub __check_set {
    my ( $dir_set ) = shift;

    my $match;
    unless ( ($match ) = $dir_set =~ /^(RW|RO)$/i )
    {
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	croak( "illegal value for directory set: $dir_set\n" )
    }

    return uc($match);
}

sub _append {
    my ( $self, $dir_set, @dirs ) = @_;

    push @{$self->{__check_set($dir_set)}}, @dirs;

    return;
}

sub _prepend {
    my ( $self, $dir_set, @dirs ) = @_;

    unshift @{$self->{__check_set($dir_set)}}, @dirs;

    return;
}

sub _extract {
    my ( $self, $dir_set ) = @_;

    return @{$self->{__check_set($dir_set)}};
}

sub _replace {
    my ( $self, $dir_set, @dirs ) = @_;

    $dir_set = __check_set($dir_set);

    my @old = @{$self->{$dir_set}};

    $self->{$dir_set} = [ @dirs ];

    return @old
      if defined wantarray;

    return;
}

sub _remove {
    my ( $self, $dir_set ) = @_;

    return $self->replace( $dir_set );
}

sub _export {
    my ( $self ) = @_;

    # join together the non-empty directories in the sets;
    my ( $rw, $ro ) =
      map { join( q{:}, grep { $_ ne q{} } @{$self->{$_}} ) }
	qw( RW RO );

    # construct a rational path
    return
          $rw eq q{} ? ";$ro"
	: $ro eq q{} ?   $rw
	:              "$rw;$ro";
}

1;

__END__