1#line 1 2## 3# name: Module::Install::Package 4# abstract: Module::Install support for Module::Package 5# author: Ingy döt Net <ingy@cpan.org> 6# license: perl 7# copyright: 2011 8# see: 9# - Module::Package 10 11# This module contains the Module::Package logic that must be available to 12# both the Author and the End User. Author-only logic goes in a 13# Module::Package::Plugin subclass. 14package Module::Install::Package; 15use strict; 16use Module::Install::Base; 17use vars qw'@ISA $VERSION'; 18@ISA = 'Module::Install::Base'; 19$VERSION = '0.30'; 20 21#-----------------------------------------------------------------------------# 22# XXX BOOTBUGHACK 23# This is here to try to get us out of Module-Package-0.11 cpantesters hell... 24# Remove this when the situation has blown over. 25sub pkg { 26 *inc::Module::Package::VERSION = sub { $VERSION }; 27 my $self = shift; 28 $self->module_package_internals_init($@); 29} 30 31#-----------------------------------------------------------------------------# 32# We allow the author to specify key/value options after the plugin. These 33# options need to be available both at author time and install time. 34#-----------------------------------------------------------------------------# 35# OO accessor for command line options: 36sub package_options { 37 @_>1?($_[0]->{package_options}=$_[1]):$_[0]->{package_options}} 38 39my $default_options = { 40 deps_list => 1, 41 install_bin => 1, 42 install_share => 1, 43 manifest_skip => 1, 44 requires_from => 1, 45}; 46 47#-----------------------------------------------------------------------------# 48# Module::Install plugin directives. Use long, ugly names to not pollute the 49# Module::Install plugin namespace. These are only intended to be called from 50# Module::Package. 51#-----------------------------------------------------------------------------# 52 53# Module::Package starts off life as a normal call to this Module::Install 54# plugin directive: 55my $module_install_plugin; 56my $module_package_plugin; 57my $module_package_dist_plugin; 58# XXX ARGVHACK This @argv thing is a temporary fix for an ugly bug somewhere in the 59# Wikitext module usage. 60my @argv; 61sub module_package_internals_init { 62 my $self = $module_install_plugin = shift; 63 my ($plugin_spec, %options) = @_; 64 $self->package_options({%$default_options, %options}); 65 66 if ($module_install_plugin->is_admin) { 67 $module_package_plugin = $self->_load_plugin($plugin_spec); 68 $module_package_plugin->mi($module_install_plugin); 69 $module_package_plugin->version_check($VERSION); 70 } 71 else { 72 $module_package_dist_plugin = $self->_load_dist_plugin($plugin_spec); 73 $module_package_dist_plugin->mi($module_install_plugin) if ref $module_package_dist_plugin; 74 } 75 # NOTE - This is the point in time where the body of Makefile.PL runs... 76 return; 77 78 sub INIT { 79 return unless $module_install_plugin; 80 return if $Module::Package::ERROR; 81 eval { 82 if ($module_install_plugin->is_admin) { 83 $module_package_plugin->initial(); 84 $module_package_plugin->main(); 85 } 86 else { 87 $module_install_plugin->_initial(); 88 $module_package_dist_plugin->_initial() if ref $module_package_dist_plugin; 89 $module_install_plugin->_main(); 90 $module_package_dist_plugin->_main() if ref $module_package_dist_plugin; 91 } 92 }; 93 if ($@) { 94 $Module::Package::ERROR = $@; 95 die $@; 96 } 97 @argv = @ARGV; # XXX ARGVHACK 98 } 99 100 # If this Module::Install plugin was used (by Module::Package) then wrap 101 # up any loose ends. This will get called after Makefile.PL has completed. 102 sub END { 103 @ARGV = @argv; # XXX ARGVHACK 104 return unless $module_install_plugin; 105 return if $Module::Package::ERROR; 106 $module_package_plugin 107 ? do { 108 $module_package_plugin->final; 109 $module_package_plugin->replicate_module_package; 110 } 111 : do { 112 $module_install_plugin->_final; 113 $module_package_dist_plugin->_final() if ref $module_package_dist_plugin; 114 } 115 } 116} 117 118# Module::Package, Module::Install::Package and Module::Package::Plugin 119# must all have the same version. Seems wise. 120sub module_package_internals_version_check { 121 my ($self, $version) = @_; 122 return if $version < 0.1800001; # XXX BOOTBUGHACK!! 123 die <<"..." unless $version == $VERSION; 124 125Error! Something has gone awry: 126 Module::Package version=$version is using 127 Module::Install::Package version=$VERSION 128If you are the author of this module, try upgrading Module::Package. 129Otherwise, please notify the author of this error. 130 131... 132} 133 134# Find and load the author side plugin: 135sub _load_plugin { 136 my ($self, $spec, $namespace) = @_; 137 $spec ||= ''; 138 $namespace ||= 'Module::Package'; 139 my $version = ''; 140 $Module::Package::plugin_version = 0; 141 if ($spec =~ s/\s+(\S+)\s*//) { 142 $version = $1; 143 $Module::Package::plugin_version = $version; 144 } 145 my ($module, $plugin) = 146 not($spec) ? ('Plugin', "Plugin::basic") : 147 ($spec =~ /^\w(\w|::)*$/) ? ($spec, $spec) : 148 ($spec =~ /^:(\w+)$/) ? ('Plugin', "Plugin::$1") : 149 ($spec =~ /^(\S*\w):(\w+)$/) ? ($1, "$1::$2") : 150 die "$spec is invalid"; 151 $module = "${namespace}::${module}"; 152 $plugin = "${namespace}::${plugin}"; 153 eval "use $module $version (); 1" or die $@; 154 return $plugin->new(); 155} 156 157# Find and load the user side plugin: 158sub _load_dist_plugin { 159 my ($self, $spec, $namespace) = @_; 160 $spec ||= ''; 161 $namespace ||= 'Module::Package::Dist'; 162 my $r = eval { $self->_load_plugin($spec, $namespace); }; 163 return $r if ref $r; 164 return; 165} 166 167#-----------------------------------------------------------------------------# 168# These are the user side analogs to the author side plugin API calls. 169# Prefix with '_' to not pollute Module::Install plugin space. 170#-----------------------------------------------------------------------------# 171sub _initial { 172 my ($self) = @_; 173} 174 175sub _main { 176 my ($self) = @_; 177} 178 179# NOTE These must match Module::Package::Plugin::final. 180sub _final { 181 my ($self) = @_; 182 $self->_all_from; 183 $self->_requires_from; 184 $self->_install_bin; 185 $self->_install_share; 186 $self->_WriteAll; 187} 188 189#-----------------------------------------------------------------------------# 190# This section is where all the useful code bits go. These bits are needed by 191# both Author and User side runs. 192#-----------------------------------------------------------------------------# 193 194my $all_from = 0; 195sub _all_from { 196 my $self = shift; 197 return if $all_from++; 198 return if $self->name; 199 my $file = shift || "$main::PM" or die "all_from has no file"; 200 $self->all_from($file); 201} 202 203my $requires_from = 0; 204sub _requires_from { 205 my $self = shift; 206 return if $requires_from++; 207 return unless $self->package_options->{requires_from}; 208 my $file = shift || "$main::PM" or die "requires_from has no file"; 209 $self->requires_from($main::PM) 210} 211 212my $install_bin = 0; 213sub _install_bin { 214 my $self = shift; 215 return if $install_bin++; 216 return unless $self->package_options->{install_bin}; 217 return unless -d 'bin'; 218 my @bin; 219 File::Find::find(sub { 220 return unless -f $_; 221 push @bin, $File::Find::name; 222 }, 'bin'); 223 $self->install_script($_) for @bin; 224} 225 226my $install_share = 0; 227sub _install_share { 228 my $self = shift; 229 return if $install_share++; 230 return unless $self->package_options->{install_share}; 231 return unless -d 'share'; 232 $self->install_share; 233} 234 235my $WriteAll = 0; 236sub _WriteAll { 237 my $self = shift; 238 return if $WriteAll++; 239 $self->WriteAll(@_); 240} 241 242# Base package for Module::Package plugin distributed components. 243package Module::Package::Dist; 244 245sub new { 246 my ($class, %args) = @_; 247 bless \%args, $class; 248} 249 250sub mi { 251 @_ > 1 ? ($_[0]->{mi}=$_[1]) : $_[0]->{mi}; 252} 253 254sub _initial { 255 my ($self) = @_; 256} 257 258sub _main { 259 my ($self) = @_; 260} 261 262sub _final { 263 my ($self) = @_; 264} 265 2661; 267 268#-----------------------------------------------------------------------------# 269# Take a guess at the primary .pm and .pod files for 'all_from', and friends. 270# Put them in global magical vars in the main:: namespace. 271#-----------------------------------------------------------------------------# 272package Module::Package::PM; 273use overload '""' => sub { 274 $_[0]->guess_pm unless @{$_[0]}; 275 return $_[0]->[0]; 276}; 277sub set { $_[0]->[0] = $_[1] } 278sub guess_pm { 279 my $pm = ''; 280 my $self = shift; 281 if (-e 'META.yml') { 282 open META, 'META.yml' or die "Can't open 'META.yml' for input:\n$!"; 283 my $meta = do { local $/; <META> }; 284 close META; 285 $meta =~ /^module_name: (\S+)$/m 286 or die "Can't get module_name from META.yml"; 287 $pm = $1; 288 $pm =~ s!::!/!g; 289 $pm = "lib/$pm.pm"; 290 } 291 else { 292 require File::Find; 293 my @array = (); 294 File::Find::find(sub { 295 return unless /\.pm$/; 296 my $name = $File::Find::name; 297 my $num = ($name =~ s!/+!/!g); 298 my $ary = $array[$num] ||= []; 299 push @$ary, $name; 300 }, 'lib'); 301 shift @array while @array and not defined $array[0]; 302 die "Can't guess main module" unless @array; 303 (($pm) = sort @{$array[0]}) or 304 die "Can't guess main module"; 305 } 306 my $pmc = $pm . 'c'; 307 $pm = $pmc if -e $pmc; 308 $self->set($pm); 309} 310$main::PM = bless [$main::PM ? ($main::PM) : ()], __PACKAGE__; 311 312package Module::Package::POD; 313use overload '""' => sub { 314 return $_[0]->[0] if @{$_[0]}; 315 (my $pod = "$main::PM") =~ s/\.pm/.pod/ 316 or die "Module::Package's \$main::PM value should end in '.pm'"; 317 return -e $pod ? $pod : ''; 318}; 319sub set { $_[0][0] = $_[1] } 320$main::POD = bless [$main::POD ? ($main::POD) : ()], __PACKAGE__; 321 3221; 323 324