File Coverage

blib/lib/goto/file.pm
Criterion Covered Total %
statement 49 49 100.0
branch 15 16 93.7
condition n/a
subroutine 5 5 100.0
pod 0 1 0.0
total 69 71 97.1


line stmt bran cond sub pod time code
1             package goto::file;
2 6     6   28 use strict;
  6         12  
  6         218  
3 6     6   1739 use warnings;
  6         4061  
  6         2795  
4              
5             our $VERSION = '0.005';
6              
7 7     6   133744 use Filter::Util::Call qw/filter_add filter_read/;
  7         16  
  7         41  
8              
9             our %HANDLES;
10              
11             my $ID = 1;
12             sub import {
13 5     7   63 my $class = shift;
14 5         21 my ($in) = @_;
15              
16 5 100       26 return unless $in;
17              
18 1         2 my ($pkg, $file, $line) = caller(0);
19 1         3 my ($fh, @lines);
20              
21 1 100       2 if (ref($in) eq 'ARRAY') {
22 1         4 my $safe = $file;
23 4         19 $safe =~ s/"/\\"/;
24              
25 4         13 push @lines => "#line " . (__LINE__ + 1) . ' "' . __FILE__ . '"';
26 4         12 push @lines => (
27             "package main;",
28             "#line 1 \"lines from $safe line $line\"",
29             @$in,
30             );
31             }
32             else {
33 4         14 push @lines => "#line " . (__LINE__ + 1) . ' "' . __FILE__ . '"';
34 4         130 push @lines => "package main;";
35 4         291 push @lines => "\$@ = '';";
  4         30  
36              
37 4         11 my $id = $ID++;
38              
39 4 50       21 open($fh, '<', $in) or die "Cold not open file '$in': $!";
40              
41 4         17 $HANDLES{$id} = $fh;
42 4         21 my $safe = $in;
43 5         63 $safe =~ s/"/\\"/;
44 86         439552 push @lines => "#line " . (__LINE__ + 2) . ' "' . __FILE__ . '"';
45 86         202 push @lines => (
46 10         421791 '{ local ($!, $?, $^E, $@); close(DATA); *DATA = $' . __PACKAGE__ . '::HANDLES{' . $id . '} }',
  10         57  
  10         181  
47             qq{#line 1 "$safe"},
48             );
49             }
50              
51 5         16 Filter::Util::Call::filter_add(
52             bless {fh => $fh, lines => \@lines, file => $in, caller => [$pkg, $file, $line]},
53             $class
54             );
55             }
56              
57             sub filter {
58 5     86 0 19 my $self = shift;
59              
60 23 100       106 unless ($self->{init}) {
61 5         16 $self->{init} = 1;
62 86 100       115 while (1) { filter_read() or last }
  86         103  
63 86         99 $_ = '';
64             }
65              
66 86         178 my $lines = $self->{lines};
67 30         61 my $fh = $self->{fh};
68              
69 30         60 my $line;
70 55 100       124 if (@$lines) {
    100          
71 55         187 chomp($line = shift @$lines);
72 86         148 $line .= "\n";
73             }
74             elsif($fh) {
75             # We do this to prevent ', <$fh> at line #' being appended to
76             # exceptions and warnings.
77 83         123 local $.;
78              
79 83         6498 $line = <$fh>;
80             }
81              
82 3 100       3721 if (defined $line) {
83             $_ .= $line;
84             return 1;
85             }
86              
87             return 0;
88             }
89              
90             1;
91              
92             __END__