Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
if ($additive{$key}) {
$add_to->{$_} = $val->{$_} foreach keys %$val;
} else {
$add_to->{$key} = $val;
}
}
}
}
sub cull_args {
my $self = shift;
my @arg_list = @_;
unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT})
if $ENV{PERL_MB_OPT};
my ($args, $action) = $self->read_args(@arg_list);
$self->merge_args($action, %$args);
$self->merge_modulebuildrc( $action, %$args );
}
sub super_classes {
my ($self, $class, $seen) = @_;
$class ||= ref($self) || $self;
$seen ||= {};
no strict 'refs';
my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
return @super, map {$self->super_classes($_,$seen)} @super;
}
sub known_actions {
my ($self) = @_;
my %actions;
no strict 'refs';
foreach my $class ($self->super_classes) {
foreach ( keys %{ $class . '::' } ) {
$actions{$1}++ if /^ACTION_(\w+)/;
}
}
return wantarray ? sort keys %actions : \%actions;
}
sub get_action_docs {
my ($self, $action) = @_;
my $actions = $self->known_actions;
die "No known action '$action'" unless $actions->{$action};
my ($files_found, @docs) = (0);
foreach my $class ($self->super_classes) {
(my $file = $class) =~ s{::}{/}g;
# NOTE: silently skipping relative paths if any chdir() happened
$file = $INC{$file . '.pm'} or next;
open(my $fh, '<', $file) or next;
$files_found++;
# Code below modified from /usr/bin/perldoc
# Skip to ACTIONS section
local $_;
while (<$fh>) {
last if /^=head1 ACTIONS\s/;
}
# Look for our action and determine the style
my $style;
while (<$fh>) {
last if /^=head1 /;
# only item and head2 are allowed (3&4 are not in 5.005)
if(/^=(item|head2)\s+\Q$action\E\b/) {
$style = $1;
push @docs, $_;
last;
}
}
$style or next; # not here
# and the content
if($style eq 'item') {
my ($found, $inlist) = (0, 0);
while (<$fh>) {
if (/^=(item|back)/) {
last unless $inlist;
}
push @docs, $_;
++$inlist if /^=over/;
--$inlist if /^=back/;
}
}
else { # head2 style
# stop at anything equal or greater than the found level
while (<$fh>) {
last if(/^=(?:head[12]|cut)/);
push @docs, $_;
}
}
# TODO maybe disallow overriding just pod for an action
# TODO and possibly: @docs and last;
}
unless ($files_found) {
$@ = "Couldn't find any documentation to search";
return;
}
unless (@docs) {
$@ = "Couldn't find any docs for action '$action'";
return;
}
return join '', @docs;
}
sub ACTION_prereq_report {
my $self = shift;
$self->log_info( $self->prereq_report );
}
sub ACTION_prereq_data {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
sub ACTION_docs {
my $self = shift;
$self->depends_on('code');
$self->depends_on('manpages', 'html');
}
# Given a file type, will return true if the file type would normally
# be installed when neither install-base nor prefix has been set.
# I.e. it will be true only if the path is set from Config.pm or
# set explicitly by the user via install-path.
sub _is_default_installable {
my $self = shift;
my $type = shift;
return ( $self->install_destination($type) &&
( $self->install_path($type) ||
$self->install_sets($self->installdirs)->{$type} )
) ? 1 : 0;
}
sub _is_ActivePerl {
# return 0;
my $self = shift;
unless (exists($self->{_is_ActivePerl})) {
$self->{_is_ActivePerl} = (eval { require ActivePerl::DocTools; } || 0);
}
return $self->{_is_ActivePerl};
}
sub _is_ActivePPM {
# return 0;
my $self = shift;
unless (exists($self->{_is_ActivePPM})) {
$self->{_is_ActivePPM} = (eval { require ActivePerl::PPM; } || 0);
}
return $self->{_is_ActivePPM};
}
sub ACTION_manpages {
my $self = shift;
return unless $self->_mb_feature('manpage_support');
$self->depends_on('code');
my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : ();
foreach my $type ( qw(bin lib) ) {
next unless ( $self->invoked_action eq 'manpages' || $self->_is_default_installable("${type}doc"));
my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
exclude => [ $self->file_qr('\.bat$') ] );
next unless %$files;
my $sub = $self->can("manify_${type}_pods");
$self->$sub( %extra_manify_args ) if defined( $sub );
}
}
sub manify_bin_pods {
my $self = shift;
my %podman_args = (section => 1, @_); # binaries go in section 1
my $files = $self->_find_pods( $self->{properties}{bindoc_dirs},
exclude => [ $self->file_qr('\.bat$') ] );
return unless keys %$files;
my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
File::Path::mkpath( $mandir, 0, oct(777) );
require Pod::Man;
foreach my $file (sort keys %$files) {
# Pod::Simple based parsers only support one document per instance.
# This is expected to change in a future version (Pod::Simple > 3.03).
my $parser = Pod::Man->new( %podman_args );
my $manpage = $self->man1page_name( $file ) . '.' .
$self->config( 'man1ext' );
my $outfile = File::Spec->catfile($mandir, $manpage);
next if $self->up_to_date( $file, $outfile );
$self->log_verbose("Manifying $file -> $outfile\n");
eval { $parser->parse_from_file( $file, $outfile ); 1 }
or $self->log_warn("Error creating '$outfile': $@\n");
$files->{$file} = $outfile;
}
}
sub manify_lib_pods {
my $self = shift;
my %podman_args = (section => 3, @_); # libraries go in section 3
my $files = $self->_find_pods($self->{properties}{libdoc_dirs});
return unless keys %$files;
my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
File::Path::mkpath( $mandir, 0, oct(777) );
require Pod::Man;
foreach my $file (sort keys %$files) {
# Pod::Simple based parsers only support one document per instance.
# This is expected to change in a future version (Pod::Simple > 3.03).
my $parser = Pod::Man->new( %podman_args );
my $manpage = $self->man3page_name( $files->{$file} ) . '.' .
$self->config( 'man3ext' );
my $outfile = File::Spec->catfile( $mandir, $manpage);
next if $self->up_to_date( $file, $outfile );
$self->log_verbose("Manifying $file -> $outfile\n");
eval { $parser->parse_from_file( $file, $outfile ); 1 }
or $self->log_warn("Error creating '$outfile': $@\n");
$files->{$file} = $outfile;
}
}
sub _find_pods {
my ($self, $dirs, %args) = @_;
my %files;
foreach my $spec (@$dirs) {
my $dir = $self->localize_dir_path($spec);
next unless -e $dir;
FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
foreach my $regexp ( @{ $args{exclude} } ) {
next FILE if $file =~ $regexp;
}
$file = $self->localize_file_path($file);
$files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file )
}
}
return \%files;
}
sub contains_pod {
my ($self, $file) = @_;
return '' unless -T $file; # Only look at text files
open(my $fh, '<', $file ) or die "Can't open $file: $!";
while (my $line = <$fh>) {
return 1 if $line =~ /^\=(?:head|pod|item)/;
}
return '';
}
sub ACTION_html {
my $self = shift;
return unless $self->_mb_feature('HTML_support');
$self->depends_on('code');
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
index => 1,
depth => $depth,
);
eval {
ActivePerl::DocTools::Pod::pod2html(map { ($_, $opts{$_}) } sort keys %opts);
1;
} or $self->log_warn("[$htmltool] pod2html (" .
join(", ", map { "q{$_} => q{$opts{$_}}" } (sort keys %opts)) . ") failed: $@");
} else {
my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs);
open(my $fh, '<', $infile) or die "Can't read $infile: $!";
my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
my $title = join( '::', (@dirs, $name) );
$title .= " - $abstract" if $abstract;
my @opts = (
"--title=$title",
( defined($podpath) ? "--podpath=$podpath" : ()),
"--infile=$infile",
"--outfile=$tmpfile",
"--podroot=$podroot",
($path2root ? "--htmlroot=$path2root" : ()),
);
unless ( eval{Pod::Html->VERSION(1.12)} ) {
push( @opts, ('--flush') ); # caching removed in 1.12
}
if ( eval{Pod::Html->VERSION(1.12)} ) {
push( @opts, ('--header', '--backlink') );
} elsif ( eval{Pod::Html->VERSION(1.03)} ) {
push( @opts, ('--header', '--backlink=Back to Top') );
}
$self->log_verbose("P::H::pod2html @opts\n");
{
my $orig = Cwd::getcwd();
eval { Pod::Html::pod2html(@opts); 1 }
or $self->log_warn("[$htmltool] pod2html( " .
join(", ", map { "q{$_}" } @opts) . ") failed: $@");
chdir($orig);
}
}
# We now have to cleanup the resulting html file
if ( ! -r $tmpfile ) {
$errors++;
next POD;
}
open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!";
my $html = join('',<$fh>);
close $fh;
if (!$self->_is_ActivePerl) {
# These fixups are already done by AP::DT:P:pod2html
# The output from pod2html is NOT XHTML!
# IE6+ will display content that is not valid for DOCTYPE
$html =~ s#^<!DOCTYPE .*?>#<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">#im;
$html =~ s#<html xmlns="http://www.w3.org/1999/xhtml">#<html>#i;
# IE6+ will not display local HTML files with strict
# security without this comment
$html =~ s#<head>#<head>\n<!-- saved from url=(0017)http://localhost/ -->#i;
}
# Fixup links that point to our temp blib
$html =~ s/\Q$blibdir\E//g;
open($fh, '>', $outfile) or die "Can't write $outfile: $!";
print $fh $html;
close $fh;
unlink($tmpfile);
}
return ! $errors;
}
# Adapted from ExtUtils::MM_Unix
sub man1page_name {
my $self = shift;
return File::Basename::basename( shift );
}
# Adapted from ExtUtils::MM_Unix and Pod::Man
# Depending on M::B's dependency policy, it might make more sense to refactor
# Pod::Man::begin_pod() to extract a name() methods, and use them...
# -spurkis
sub man3page_name {
my $self = shift;
my ($vol, $dirs, $file) = File::Spec->splitpath( shift );
my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
# Remove known exts from the base name
$file =~ s/\.p(?:od|m|l)\z//i;
return join( $self->manpage_separator, @dirs, $file );
}
sub manpage_separator {
return '::';
}
# For systems that don't have 'diff' executable, should use Algorithm::Diff
sub ACTION_diff {
my $self = shift;
$self->depends_on('build');
my $local_lib = File::Spec->rel2abs('lib');
my @myINC = grep {$_ ne $local_lib} @INC;
# The actual install destination might not be in @INC, so check there too.
push @myINC, map $self->install_destination($_), qw(lib arch);
my @flags = @{$self->{args}{ARGV}};
@flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;
my $installmap = $self->install_map;
delete $installmap->{read};
delete $installmap->{write};
my $text_suffix = $self->file_qr('\.(pm|pod)$');
foreach my $localdir (sort keys %$installmap) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
if (defined $args{to} and length $args{to}) {
$to_path = $args{to};
} elsif (defined $args{to_dir} and length $args{to_dir}) {
$to_path = File::Spec->catfile( $args{to_dir}, $args{flatten}
? File::Basename::basename($file)
: $file );
} else {
die "No 'to' or 'to_dir' parameter given to copy_if_modified";
}
return if $self->up_to_date($file, $to_path); # Already fresh
{
local $self->{properties}{quiet} = 1;
$self->delete_filetree($to_path); # delete destination if exists
}
# Create parent directories
File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
$self->log_verbose("Copying $file -> $to_path\n");
if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
chmod 0666, $to_path;
File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
} else {
File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
}
# mode is read-only + (executable if source is executable)
my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
chmod( $mode, $to_path );
return $to_path;
}
sub up_to_date {
my ($self, $source, $derived) = @_;
$source = [$source] unless ref $source;
$derived = [$derived] unless ref $derived;
# empty $derived means $source should always run
return 0 if @$source && !@$derived || grep {not -e} @$derived;
my $most_recent_source = time / (24*60*60);
foreach my $file (@$source) {
unless (-e $file) {
$self->log_warn("Can't find source file $file for up-to-date check");
next;
}
$most_recent_source = -M _ if -M _ < $most_recent_source;
}
foreach my $derived (@$derived) {
return 0 if -M $derived > $most_recent_source;
}
return 1;
}
sub dir_contains {
my ($self, $first, $second) = @_;
# File::Spec doesn't have an easy way to check whether one directory
# is inside another, unfortunately.
($first, $second) = map File::Spec->canonpath($_), ($first, $second);
my @first_dirs = File::Spec->splitdir($first);
my @second_dirs = File::Spec->splitdir($second);
return 0 if @second_dirs < @first_dirs;
my $is_same = ( $self->_case_tolerant
? sub {lc(shift()) eq lc(shift())}
: sub {shift() eq shift()} );
while (@first_dirs) {
return 0 unless $is_same->(shift @first_dirs, shift @second_dirs);
}
return 1;
}
1;
__END__
=head1 NAME
Module::Build::Base - Default methods for Module::Build
=head1 SYNOPSIS
Please see the Module::Build documentation.
=head1 DESCRIPTION
The C<Module::Build::Base> module defines the core functionality of
C<Module::Build>. Its methods may be overridden by any of the
platform-dependent modules in the C<Module::Build::Platform::>
namespace, but the intention here is to make this base module as
platform-neutral as possible. Nicely enough, Perl has several core
tools available in the C<File::> namespace for doing this, so the task
isn't very difficult.
Please see the C<Module::Build> documentation for more details.
=head1 AUTHOR
Ken Williams <kwilliams@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
perl(1), Module::Build(3)
=cut
( run in 1.128 second using v1.01-cache-2.11-cpan-39bf76dae61 )