File Coverage

blib/lib/Env/Modulecmd.pm

Criterion	Covered	Total	%
statement	57	74	77.0
branch	6	24	25.0
condition	5	15	33.3
subroutine	9	9	100.0
pod			n/a
total	77	122	63.1

# $Id: Modulecmd.pm,v 5.3 2014/08/18 16:56:11 ronisaac Exp $

# Copyright (c) 2001-2014, Morgan Stanley.
# Distributed under the terms of the GNU General Public License.
# Please see the copyright notice at the end of this file for more information.

package Env::Modulecmd;

BEGIN {
  # defaults: if Env::Modulecmd is built using perl5.005 or later, the
  # magic strings below are replaced with values supplied to 'make' at
  # build time

  my $modulecmd  = '';
  my $modulepath = '';

  $ENV{PERL_MODULECMD} ||= $modulecmd  unless ($modulecmd  =~ /^\@\@/);
  $ENV{MODULEPATH}     ||= $modulepath unless ($modulepath =~ /^\@\@/);
}

use strict;
use vars qw($VERSION $AUTOLOAD);

use Carp;
use IO::File;

$VERSION = 1.3;

my $modulecmd = $ENV{'PERL_MODULECMD'} || 'modulecmd';

sub import {
  my @args = @_;
  shift @args;

  # import just dispatches commands to _modulecmd

  foreach my $arg (@args) {
    if (ref ($arg) eq "HASH") {
      my %hash = %{$arg};
      foreach my $key (keys %hash) {
        my $val = $hash{$key};
        if (ref ($val) eq "ARRAY") {
          _modulecmd ($key, $_) for @{$val};
        } else {
          _modulecmd ($key, $val);
        }
      }
    } else {
      _modulecmd ('load', $arg);
    }
  }
}

sub AUTOLOAD {
  my @modules = @_;

  # AUTOLOAD, like import, calls _modulecmd with the requested function

  my $fun = $AUTOLOAD;
  $fun =~ s/^.*:://;

  _modulecmd ($fun, $_) for @modules;
}

sub _indent {
  my ($str) = @_;

  $str =~ s/\n$//;
  $str =~ s/\n/\n -> /g;
  $str = " -> $str\n";

  return ($str);
}

sub _modulecmd {
  my ($fun, $module) = @_;

  # here's where the actual work gets done. we call modulecmd and
  # capture its standard output and standard error. we used to use
  # IPC::Open3, but switched to temp files to resolve a potential hang
  # on MS Windows 7 and up.

  my @cmd = ($modulecmd, "perl", $fun, $module);

  # 1. save stdout and stderr and redirect them to (unlinked) temp
  #    files

  my $SAVE_OUT = IO::File->new (">&" . STDOUT->fileno);
  my $SAVE_ERR = IO::File->new (">&" . STDERR->fileno);

  my $OUT = IO::File->new_tmpfile;
  my $ERR = IO::File->new_tmpfile;

  STDOUT->fdopen ($OUT, "w");
  STDERR->fdopen ($ERR, "w");

  STDOUT->autoflush (1);
  STDERR->autoflush (1);

  # 2. call modulecmd

  my $retcode = system (@cmd);
  my $syserr  = $!;

  # 3. read the output from the temp files and restore stdout and
  #    stderr

  STDOUT->fdopen ($SAVE_OUT, "w");
  STDERR->fdopen ($SAVE_ERR, "w");

  $OUT->seek (0, 0);
  $ERR->seek (0, 0);

  my $out;
  my $err;
  my $buf;

  $out .= $buf while read $OUT, $buf, 1024;
  $err .= $buf while read $ERR, $buf, 1024;

  undef $OUT;
  undef $ERR;

  # ok, how did we do?

  if ($err || $retcode) {
    my $croak = 0;

    # attempt to guess whether the stderr output is a real error
    # generated by modulecmd, or just an informational message output
    # by the module itself. error messages from modulecmd (like
    # "Couldn't find modulefile ... in MODULEPATH") fall into two
    # categories: they either (a) start with "ERROR:", or (b) start
    # and end with a row of dashes, and contain the message shown
    # below. (note that "occurred" is misspelled as "occured" in the
    # modulecmd source.)

    my $error_from_modulecmd =
      (($err =~ /^ERROR:/) or
       ($err =~ /^-----/ and $err =~ /-----\s*$/ and
        $err =~ /An error occur*ed while processing your module command/));

    $croak = 1
      if $error_from_modulecmd;

    # now check for failure from the system() call. start by checking
    # for a non-zero return code, which works on some versions of
    # MS Windows and most other systems.
    #
    # on MS Windows, shell commands are always wrapped with cmd.exe,
    # and some versions of cmd.exe will always exit with a zero return
    # code. Windows 7 seems to pass through the return code of the
    # last command, but Windows XP and earlier can be problematic.
    #
    # modulecmd itself will hardly ever exit with a non-zero return
    # code. however, there are two cases where it will: (a) invalid
    # syntax, like "modulecmd no-such-shell list"; and (b) "modulecmd
    # perl load /no/such/directory". in these cases, we hopefully
    # already determined (using the pattern above) that this is an
    # error message from modulecmd. if not, we assume it's a message
    # about a failure to call modulecmd in the first place.

    if ($retcode) {
      $croak = 1;

      unless ($error_from_modulecmd) {
        croak
          ("Unable to execute '@cmd':\n" .
           _indent ($err || $syserr) .
           "Error loading module $module");
      }
    }

    # now, if $croak is set, it's a fatal error, so croak on it.
    # otherwise, issue a warning, but only if -w is in effect.

    if ($croak) {
      croak
        ("Errors from '@cmd':\n" .
         _indent ($err) .
         "Error loading module $module");
    } else {
      carp
        ("Messages from '@cmd':\n" .
         _indent ($err) .
         "Possible error loading module $module")
          if $^W;
    }
  }

  # if we got here, then the command didn't fail. if it did generate
  # output, then we have something to eval.

  if ($out) {

    # what if we try to eval something that's not valid perl? in this
    # case, eval will die, with a message indicating what went wrong.
    # we want to catch this and nicely print out the error.

    eval $out;

    croak
      ("'@cmd' generated output:\n" .
       _indent ($out) .
       "Error evaluating:\n" .
       _indent ($@) .
       "Error loading module $module")
        if $@;
  }
}

1;

__END__