config/auto/perldoc.pm

   1 # Copyright (C) 2001-2008, Parrot Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 config/auto/perldoc - Check whether perldoc works
   7
   8 =head1 DESCRIPTION
   9
  10 Determines whether F<perldoc> exists on the system and, if so, which
  11 version of F<perldoc> it is.
  12
  13 More specifically, we look for the F<perldoc> associated with the
  14 instance of F<perl> with which F<Configure.pl> was invoked.
  15
  16 =cut
  17
  18 package auto::perldoc;
  19
  20 use strict;
  21 use warnings;
  22
  23 use File::Temp qw (tempfile );
  24 use base qw(Parrot::Configure::Step);
  25 use Parrot::Configure::Utils ':auto';
  26
  27
  28 sub _init {
  29     my $self = shift;
  30     my %data;
  31     $data{description} = q{Is perldoc installed};
  32     $data{result}      = q{};
  33     return \%data;
  34 }
  35
  36 sub runstep {
  37     my ( $self, $conf ) = @_;
  38
  39     my $cmd = $conf->data->get_p5('scriptdirexp') . q{/perldoc};
  40     my ( $fh, $filename ) = tempfile( UNLINK => 1 );
  41     my $content = capture_output("$cmd -ud $filename perldoc") || undef;
  42
  43     return 1 unless defined( $self->_initial_content_check($conf, $content) );
  44
  45     my $version = $self->_analyze_perldoc($cmd, $filename, $content);
  46
  47     _handle_version($conf, $version, $cmd);
  48
  49     my $TEMP_pod_build = <<'E_NOTE';
  50
  51 # the following part of the Makefile was built by 'config/auto/perldoc.pm'
  52
  53 E_NOTE
  54
  55     opendir OPS, 'src/ops' or die "opendir ops: $!";
  56     my @ops = sort grep { !/^\./ && /\.ops$/ } readdir OPS;
  57     closedir OPS;
  58
  59     my $TEMP_pod = join q{ } =>
  60         map { my $t = $_; $t =~ s/\.ops$/.pod/; "ops/$t" } @ops;
  61
  62     my $slash       = $conf->data->get('slash');
  63     my $new_perldoc = $conf->data->get('new_perldoc');
  64
  65     foreach my $ops (@ops) {
  66         my $pod = $ops;
  67         $pod =~ s/\.ops$/.pod/;
  68         if ( $new_perldoc ) {
  69             $TEMP_pod_build .= <<"END"
  70 ops$slash$pod: ..${slash}src${slash}ops${slash}$ops
  71 \t\$(PERLDOC) -ud ops${slash}$pod ..${slash}src${slash}ops${slash}$ops
  72 \t\$(CHMOD) 0644 ops${slash}$pod
  73
  74 END
  75         }
  76         else {
  77             $TEMP_pod_build .= <<"END"
  78 ops$slash$pod: ..${slash}src${slash}ops${slash}$ops
  79 \t\$(PERLDOC) -u ..${slash}ops${slash}$ops > ops${slash}$pod
  80 \t\$(CHMOD) 0644 ..${slash}ops${slash}$pod
  81
  82 END
  83         }
  84     }
  85
  86     $conf->data->set(
  87         TEMP_pod             => $TEMP_pod,
  88         TEMP_pod_build       => $TEMP_pod_build,
  89     );
  90
  91     return 1;
  92 }
  93
  94 sub _initial_content_check {
  95     my $self = shift;
  96     my ($conf, $content) = @_;
  97     if (! defined $content) {
  98         $conf->data->set(
  99             has_perldoc => 0,
 100             new_perldoc => 0,
 101             perldoc     => 'echo',
 102             TEMP_pod        => '',
 103             TEMP_pod_build  => '',
 104         );
 105         $self->set_result('no');
 106         return;
 107     }
 108     else {
 109         return 1;
 110     }
 111 }
 112
 113 sub _analyze_perldoc {
 114     my $self = shift;
 115     my ($cmd, $tmpfile, $content) = @_;
 116     my $version;
 117     if ( $content =~ m/^Unknown option:/ ) {
 118         $content = capture_output("$cmd perldoc") || '';
 119         if ($content =~ m/perldoc/) {
 120             $version = $self->_handle_old_perldoc();
 121         }
 122         else {
 123             $version = $self->_handle_no_perldoc();
 124         }
 125     }
 126     elsif ( open my $FH, '<', $tmpfile ) {
 127         local $/;
 128         $content = <$FH>;
 129         close $FH;
 130         $version = 2;
 131         $self->set_result('yes');
 132     }
 133     else {
 134         $version = $self->_handle_no_perldoc();
 135     }
 136     unlink $tmpfile;
 137     return $version;
 138 }
 139
 140 sub _handle_old_perldoc {
 141     my $self = shift;
 142     $self->set_result('yes, old version');
 143     return 1;
 144 }
 145
 146 sub _handle_no_perldoc {
 147     my $self = shift;
 148     $self->set_result('failed');
 149     return 0;
 150 }
 151
 152 sub _handle_version {
 153     my ($conf, $version, $cmd) = @_;
 154     $conf->data->set(
 155         has_perldoc => $version != 0 ? 1 : 0,
 156         new_perldoc => $version == 2 ? 1 : 0
 157     );
 158
 159     $conf->data->set( perldoc => $cmd ) if $version;
 160
 161     return 1;
 162 }
 163
 164 1;
 165
 166 # Local Variables:
 167 #   mode: cperl
 168 #   cperl-indent-level: 4
 169 #   fill-column: 100
 170 # End:
 171 # vim: expandtab shiftwidth=4: