File Coverage

blib/lib/Module/PortablePath.pm

Criterion	Covered	Total	%
statement	21	95	22.1
branch	1	22	4.5
condition	0	14	0.0
subroutine	7	11	63.6
pod	2	2	100.0
total	31	144	21.5

#########
# Author:        rmp
# Maintainer:    rmp
# Created:       2005-02-14
# Last Modified: $Date: 2008-02-28$
# Id:            $Id$
# Source:        $Source$
# $HeadURL$
#
package Module::PortablePath;
use strict;
use warnings;
use Sys::Hostname;
use Config::IniFiles;
use Carp;
use English qw(-no_match_vars);

our $VERSION = q[0.17];
our $CONFIGS = {
		default => map { m{([[:lower:][:digit:]_./]+)}smix } ($ENV{MODULE_PORTABLEPATH_CONF} || q[/etc/perlconfig.ini]),
	       };

sub config {
  my $cfgfile  = $CONFIGS->{'default'};
  my $hostname = hostname() || q[];

  for my $k (sort { length $a <=> length $b } keys %{$CONFIGS}) {
    if($hostname =~ /$k/smx) {
      $cfgfile = $CONFIGS->{$k};
      last;
    }
  }

  my $config;
  if(-f $cfgfile) {
    $config = Config::IniFiles->new(
				    -file => $cfgfile,
				   );
  } else {
    $config = Config::IniFiles->new();
  }

  return $config;
}

sub import {
  my ($pkg, @args) = @_;
  if(!scalar @args) {
    return;
  }

  my $config = config();
  $pkg->_import_libs($config, @args);
  $pkg->_import_ldlibs($config, @args);

  return;
}

sub _import_libs {
  my ($pkg, $config, @args) = @_;
  my $forward      = {};
  my $reverse      = {};

  for my $param ($config->Parameters('libs')) {
    for my $v (split /[,\s;:]+/smx, $config->val('libs', $param)||q[]) {
      $reverse->{$v} = $param;
      unshift @{$forward->{$param}}, $v;
    }
  }

  my $seentags = {};
  for my $i (@INC) {
    if(!$reverse->{$i}) {
      next;
    }

    my ($tag) = $reverse->{$i} =~ /([[:lower:]]+)/smx;
    $seentags->{$tag} = $reverse->{$i};
  }

  for my $a (@args) {
    if(!$forward->{$a}) {
      carp qq[Use of unknown tag "$a"];
    }
    for my $i (@{$forward->{$a}}) {
      my ($tag) = $reverse->{$i} =~ /([[:lower:]]+)/smx;
      if($seentags->{$tag} && ($seentags->{$tag} ne $reverse->{$i})) {
	carp qq[Import of tag "$a" may clash with tag "$seentags->{$tag}"];
      }
      unshift @INC, $i;
    }
  }
  return;
}

sub _import_ldlibs {
  my ($pkg, $config, @args) = @_;
  my $forward      = {};
  my $reverse      = {};
  my @LDLIBS       = split /:/smx, $ENV{LD_LIBRARY_PATH}||q[];

  for my $param ($config->Parameters('ldlibs')) {
    for my $v (split /[,\s;:]+/smx, $config->val('ldlibs', $param) || q[]) {
      $reverse->{$v} = $param;
      unshift @{$forward->{$param}}, $v;
    }
  }

  my $seentags = {};
  for my $i (@LDLIBS) {
    if(!$reverse->{$i}) {
      next;
    }
    my ($tag) = $reverse->{$i} =~ /([[:lower:]]+)/smx;
    $seentags->{$tag} = $reverse->{$i};
  }

  for my $a (@args) {
    if(!$forward->{$a}) {
      next;
    }

    for my $i (@{$forward->{$a}}) {
      my ($tag) = $reverse->{$i} =~ /([[:lower:]]+)/smx;
      if($seentags->{$tag} && ($seentags->{$tag} ne $reverse->{$i})) {
	carp qq[Import of tag "$a" may clash with tag "$seentags->{$tag}"];
      }
      unshift @LDLIBS, $i;
    }
  }

  $ENV{'LD_LIBRARY_PATH'} = join q[:], @LDLIBS; ## no critic (RequireLocalizedPunctuationVars)
  return;
}

sub dump { ## no critic (Homonyms)
  my $config = config();
  for my $l (qw(Libs LDlibs)) {
    print $l, "\n" or croak $ERRNO;
    for my $s (sort $config->Parameters(lc $l)) {
      printf qq[%-12s %s\n], $s, $config->val(lc $l, $s);
    }
    print "\n\n" or croak $ERRNO;
  }

  return;
}

1;

__END__