This file is indexed.

/usr/bin/iperl is in libapp-repl-perl 0.012-1.

This file is owned by root:root, with mode 0o755.

The actual contents of the file can be viewed below.

  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
#! /usr/bin/env perl
use strict;
use warnings;
use Term::ANSIColor ':constants';
$Term::ANSIColor::AUTORESET = 1;

# ----------------------------------------------------------------------
# This first, to keep PadWalker away from lexical variables below.
sub scoped_eval {
  print MAGENTA @_ if $App::REPL::DEBUG;
  eval shift;
  print BOLD YELLOW $@ if $@;
}

use PadWalker 'peek_my';
use PPI;
use PPI::Find;
use Data::Dumper;
use Symbol;
use Term::ReadLine;
$App::REPL::DEBUG = 0;

{ my $in_package = 'App::REPL';
  sub in_package { @_ ? $in_package = shift : $in_package }
}

# ----------------------------------------------------------------------
# Added RESET as the color somehow bleeds into the prompt
# -- when we use Term::ReadLine
{ my $prompt;
  my $term = Term::ReadLine->new('iperl');
  sub pnew  { $prompt = RESET . in_package . ' _ ' }
  sub pcont { $prompt = RESET . in_package . '. ' }
  sub prompt {
    my $s = $term->readline($prompt);
    $term->addhistory($s) if defined($s) and $s =~ /\S/;
    $s
  }
  pnew;
  $term->ornaments(0)
}

sub eek { print STDERR BOLD RED @_, "\n"; goto REPL }


# ----------------------------------------------------------------------
# Magic.  This allows 'my' variables assigned within the eval to carry
# through subsequent evals -- unless the eval'd returns from the eval,
# in which case the next eval will get the same variables.
#--
use constant PRO_IN => <<'EOP';
  use App::REPL;
  use strict;
  no warnings 'void';
EOP
sub PRO {
  my $r = "no strict 'refs';\n"
        . "package @{[in_package]};\n";
  my $h = do { no strict 'refs'; ${in_package . '::REPL::env'} || {}};
  for (keys %$h) {
    /^(.)/;
    $r .= "my $_ = $1" . q,{${", . in_package . q,::REPL::env"}->, . "{'$_'}};\n"
  }
  $r . PRO_IN
}
use constant EPI => <<'EOE';
  ;
  no strict 'refs';
  for (Symbol::qualify('')) { s/::$//; main::in_package($_) }
  ${main::in_package . '::REPL::env'} = PadWalker::peek_my(0)
EOE

# ----------------------------------------------------------------------
# More magic.  This finds the final statement of some Perl, wherever
# that statement may be (even if its result cannot escape the overall
# evaluation), and saves its value in $App::REPL::ret
#--
$App::REPL::ret = '';
{ my $f = PPI::Find->new(sub { shift->isa('PPI::Statement') });
  sub save_ret {
    my $d = shift;
  
    # don't even try if it contains something troublesome.
    return $d->serialize if has_troublesome($d);
  
    my @s = $f->in($d);
    for (reverse @s) {
      next if within_constructor($_, $d);
      print Dumper $d if $App::REPL::DEBUG > 1;
      unshift @{$_->{children}},
        bless({content => '$App::REPL::ret'}, 'PPI::Token::Symbol'),
        bless({content => '='},               'PPI::Token::Operator');
      return $d->serialize
    }
  
    # try and save the whole thing
    return '$App::REPL::ret = ' . $d->serialize if @s;

    # give up
    $d->serialize
  }
}


{ my %troublesome = map { $_, 1 } qw(sub package use require my our local);
  my $f = PPI::Find->new(sub {
    return 0 unless (my $e = shift)->isa('PPI::Token::Word');
    return 1 if exists $troublesome{$e->{content}};
    0
  });
  sub has_troublesome { $f->in(shift) } 
}
  
sub dump_ret {
  return if ref $_[0] eq 'CODE';
  print BOLD CYAN Dumper $App::REPL::ret if $App::REPL::ret;
}

{ my $fc = PPI::Find->new(sub { $_[0]->isa('PPI::Structure::Constructor')
                             or $_[0]->isa('PPI::Structure::Block') });
  sub within_constructor {
    my ($s, $d) = @_;
    my $fs = PPI::Find->new(sub { shift eq $s });
    for ($fc->in($d)) {
      return 1 for $fs->in($_);
    }
    0
  }
}

# ----------------------------------------------------------------------
# The PPI here handles the rest of the magic: it detects unfinished
# blocks and such so that the repl can request more lines until they
# complete.  Note that this does -not- handle e.g. qw(
#--
{ my $f = PPI::Find->new(sub {
    my %h = %{+shift};
    (exists $h{start} and !exists $h{finish}) ? 1 : 0
  });
  sub repl {
    my $s = '';
    REPL: while (defined($_ = prompt)) {
      $s .= "\n" . $_;
      my $d = PPI::Document->new(\$s);
      if ($f->in($d)) {
        pcont
      }
      else {
        scoped_eval PRO . save_ret($d) . EPI;
        dump_ret;
        $App::REPL::ret = '';
        $s = '';
        pnew
      }
    }
  }
}


# ----------------------------------------------------------------------
package App::REPL;
main::repl();



# ----------------------------------------------------------------------
BEGIN {
  # Patch PPI 1.118 into suitability; subsequent versions should work fine.
  # Yes, this is somewhat wrong, and will go away as soon as PPI >1.118
  # comes out -- but in these early versions of App::REPL , it should be
  # OK.
  return unless $PPI::VERSION eq 1.118;
  print "#-- Oh, you have PPI 1.118 -- we need to patch it up a bit.\n";
  no warnings 'redefine';
  package PPI::Find;
  sub _execute {
          my $self   = shift;
          my $wanted = $self->{wanted};
          my @queue  = ( $self->{in} );

          # Pull entries off the queue and hand them off to the wanted function
          while ( my $Element = shift @queue ) {
                  my $rv = &$wanted( $Element, $self->{in} );

                  # Add to the matches if returns true
                  push @{$self->{matches}}, $Element if $rv;
                  
                  # Continue and don't descend if it returned undef
                  # or if it doesn't have children
                  next unless defined $rv;
                  next unless $Element->isa('PPI::Node');

                  # Add the children to the head of the queue
                  if ( $Element->isa('PPI::Structure') ) {
                          unshift @queue, $Element->finish if $Element->finish;
                          unshift @queue, $Element->children;
                          unshift @queue, $Element->start if $Element->start;
                  } else {
                          unshift @queue, $Element->children;
                  }
          }

          1;
  }
}