File Coverage

blib/lib/App/RecordStream/Operation/help/FromManual.pm
Criterion Covered Total %
statement 18 40 45.0
branch 0 12 0.0
condition 0 6 0.0
subroutine 6 10 60.0
pod 0 4 0.0
total 24 72 33.3


line stmt bran cond sub pod time code
1 1     1   6 use strict;
  1         2  
  1         23  
2 1     1   4 use warnings;
  1         1  
  1         30  
3              
4             package App::RecordStream::Operation::help::FromManual;
5 1     1   4 use base qw(App::RecordStream::Operation::help);
  1         1  
  1         266  
6              
7 1     1   432 use Pod::Perldoc;
  1         25482  
  1         42  
8 1     1   621 use File::Temp qw< tempfile >;
  1         12554  
  1         58  
9 1     1   6 use Scalar::Util qw< blessed >;
  1         3  
  1         304  
10              
11       0 0   sub init_help {}
12             sub init {
13 0     0 0   my $this = shift;
14 0           local @ARGV = ('-F', $this->pod_file);
15 0           Pod::Perldoc->run();
16             }
17              
18             sub pod_file {
19 0     0 0   my $this = shift;
20 0           my ($class, $pm) = $this->manual_class;
21 0           my $source = $INC{$pm};
22              
23             # Simple case: manual class is on disk already
24 0 0 0       if (not ref $source and -e $source) {
    0 0        
25 0           return $source;
26             }
27             # Fatpacked: read from the @INC hook
28             elsif (ref $source and blessed($source) =~ /^FatPacked::/) {
29 0 0         my $source_fh = $source->INC($pm)
30             or die "FatPacked INC entry failed?!";
31              
32 0           my ($tmp, $tmpfile) = tempfile( UNLINK => 1, TMPDIR => 1, SUFFIX => '.pm' );
33 0           print { $tmp } $_ while <$source_fh>;
  0            
34 0 0         close $tmp
35             or die "failed to close tempfile $tmpfile after writing: $!";
36 0           return $tmpfile;
37             }
38             else {
39 0           die "Don't know how to read source of $class where \$INC{$pm} = $source";
40             }
41             }
42              
43             sub manual_class {
44 0     0 0   my $this = shift;
45 0           my $page = (split /::/, ref $this)[-1];
46 0           my $class = "App::RecordStream::Manual::\u$page";
47 0           my $pm = "$class.pm";
48 0           $pm =~ s{::}{/}g;
49 0 0         require $pm
50             or die "Can't locate manual class $class: $!";
51 0 0         return wantarray ? ($class, $pm) : $class;
52             }
53              
54             1;