+{
+ my %cached; # Conceal cached sources: ( path => [ [ deps ], source, -M ] )
+
+ # Given a filename and optional level (level should be 0 if the caller isn't
+ # source() itself), and optional linespec (used by PLP::Functions::Include),
+ # this function parses a PLP file and returns Perl code, ready to be eval'ed
+ sub source {
+ my ($file, $level, $linespec, $path) = @_;
+ our $use_cache;
+
+ # $file is displayed, $path is used. $path is constructed from $file if
+ # not given.
+
+ $level = 0 unless defined $level;
+ $linespec = '1' unless defined $linespec;
+
+ if ($level > 128) {
+ %cached = ();
+ return $level
+ ? qq{\cQ; die qq[Include recursion detected]; print q\cQ}
+ : qq{\n#line $linespec\ndie qq[Include recursion detected];};
+ }
+
+ my $in_block = 0; # 1 => "<:", 2 => "<:="
+
+ $path ||= File::Spec->rel2abs($file);
+
+ my $source_start = $level
+ ? qq/\cQ;\n#line 1 "$file"\n$PLP::print q\cQ/
+ : qq/\n#line 1 "$file"\n$PLP::print q\cQ/;
+
+ if ($use_cache and exists $cached{$path}) {
+ BREAKOUT: {
+ my @checkstack = ($path);
+ my $item;
+ my %checked;
+ while (defined(my $item = shift @checkstack)) {
+ next if $checked{$item};
+ last BREAKOUT if $cached{$item}[2] > -M $item;
+ $checked{$item} = 1;
+ push @checkstack, @{ $cached{$item}[0] }
+ if @{ $cached{$item}[0] };
+ }
+ return $level
+ ? $source_start . $cached{$path}[1]
+ : $source_start . $cached{$path}[1] . "\cQ";
+ }
+ }
+
+ $cached{$path} = [ [ ], undef, undef ] if $use_cache;
+
+ my $linenr = 0;
+ my $source = '';
+
+ local *SOURCE;
+ open SOURCE, '<', $path or return $level
+ ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
+ : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
+
+ LINE:
+ while (defined (my $line = <SOURCE>)) {
+ $linenr++;
+ for (;;) {
+ $line =~ /
+ \G # Begin where left off
+ ( \z # End
+ | <:=? | :> # PLP tags <:= ... :> <: ... :>
+ | <\([^)]*\)> # Include tags <(...)>
+ | <[^:(][^<:]* # Normal text
+ | :[^>][^<:]* # Normal text
+ | [^<:]* # Normal text
+ )
+ /gxs;
+ next LINE unless length $1;
+ my $part = $1;
+ if ($part eq '<:=' and not $in_block) {
+ $in_block = 2;
+ $source .= "\cQ, (";
+ } elsif ($part eq '<:' and not $in_block) {
+ $in_block = 1;
+ $source .= "\cQ; ";
+ } elsif ($part eq ':>' and $in_block) {
+ $source .= (
+ $in_block == 2
+ ? "), q\cQ" # 2
+ : "; $PLP::print q\cQ" # 1
+ );
+ $in_block = 0;
+ } elsif ($part =~ /^<\((.*?)\)>\z/ and not $in_block) {
+ my $ipath = File::Spec->rel2abs(
+ $1, File::Basename::dirname($path)
+ );
+ $source .= source($1, $level + 1, undef, $ipath) .
+ qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
+ push @{ $cached{$path}[0] }, $ipath;
+ } else {
+ $part =~ s/\\/\\\\/ unless $in_block;
+ $source .= $part;
+ }
+ }
+ }
+
+ if ($in_block) {
+ $source .= (
+ $in_block == 2
+ ? "), q\cQ" # 2
+ : "; $PLP::print q\cQ" # 1
+ );
+ }
+
+ if ($use_cache) {
+ $cached{$path}[1] = $source;
+ $cached{$path}[2] = -M $path;
+ }
+
+ return $level
+ ? $source_start . $source
+ : $source_start . $source . "\cQ";
+ }