File Coverage

blib/lib/Config/PFiles/Path.pm

Criterion	Covered	Total	%
statement	88	93	94.6
branch	23	26	88.4
condition	10	13	76.9
subroutine	18	18	100.0
pod	1	1	100.0
total	140	151	92.7

package Config::PFiles::Path;

# ABSTRACT: manipulate PFILES path for IRAF Compatible parameter files

use 5.008009;

use strict;
use warnings;

use Symbol ();
use Sub::Uplevel ();

our $VERSION = '0.04';

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

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

our $AUTOLOAD;










sub _croak {
    require Carp;
    goto &Carp::croak;
}

# 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;
    Sub::Uplevel::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 = *{Symbol::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 )
        {
            Sub::Uplevel::uplevel( 1, $subref, @_ );
            $ENV{PFILES} = $env->_export;
            return;
        }

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

        # scalar
        else
        {
            my $result = Sub::Uplevel::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;

#
# This file is part of Config-PFiles-Path
#
# This software is Copyright (c) 2007 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__