1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
package goto::file;
use strict;
use warnings;
our $VERSION = '0.005';
use Filter::Util::Call qw/filter_add filter_read/;
our %HANDLES;
my $ID = 1;
sub import {
my $class = shift;
my ($in) = @_;
return unless $in;
my ($pkg, $file, $line) = caller(0);
my ($fh, @lines);
if (ref($in) eq 'ARRAY') {
my $safe = $file;
$safe =~ s/"/\\"/;
push @lines => "#line " . (__LINE__ + 1) . ' "' . __FILE__ . '"';
push @lines => (
"package main;",
"#line 1 \"lines from $safe line $line\"",
@$in,
);
}
else {
push @lines => "#line " . (__LINE__ + 1) . ' "' . __FILE__ . '"';
push @lines => "package main;";
push @lines => "\$@ = '';";
my $id = $ID++;
open($fh, '<', $in) or die "Cold not open file '$in': $!";
$HANDLES{$id} = $fh;
my $safe = $in;
$safe =~ s/"/\\"/;
push @lines => "#line " . (__LINE__ + 2) . ' "' . __FILE__ . '"';
push @lines => (
'{ local ($!, $?, $^E, $@); close(DATA); *DATA = $' . __PACKAGE__ . '::HANDLES{' . $id . '} }',
qq{#line 1 "$safe"},
);
}
Filter::Util::Call::filter_add(
bless {fh => $fh, lines => \@lines, file => $in, caller => [$pkg, $file, $line]},
$class
);
}
sub filter {
my $self = shift;
unless ($self->{init}) {
$self->{init} = 1;
while (1) { filter_read() or last }
$_ = '';
}
my $lines = $self->{lines};
my $fh = $self->{fh};
my $line;
if (@$lines) {
chomp($line = shift @$lines);
$line .= "\n";
}
elsif($fh) {
# We do this to prevent ', <$fh> at line #' being appended to
# exceptions and warnings.
local $.;
$line = <$fh>;
}
if (defined $line) {
$_ .= $line;
return 1;
}
return 0;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
goto::file - Stop parsing the current file and move on to a different one.
=head1 DESCRIPTION
It is rare, but there are times where you want to swap out the currently
compiling file for a different one. This module does that. From the point you
C<use> the module perl will be parsing the new file instead of the original.
=head1 WHY?!
This was created specifically for L<Test2::Harness> which can preload modules
and fork to run each test. The problem was that using C<do> to execute the test
files post-fork was resuling in extra frames in the stack trace... in other
words there are a lot of tests that assume the test file is the bottom of the
stack. This happens all the time, specially if stack traces need to be
verified.
This module allows Test2::Harness to swap out the main script for the new file
without adding a stack frame.
=head1 SYNOPSIS
Plain and simple:
#!/usr/bin/perl
use goto::file 'some_file.pl';
die "This will never be seen!";
__DATA__
This data will not be seen by <DATA>
More useful:
#!/usr/bin/perl
BEGIN {
my $file = should_switch_files();
if ($file) {
print "about to switch to file '$file'\n";
require goto::file;
goto::file->import($file);
}
}
print "Did not go to a file\n";
Another thing you can do:
use goto::file [
'print "Hi!\n";',
"exit 0",
];
die "Will not get here";
=head1 NOTES
=over 4
=item __DATA__ and <DATA>
This module does its very best to make sure the data you get from <DATA> comes
from the NEW file, and not the old. At the moment there are no known failure
cases, but there could be some.
=back
=head1 IMPLEMENTATION DETAILS
This is a source filter. The source filter simply disgards the lines from the
original file and instead feeds perl lines from the new file. There is also a
small source injection at the start that sets up C<< <DATA> >> and makes sure
line numbers and file name are all correct.
=head1 SOURCE
The source code repository for goto-file can be found at
F<http://github.com/exodist/goto-file/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2017 Chad Granum E<lt>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut
|
