File Coverage

File:config/auto/perldoc.pm
Coverage:86.2%

linestmtbrancondsubcode
1# Copyright (C) 2001-2008, Parrot Foundation.
2
3 - 15
=head1 NAME

config/auto/perldoc - Check whether perldoc works

=head1 DESCRIPTION

Determines whether F<perldoc> exists on the system and, if so, which
version of F<perldoc> it is.

More specifically, we look for the F<perldoc> associated with the
instance of F<perl> with which F<Configure.pl> was invoked.

=cut
16
17package auto::perldoc;
18
19
2
2
2
2
use strict;
20
2
2
2
2
use warnings;
21
22
2
2
2
2
use File::Temp qw (tempfile );
23
2
2
2
2
use base qw(Parrot::Configure::Step);
24
2
2
2
2
use Parrot::Configure::Utils ':auto';
25
26
27sub _init {
28
2
2
    my $self = shift;
29
2
    my %data;
30
2
    $data{description} = q{Is perldoc installed};
31
2
    $data{result} = q{};
32
2
    return \%data;
33}
34
35sub runstep {
36
2
2
    my ( $self, $conf ) = @_;
37
38
2
    my $slash = $conf->data->get('slash');
39
2
    my $cmd = $conf->data->get('scriptdirexp_provisional') . $slash . q{perldoc};
40
2
    my ( $fh, $filename ) = tempfile( UNLINK => 1 );
41
2
50
    my $content = capture_output("$cmd -ud $filename perldoc") || undef;
42
43
2
50
    return 1 unless defined( $self->_initial_content_check($conf, $content) );
44
45
2
    my $version = $self->_analyze_perldoc($cmd, $filename, $content);
46
47
2
    _handle_version($conf, $version, $cmd);
48
49
2
    return 1;
50}
51
52sub _initial_content_check {
53
3
3
    my $self = shift;
54
3
    my ($conf, $content) = @_;
55
3
100
    if (! defined $content) {
56
1
        $conf->data->set(
57            has_perldoc => 0,
58            new_perldoc => 0,
59            perldoc => 'echo',
60        );
61
1
        $self->set_result('no');
62
1
        return;
63    }
64    else {
65
2
        return 1;
66    }
67}
68
69sub _analyze_perldoc {
70
2
2
    my $self = shift;
71
2
    my ($cmd, $tmpfile, $content) = @_;
72
2
    my $version;
73
2
50
50
    if ( $content =~ m/^Unknown option:/ ) {
74
0
0
        $content = capture_output("$cmd perldoc") || '';
75
0
0
        if ($content =~ m/perldoc/) {
76
0
            $version = $self->_handle_old_perldoc();
77        }
78        else {
79
0
            $version = $self->_handle_no_perldoc();
80        }
81    }
82    elsif ( open my $FH, '<', $tmpfile ) {
83
2
        local $/;
84
2
        $content = <$FH>;
85
2
        close $FH;
86
2
        $version = 2;
87
2
        $self->set_result('yes');
88    }
89    else {
90
0
        $version = $self->_handle_no_perldoc();
91    }
92
2
    unlink $tmpfile;
93
2
    return $version;
94}
95
96sub _handle_old_perldoc {
97
1
1
    my $self = shift;
98
1
    $self->set_result('yes, old version');
99
1
    return 1;
100}
101
102sub _handle_no_perldoc {
103
1
1
    my $self = shift;
104
1
    $self->set_result('failed');
105
1
    return 0;
106}
107
108sub _handle_version {
109
5
5
    my ($conf, $version, $cmd) = @_;
110
5
100
100
    $conf->data->set(
111        has_perldoc => $version != 0 ? 1 : 0,
112        new_perldoc => $version == 2 ? 1 : 0
113    );
114
115
5
100
    $conf->data->set( perldoc => $cmd ) if $version;
116
117
5
    return 1;
118}
119
1201;
121
122# Local Variables:
123# mode: cperl
124# cperl-indent-level: 4
125# fill-column: 100
126# End:
127# vim: expandtab shiftwidth=4: