From: matthewt Date: Mon, 13 Aug 2007 22:20:42 +0000 (+0000) Subject: lib::local code X-Git-Tag: 1.006009~115 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b5cc15f7139b20feea57c18e5498ef0dd1432935;p=p5sagit%2Flocal-lib.git lib::local code git-svn-id: http://dev.catalyst.perl.org/repos/bast/local-lib/1.000/trunk@3677 bd8105ee-0ff8-0310-8827-fb3f25b6796d --- diff --git a/lib/local/lib.pm b/lib/local/lib.pm new file mode 100644 index 0000000..557a9a6 --- /dev/null +++ b/lib/local/lib.pm @@ -0,0 +1,262 @@ +use strict; +use warnings; + +package local::lib; + +use 5.8.1; # probably works with earlier versions but I'm not supporting them + # (patches would, of course, be welcome) + +use File::Spec (); +use File::Path (); +use Carp (); +use Config; + +our $VERSION = '1.000000'; # 1.0.0 + +sub import { + my ($class, $path) = @_; + $path = $class->resolve_path($path); + $class->setup_local_lib_for($path); +} + +sub compose; + +sub compose { + my @methods = @_; + my $last = pop(@methods); + if (@methods) { + \sub { + my ($obj, @args) = @_; + $obj->${compose @methods}( + $obj->$last(@args) + ); + }; + } else { + \sub { + shift->$last(@_); + }; + } +} + +=for test + +package local::lib; + +{ package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } } +my $foo = bless({}, 'Foo'); +ok($foo->${compose qw(foo bar baz)}(10) == -15); + +=cut + +sub resolve_path { + my ($class, $path) = @_; + $class->${compose qw( + resolve_relative_path + resolve_home_path + resolve_empty_path + )}($path); +} + +sub resolve_empty_path { + my ($class, $path) = @_; + if (defined $path) { + $path; + } else { + '~/perl5'; + } +} + +=for test classmethod setup + +my $c = 'local::lib'; + +=cut + +=for test classmethod + +is($c->resolve_empty_path, '~/perl5'); +is($c->resolve_empty_path('foo'), 'foo'); + +=cut + +sub resolve_home_path { + my ($class, $path) = @_; + return $path unless ($path =~ /^~/); + my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us' + my $tried_file_homedir; + my $homedir = do { + if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) { + $tried_file_homedir = 1; + if (defined $user) { + File::HomeDir->users_home($user); + } else { + File::HomeDir->my_homedir; + } + } else { + if (defined $user) { + (getpwnam $user)[7]; + } else { + if (defined $ENV{HOME}) { + $ENV{HOME}; + } else { + (getpwuid $<)[7]; + } + } + } + }; + unless (defined $homedir) { + Carp::croak( + "Couldn't resolve homedir for " + .(defined $user ? $user : 'current user') + .($tried_file_homedir ? '' : ' - consider installing File::HomeDir') + ); + } + $path =~ s/^~[^\/]*/$homedir/; + $path; +} + +sub resolve_relative_path { + my ($class, $path) = @_; + File::Spec->rel2abs($path); +} + +=for test classmethod + +local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; }; +is($c->resolve_relative_path('bar'),'FOObar'); + +=cut + +sub setup_local_lib_for { + my ($class, $path) = @_; + $class->ensure_dir_structure_for($path); + if ($0 eq '-') { + $class->print_environment_vars_for($path); + exit 0; + } else { + $class->setup_env_hash_for($path); + } +} + +sub modulebuildrc_path { + my ($class, $path) = @_; + File::Spec->catfile($path, '.modulebuildrc'); +} + +sub install_base_bin_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'bin'); +} + +sub install_base_perl_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'lib', 'perl5'); +} + +sub install_base_arch_path { + my ($class, $path) = @_; + File::Spec->catdir($class->install_base_perl_path($path), $Config{archname}); +} + +sub ensure_dir_structure_for { + my ($class, $path) = @_; + unless (-d $path) { + warn "Attempting to create directory ${path}\n"; + } + File::Path::mkpath($path); + my $modulebuildrc_path = $class->modulebuildrc_path($path); + if (-e $modulebuildrc_path) { + unless (-f _) { + Carp::croak("${modulebuildrc_path} exists but is not a plain file"); + } + } else { + warn "Attempting to create file ${modulebuildrc_path}\n"; + open MODULEBUILDRC, '>', $modulebuildrc_path + || Carp::croak("Couldn't open ${modulebuildrc_path} for writing: $!"); + print MODULEBUILDRC qq{--install_base ${path}\n} + || Carp::croak("Couldn't write line to ${modulebuildrc_path}: $!"); + close MODULEBUILDRC + || Carp::croak("Couldn't close file ${modulebuildrc_path}: $@"); + } +} + +sub INTERPOLATE_PATH () { 1 } +sub LITERAL_PATH () { 0 } + +sub print_environment_vars_for { + my ($class, $path) = @_; + my @envs = $class->build_environment_vars_for($path, LITERAL_PATH); + my $out = ''; + while (@envs) { + my ($name, $value) = (shift(@envs), shift(@envs)); + $value =~ s/(\\")/\\$1/g; + $out .= qq{export ${name}="${value}"\n}; + } + print $out; +} + +sub setup_env_hash_for { + my ($class, $path) = @_; + my %envs = $class->build_environment_vars_for($path, INTERPOLATE_PATH); + @ENV{keys %envs} = values %envs; +} + +sub build_environment_vars_for { + my ($class, $path, $interpolate) = @_; + return ( + MODULEBUILDRC => $class->modulebuildrc_path($path), + PERL_MM_OPT => "INSTALL_BASE=${path}", + PERL5LIB => join(':', + $class->install_base_perl_path($path), + $class->install_base_arch_path($path), + ), + PATH => join(':', + $class->install_base_bin_path($path), + ($interpolate == INTERPOLATE_PATH + ? $ENV{PATH} + : '$PATH') + ), + ) +} + +=for test classmethod + +File::Path::rmtree('t/var/splat'); + +$c->resolve_relative_path('t/var/splat'); + +ok(-d 't/var/splat'); + +ok(-f 't/var/splat/.modulebuildrc'); + +=head1 NAME + +local::lib - create and use a local lib/ for perl modules with PERL5LIB + +=head1 SYNOPSIS + +In code - + + use local::lib; # sets up a local lib at ~/perl5 + + use local::lib '~/foo'; # same, but ~/foo + +From the shell - + + $ perl -Mlocal::lib + export MODULEBUILDRC=/home/username/perl/.modulebuildrc + export PERL_MM_OPT='INSTALL_BASE=/home/username/perl' + export PERL5LIB='/home/username/perl/lib/perl5:/home/username/perl/lib/perl5/i386-linux' + export PATH="/home/username/perl/bin:$PATH" + +=head1 AUTHOR + +Matt S Trout http://www.shadowcat.co.uk/ + +=head1 LICENSE + +This library is free software under the same license as perl itself + +=cut + +1;