lib/local/lib.pm

   1 use strict;
   2 use warnings;
   3
   4 package local::lib;
   5
   6 use 5.8.1; # probably works with earlier versions but I'm not supporting them
   7            # (patches would, of course, be welcome)
   8
   9 use File::Spec ();
  10 use File::Path ();
  11 use Carp ();
  12 use Config;
  13
  14 our $VERSION = '1.000000'; # 1.0.0
  15
  16 sub import {
  17   my ($class, $path) = @_;
  18   $path = $class->resolve_path($path);
  19   $class->setup_local_lib_for($path);
  20 }
  21
  22 sub pipeline;
  23
  24 sub pipeline {
  25   my @methods = @_;
  26   my $last = pop(@methods);
  27   if (@methods) {
  28     \sub {
  29       my ($obj, @args) = @_;
  30       $obj->${pipeline @methods}(
  31         $obj->$last(@args)
  32       );
  33     };
  34   } else {
  35     \sub {
  36       shift->$last(@_);
  37     };
  38   }
  39 }
  40
  41 =for test pipeline
  42
  43 package local::lib;
  44
  45 { package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } }
  46 my $foo = bless({}, 'Foo');
  47 Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15);
  48
  49 =cut
  50
  51 sub resolve_path {
  52   my ($class, $path) = @_;
  53   $class->${pipeline qw(
  54     resolve_relative_path
  55     resolve_home_path
  56     resolve_empty_path
  57   )}($path);
  58 }
  59
  60 sub resolve_empty_path {
  61   my ($class, $path) = @_;
  62   if (defined $path) {
  63     $path;
  64   } else {
  65     '~/perl5';
  66   }
  67 }
  68
  69 =for test classmethod setup
  70
  71 my $c = 'local::lib';
  72
  73 =cut
  74
  75 =for test classmethod
  76
  77 is($c->resolve_empty_path, '~/perl5');
  78 is($c->resolve_empty_path('foo'), 'foo');
  79
  80 =cut
  81
  82 sub resolve_home_path {
  83   my ($class, $path) = @_;
  84   return $path unless ($path =~ /^~/);
  85   my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
  86   my $tried_file_homedir;
  87   my $homedir = do {
  88     if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
  89       $tried_file_homedir = 1;
  90       if (defined $user) {
  91         File::HomeDir->users_home($user);
  92       } else {
  93         File::HomeDir->my_homedir;
  94       }
  95     } else {
  96       if (defined $user) {
  97         (getpwnam $user)[7];
  98       } else {
  99         if (defined $ENV{HOME}) {
 100           $ENV{HOME};
 101         } else {
 102           (getpwuid $<)[7];
 103         }
 104       }
 105     }
 106   };
 107   unless (defined $homedir) {
 108     Carp::croak(
 109       "Couldn't resolve homedir for "
 110       .(defined $user ? $user : 'current user')
 111       .($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
 112     );
 113   }
 114   $path =~ s/^~[^\/]*/$homedir/;
 115   $path;
 116 }
 117
 118 sub resolve_relative_path {
 119   my ($class, $path) = @_;
 120   File::Spec->rel2abs($path);
 121 }
 122
 123 =for test classmethod
 124
 125 local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; };
 126 is($c->resolve_relative_path('bar'),'FOObar');
 127
 128 =cut
 129
 130 sub setup_local_lib_for {
 131   my ($class, $path) = @_;
 132   $class->ensure_dir_structure_for($path);
 133   if ($0 eq '-') {
 134     $class->print_environment_vars_for($path);
 135     exit 0;
 136   } else {
 137     $class->setup_env_hash_for($path);
 138   }
 139 }
 140
 141 sub modulebuildrc_path {
 142   my ($class, $path) = @_;
 143   File::Spec->catfile($path, '.modulebuildrc');
 144 }
 145
 146 sub install_base_bin_path {
 147   my ($class, $path) = @_;
 148   File::Spec->catdir($path, 'bin');
 149 }
 150
 151 sub install_base_perl_path {
 152   my ($class, $path) = @_;
 153   File::Spec->catdir($path, 'lib', 'perl5');
 154 }
 155
 156 sub install_base_arch_path {
 157   my ($class, $path) = @_;
 158   File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
 159 }
 160
 161 sub ensure_dir_structure_for {
 162   my ($class, $path) = @_;
 163   unless (-d $path) {
 164     warn "Attempting to create directory ${path}\n";
 165   }
 166   File::Path::mkpath($path);
 167   my $modulebuildrc_path = $class->modulebuildrc_path($path);
 168   if (-e $modulebuildrc_path) {
 169     unless (-f _) {
 170       Carp::croak("${modulebuildrc_path} exists but is not a plain file");
 171     }
 172   } else {
 173     warn "Attempting to create file ${modulebuildrc_path}\n";
 174     open MODULEBUILDRC, '>', $modulebuildrc_path
 175       || Carp::croak("Couldn't open ${modulebuildrc_path} for writing: $!");
 176     print MODULEBUILDRC qq{install  --install_base  ${path}\n}
 177       || Carp::croak("Couldn't write line to ${modulebuildrc_path}: $!");
 178     close MODULEBUILDRC
 179       || Carp::croak("Couldn't close file ${modulebuildrc_path}: $@");
 180   }
 181 }
 182
 183 sub INTERPOLATE_PATH () { 1 }
 184 sub LITERAL_PATH     () { 0 }
 185
 186 sub print_environment_vars_for {
 187   my ($class, $path) = @_;
 188   my @envs = $class->build_environment_vars_for($path, LITERAL_PATH);
 189   my $out = '';
 190   while (@envs) {
 191     my ($name, $value) = (shift(@envs), shift(@envs));
 192     $value =~ s/(\\")/\\$1/g;
 193     $out .= qq{export ${name}="${value}"\n};
 194   }
 195   print $out;
 196 }
 197
 198 sub setup_env_hash_for {
 199   my ($class, $path) = @_;
 200   my %envs = $class->build_environment_vars_for($path, INTERPOLATE_PATH);
 201   @ENV{keys %envs} = values %envs;
 202 }
 203
 204 sub build_environment_vars_for {
 205   my ($class, $path, $interpolate) = @_;
 206   return (
 207     MODULEBUILDRC => $class->modulebuildrc_path($path),
 208     PERL_MM_OPT => "INSTALL_BASE=${path}",
 209     PERL5LIB => join(':',
 210                   $class->install_base_perl_path($path),
 211                   $class->install_base_arch_path($path),
 212                 ),
 213     PATH => join(':',
 214               $class->install_base_bin_path($path),
 215               ($interpolate == INTERPOLATE_PATH
 216                 ? $ENV{PATH}
 217                 : '$PATH')
 218              ),
 219   )
 220 }
 221
 222 =for test classmethod
 223
 224 File::Path::rmtree('t/var/splat');
 225
 226 $c->ensure_dir_structure_for('t/var/splat');
 227
 228 ok(-d 't/var/splat');
 229
 230 ok(-f 't/var/splat/.modulebuildrc');
 231
 232 =head1 NAME
 233
 234 local::lib - create and use a local lib/ for perl modules with PERL5LIB
 235
 236 =head1 SYNOPSIS
 237
 238 In code -
 239
 240   use local::lib; # sets up a local lib at ~/perl5
 241
 242   use local::lib '~/foo'; # same, but ~/foo
 243
 244 From the shell -
 245
 246   $ perl -Mlocal::lib
 247   export MODULEBUILDRC=/home/username/perl/.modulebuildrc
 248   export PERL_MM_OPT='INSTALL_BASE=/home/username/perl'
 249   export PERL5LIB='/home/username/perl/lib/perl5:/home/username/perl/lib/perl5/i386-linux'
 250   export PATH="/home/username/perl/bin:$PATH"
 251
 252 =head1 AUTHOR
 253
 254 Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
 255
 256 =head1 LICENSE
 257
 258 This library is free software under the same license as perl itself
 259
 260 =cut
 261
 262 1;