File Coverage

blib/lib/Perl6/Perldoc.pm
Criterion Covered Total %
statement 24 24 100.0
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 32 32 100.0


line stmt bran cond sub pod time code
1             =encoding ISO8859-1
2             =cut
3              
4             package Perl6::Perldoc;
5              
6             our $VERSION = '0.000012';
7 3     3   18361 use warnings;
  3         5  
  3         89  
8 3     3   13 use strict;
  3         3  
  3         113  
9 3     3   12 use re 'eval';
  3         6  
  3         97  
10              
11 3     3   1531 use Filter::Simple;
  3         66789  
  3         15  
12              
13             my $IDENT = qr{ (?> [^\W\d] \w* ) }xms;
14             my $QUAL_IDENT = qr{ $IDENT (?: :: $IDENT)* }xms;
15             my $TO_EOL = qr{ (?> [^\n]* ) (?:\Z|\n) }xms;
16             my $HWS = qr{ (?> [^\S\n]+ ) }xms;
17             my $OHWS = qr{ (?> [^\S\n]* ) }xms;
18             my $BLANK_LINE = qr{ ^ $OHWS $ | (?= ^ = | \s* \z) }xms;
19             my $DIRECTIVE = qr{ config | encoding | use }xms;
20             my $OPT_EXTRA_CONFIG = qr{ (?> (?: ^ = $HWS $TO_EOL)* ) }xms;
21              
22              
23             # Recursive matcher for =DATA sections...
24              
25             my $DATA_PAT = qr{
26             ^ =
27             (?:
28             begin $HWS DATA $TO_EOL
29             $OPT_EXTRA_CONFIG
30             (.*?)
31             ^ =end $HWS DATA
32             |
33             for $HWS DATA $TO_EOL
34             $OPT_EXTRA_CONFIG
35             (.*?)
36             $BLANK_LINE
37             |
38             DATA \s
39             (.*?)
40             $BLANK_LINE
41             )
42             }xms;
43              
44              
45             # Recursive matcher for all other Perldoc sections...
46              
47 3     3   2577 use vars '$type';
  3         6  
  3         955  
48             my $POD_PAT; $POD_PAT = qr{
49             ^ =
50             (?:
51             (?:(?:begin|for) $HWS)? END
52             (?> .*) \z
53             |
54             begin $HWS ($IDENT) (?{ local $type = $^N}) $TO_EOL
55             $OPT_EXTRA_CONFIG
56             (?: ^ (??{$POD_PAT}) | . )*?
57             ^ =end $HWS (??{$type}) $TO_EOL
58             |
59             for $HWS $TO_EOL
60             $OPT_EXTRA_CONFIG
61             .*?
62             $BLANK_LINE
63             |
64             $DIRECTIVE $HWS $TO_EOL
65             $OPT_EXTRA_CONFIG
66             |
67             (?! end) $IDENT $TO_EOL
68             .*?
69             $BLANK_LINE
70             )
71             }xms;
72              
73             FILTER {
74             my @DATA;
75              
76             # Extract DATA sections, deleting them but preserving line numbering...
77             s{ ($DATA_PAT) }{
78             my ($data_block, $contents) = ($1,$+);
79              
80             # Special newline handling required under Windows...
81             if ($^O =~ /MSWin/) {
82             $contents =~ s{ \r\n }{\n}gxms;
83             }
84              
85             # Save the data...
86             push @DATA, $contents;
87              
88             # Delete it from the source code, but leave the newlines...
89             $data_block =~ tr[\n\0-\377][\n]d;
90              
91             $data_block;
92             }gxmse;
93              
94             # Collect all declared package names...
95             my %packages = (main=>1);
96             s{ (\s* package \s+ ($QUAL_IDENT)) }{
97             my ($package_decl, $package_name) = ($1,$2);
98             $packages{$package_name} = 1;
99             $package_decl;
100             }gxmse;
101              
102             # Delete all other pod sections, preserving newlines...
103 3     3   19 { no warnings;
  3         3  
  3         466  
104             s{ ($POD_PAT) }{ my $text = $1; $text =~ tr[\n\0-\377][\n]d; $text; }gxmse;
105             }
106              
107             # Consolidate data and open a filehandle to it...
108             local *DATA_glob;
109             my $DATA_as_str = join q{}, @DATA;
110             *DATA_glob = \$DATA_as_str;
111             *DATA_glob = \@DATA;
112 3     3   1408 open *DATA_glob, '<', \$DATA_as_str
  3         23  
  3         19  
113             or require Carp
114             and croak( "Can't set up *DATA handle ($!)" );
115              
116             # Alias each package's *DATA, @DATA, and $DATA...
117             for my $package (keys %packages) {
118 3     3   18 no strict 'refs';
  3         3  
  3         246  
119             *{$package.'::DATA'} = *DATA_glob;
120             }
121             }
122              
123             __END__