File Coverage

blib/lib/Remote/Use.pm

Criterion	Covered	Total	%
statement	18	115	15.6
branch	0	48	0.0
condition	0	35	0.0
subroutine	6	11	54.5
pod	0	4	0.0
total	24	213	11.2

package Remote::Use;
use strict;
use warnings;

use File::Path;
use File::Spec;
use File::Basename;

use Scalar::Util qw{reftype};

our $VERSION = '0.04';

# Receives s.t. like 'Remote/Use.pm' and returns 'Remote::Use'
sub filename2modname {
  my $config = shift;

  my $confid = $config;
  $confid =~ s{/}{::}g;
  $confid =~ s{\.pm$}{};
  return $confid;
}

# Evaluates the ppmdf file as perl code.
# The resulting hash is set as the attribute 'cache'
# of the Remote::Use object
sub setinstallation {
  my $self = shift;

  $self->{cache} = {};
  if (-e $self->{ppmdf}) {
    if (open(my $f, $self->{ppmdf})) {
      local $/ = undef;
      my $s = <$f>;
      my @s = eval $s;
      die "Error evaluating cache file: $@" if $@;
      $self->{cache} = { @s };
    }
  }
}

sub import {
  my $module = shift;
  my %arg = @_;

  my $config = $arg{config};

  # Set the code handler in @INC so that we can later manage "use Module"
  # via Remote::Use::INC

  my $self = $module->new();
  push @INC, $self;

  # If the 'config' option is used we take the
  # arguments from the configuration package
  if (defined($config) && -r $config) {
    eval {
      require $config;
    };
    die "Error in $config: $@" if $@;

    my $confid = $arg{package};

    $confid = filename2modname($config) unless defined($confid);

    # The $confid package must have defined
    # the 'getarg' method

    $self->{confid} = $confid;
    %arg = $confid->getarg($self);
  }

  # host is the machine where to look for
  my $host = $arg{host};
  die "Provide a host" unless defined $host;
  delete $arg{host};
  $self->{host} = $host;

  # The 'prefix' attribute is the path where files and libraries
  # will be installed. If not provided it will be set to s.t. like
  # /home/myname/perl5lib

  my $perl5lib = "$ENV{HOME}/perl5lib" if $ENV{HOME};
  $perl5lib    = "$ENV{USERPROFILE}/perl5lib" if !$perl5lib && $ENV{USERPROFILE};

  my $prefix = $self->{prefix} = ($arg{prefix} || $perl5lib || File::Spec->tmpdir);
  die "Provide a prefix directory" unless defined $prefix;
  delete $arg{prefix};

  # Create the directory if it does not exists
  mkpath($prefix) unless -d $prefix;
  unshift @INC, "$prefix/files";

  my $ppmdf = $arg{ppmdf};
  die "Provide a .installed.modules filename (ppmdf argument)" unless defined $ppmdf;
  delete $arg{ppmdf};
  $self->{ppmdf} = $ppmdf;

  # Opens and evaluates the ppmdf file. It sets the attribute 'cache'
  $self->setinstallation;

  # What application shall we use: rsync? wget? ...
  my $command = $arg{command};
  die "Provide a command" unless defined $command;
  $self->{command} = $command;
  delete $arg{command};

  $self->{$_} = $arg{$_} for keys(%arg);
}

sub Remote::Use::INC {
  my ($self, $filename) = @_;

  if ($filename =~ m{^[\w/\\]+\.pm$}) {
    my $prefix = $self->{prefix}; # prefix path where the file will be stored ('/tmp/perl5lib')
    my $host = $self->{host};     # the 'host part' defining where the server is ('orion:')

    my $command = $self->{command}; # rsync, scp, wget, etc. Options included

    # options required by $command that go after the $host$sourcefile part
    my $commandoptions = $self->{commandoptions} || '';

    # an entry for some $filename is like:
    # 'IO/Tty.pm' => { dir => '/usr/local/lib/perl/5.8.8', files => [
    #                '/usr/local/lib/perl/5.8.8/auto/IO/Tty/Tty.so',
    #                '/usr/local/lib/perl/5.8.8/auto/IO/Tty/Tty.bs',
    #                         '/usr/local/lib/perl/5.8.8/IO/Tty.pm' ] },
    my %files;
    my $entry = $self->{cache}{$filename};
    %files = %{$entry} if $entry && (reftype($entry) eq 'HASH');

    # No files, nothing to download
    return unless %files;

    my $remoteprefix = quotemeta($files{dir});
    delete $files{dir};

    my $f = $files{files};
    delete $files{files};

    my $conf = $self->{confid}; # configuration package name

    my @files;
    @files= @$f if $f && (reftype($f) eq 'ARRAY');
    for (@files) {
       my $url = "$host$_"; # s.t. like 'orion:/usr/local/lib/perl/5.8.8/auto/IO/Tty/Tty.so'
       my $file = $_;       # s.t. like '/usr/local/lib/perl/5.8.8/auto/IO/Tty/Tty.so'
       $file =~ s{^$remoteprefix}{$prefix/files/}; # s.t. like '/tmp/perl5lib/files/auto/IO/Tty/Tty.so'

       # If the configuration package defines a 'prefiles' method, use it to obtain
       # the final name of the file:
       $file = $conf->prefiles($url, $file, $self) if $conf && ($conf->can('prefiles'));

       my $path =  dirname($file);    # s.t. like ''/tmp/perl5lib/files/auto/IO/Tty/'
       mkpath($path) unless -d $path;

       # grab the $url and store it in $file
       system("$command $url $commandoptions $file");

       # If the configuration package defines a 'postfiles' method, use it
       # to do any required modifications to the file (changing its mod access for example)
       $conf->postfiles($file, $self) if ($conf && $conf->can('postfiles'));
    }

    # Find if there are alternative families of files (bin, man, etc.)
    my @families = keys %files;
    for (@families) {
      my $f = $files{$_}; # [ '/usr/local/bin/eyapp', '/usr/local/bin/treereg' ]
      my @files;          # ( '/usr/local/bin/eyapp', '/usr/local/bin/treereg' )
      @files = @$f if $f && (reftype($f) eq 'ARRAY');

      for my $b (@files) {
         my $url = "$host$b"; # 'orion:/usr/local/bin/eyapp'
         my $file = $b;                 # name in the client:
         $file =~ s{^.*/}{$prefix/$_/}; #   /tmp/perl5lib/bin/eyapp

         my $pre = "pre$_";
         $file = $conf->$pre($url, $file, $self) if ($conf && $conf->can($pre));

         my $path =  dirname($file);
         mkpath($path) unless -d $path;

         system("$command $url $commandoptions $file");

         my $post = "post$_";
         $conf->$post($file, $self) if ($conf && $conf->can($post));
      }
    }

     open my $fh, '<', "$prefix/files/$filename";
     return $fh;
  }

  return undef;
}

sub new {
  my $this = shift;
  my $class = ref($this) || $this;

  return bless { @_ }, $class;
}

1;
__END__