This file is indexed.

/usr/share/perl5/Shell/Perl.pm is in libshell-perl-perl 0.0023-1.

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

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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
package Shell::Perl;

use strict;
use warnings;

# /Id: Perl.pm 1131 2007-01-27 17:43:35Z me / # don't erase that for now
# $Id: /iperl/lib/Shell/Perl.pm 2317 2008-03-09T16:22:00.577930Z a.r.ferreira@gmail.com  $

our $VERSION = '0.0023';

use base qw(Class::Accessor); # soon use base qw(Shell::Base);
Shell::Perl->mk_accessors(qw( out_type dumper context package term ornaments )); # XXX use_strict

use Term::ReadLine;
use Shell::Perl::Dumper;

# out_type defaults to one of 'D', 'DD', 'Y', 'P';
# dumper XXX
# context defaults to 'list'
# package defaults to __PACKAGE__ . '::sandbox'
# XXX use_strict defaults to 0

sub new {
    my $self = shift;
    my $sh = $self->SUPER::new({
                           context => 'list', # print context
                           @_ });
    $sh->_init;
    return $sh;
}

my %dumper_for = (
   'D' => 'Shell::Perl::Data::Dump',
   'DD' => 'Shell::Perl::Data::Dumper',
   'Y' => 'Shell::Perl::Dumper::YAML',
   'Data::Dump' => 'Shell::Perl::Data::Dump',
   'Data::Dumper' => 'Shell::Perl::Data::Dumper',
   'YAML' => 'Shell::Perl::Dumper::YAML',
   'DDS' => 'Shell::Perl::Data::Dump::Streamer',

   'P' => 'Shell::Perl::Dumper::Plain',
   'plain' => 'Shell::Perl::Dumper::Plain',
);

sub _init {
    my $self = shift;

    # loop until you find one available alternative for dump format
    my $dumper_class;
    for my $format ( qw(D DD DDS Y P) ) {
        if ($dumper_for{$format}->is_available) {
            #$self->print("format: $format\n");
            $self->set_out($format);
            last
        } # XXX this is not working 100% - and I have no clue about it
    }

    $self->set_package( __PACKAGE__ . '::sandbox' );

}

sub _shell_name {
    require File::Basename;
    return File::Basename::basename($0);
}

sub print {
    my $self = shift;
    print {$self->term->OUT} @_;
}

## # XXX remove: code and docs
## sub out {
##     my $self = shift;
##
##     # XXX I want to improve this: preferably with an easy way to add dumpers
##     if ($self->context eq 'scalar') {
##         $self->print($self->dumper->dump_scalar(shift), "\n");
##     } else { # list
##         $self->print($self->dumper->dump_list(@_), "\n");
##     }
## }

# XXX I want to improve this: preferably with an easy way to add dumpers

=begin private

=item B<_print_scalar>

    $sh->_print_scalar($answer);

That corresponds to the 'print' in the read-eval-print
loop (in scalar context). It outputs the evaluation result
after passing it through the current dumper.

=end private

=cut

sub _print_scalar { # XXX make public, document
    my $self = shift;
    $self->print($self->dumper->dump_scalar(shift));
}

=begin private

=item B<_print_scalar>

    $sh->_print_list(@answers);

That corresponds to the 'print' in the read-eval-print
loop (in list context). It outputs the evaluation result
after passing it through the current dumper.

=end private

=cut

sub _print_list { # XXX make public, document
    my $self = shift;
    $self->print($self->dumper->dump_list(@_));
}

sub _warn {
    shift;
    my $shell_name = _shell_name;
    warn "$shell_name: ", @_, "\n";
}

sub set_out {
    my $self = shift;
    my $type = shift;
    my $dumper_class = $dumper_for{$type};
    if (!defined $dumper_class) {
        $self->_warn("unknown dumper $type");
        return;
    }
    if ($dumper_class->is_available) {
        $self->dumper($dumper_class->new);
        $self->out_type($type);
    } else {
        $self->_warn("can't load dumper $dumper_class");
    }
}

sub _ctx {
    my $context = shift;

    if ($context =~ /^(s|scalar|\$)$/i) {
        return 'scalar';
    } elsif ($context =~ /^(l|list|@)$/i) {
        return 'list';
    } elsif ($context =~ /^(v|void|_)$/i) {
        return 'void';
    } else {
        return undef;
    }
}

sub set_ctx {
    my $self    = shift;
    my $context = _ctx shift;

    if ($context) {
        $self->context($context);
    } else {
        $self->_warn("unknown context $context");
    }
}

sub set_package {
    my $self    = shift;
    my $package = shift;

    if ($package =~ /( [a-zA-Z_] \w*  :: )* [a-zA-Z_] \w* /x) {
        $self->package($package);

        no strict 'refs';
        *{ "${package}::quit" } = sub { $self->quit };
    } else {
        $self->_warn("bad package name $package");
    }
}

use constant HELP =>
    <<'HELP';
Shell commands:           (begin with ':')
  :e(x)it or :q(uit) - leave the shell
  :set out (D|DD|DDS|Y|P) - setup the output format
  :set ctx (scalar|list|void|s|l|v|$|@|_) - setup the eval context
  :set package <name> - set package in which shell eval statements
  :reset - reset the environment
  :dump history <file> - (experimental) print the history to STDOUT or a file
  :h(elp) - get this help screen

HELP

sub help {
    print HELP;
}

# :reset is a nice idea - but I wanted more like CPAN reload
# I retreated the current implementation of :reset
#    because %main:: is used as the evaluation package
#    and %main:: = () is too severe by now

sub reset {
    my $self = shift;
    my $package = $self->package;
    return if $package eq 'main'; # XXX don't reset %main::
    no strict 'refs';
    %{"${package}::"} = ();
    #%main:: = (); # this segfaults at my machine
}

sub prompt_title {
    my $self = shift;
    my $shell_name = _shell_name;
    my $sigil = { scalar => '$', list => '@', void => '' }->{$self->{context}};
    return "$shell_name $sigil> ";
}

sub _readline {
    my $self = shift;
    return $self->term->readline($self->prompt_title);
}

sub _history_file { # XXX
    require Path::Class;
    require File::HomeDir;
    return Path::Class::file( File::HomeDir->my_home, '.pirl-history' )->stringify;
}

sub _read_history { # XXX belongs to Shell::Perl::ReadLine
    my $term = shift;
    my $h    = _history_file;
    #warn "read history from $h\n"; # XXX
    if ( $term->Features->{readHistory} ) {
        $term->ReadHistory( $h );
    } elsif ( $term->Features->{setHistory} ) {
        if ( -e $h ) {
            require File::Slurp;
            my @h = File::Slurp::read_file( $h );
            chomp @h;
            $term->SetHistory( @h );
        }
    } else {
        # warn "Your ReadLine doesn't support setHistory\n";
    }

}

sub _write_history { # XXX belongs to Shell::Perl::ReadLine
   my $term = shift;
   my $h    = _history_file;
   #warn "write history to $h\n"; # XXX
   if ( $term->Features->{writeHistory} ) {
       $term->WriteHistory( $h );
   } elsif ( $term->Features->{getHistory} ) {
       require File::Slurp;
       my @h = map { "$_\n" } $term->GetHistory;
       File::Slurp::write_file( $h, @h );
   } else {
       # warn "Your ReadLine doesn't support getHistory\n";
   }
}

sub _new_term {
    my $self = shift;
    my $name = shift;
    my $term = Term::ReadLine->new( $name );
    _read_history( $term );
    return $term;
}

sub run {
    my $self = shift;
    my $shell_name = _shell_name;
    $self->term( my $term = $self->_new_term( $shell_name ) );
    $term->ornaments($self->ornaments); # XXX
    my $prompt = "$shell_name > ";

    print "Welcome to the Perl shell. Type ':help' for more information\n\n";

    REPL: while ( defined ($_ = $self->_readline) ) {

        # trim
        s/^\s+//g;
        s/\s+$//g;

        # Shell commands start with ':' followed by something else
        # which is not ':', so we can use things like '::my_subroutine()'.
        if (/^:[^:]/) {
            last REPL if /^:(exit|quit|q|x)/;
            $self->set_out($1) if /^:set out (\S+)/;
            $self->set_ctx($1) if /^:set ctx (\S+)/;
            $self->set_package($1) if /^:set package (\S+)/;
            $self->reset if /^:reset/;
            $self->help if /^:h(elp)?/;
            $self->dump_history($1) if /^:dump history(?:\s+(\S*))?/;
            # unknown shell command ?!
            next REPL;
        }

        my $context;
        $context = _ctx($1) if s/#(s|scalar|\$|l|list|\@|v|void|_)\z//;
        $context = $self->context unless $context;
        if ( $context eq 'scalar' ) {
            my $out = $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
            $self->_print_scalar($out);
        } elsif ( $context eq 'list' ) {
            my @out = $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
            $self->_print_list(@out);
        } elsif ( $context eq 'void' ) {
            $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
        } else {
            # XXX should not happen
        }

    }
    $self->quit;

}

# $shell->eval($exp)
sub eval {
    my $self = shift;
    my $exp = shift;
    my $package = $self->package;
    # XXX gotta restore $_, etc.

    return eval <<CHUNK;
       package $package; # XXX
       no strict qw(vars subs);
#line 1
       $exp
CHUNK
    # XXX gotta save $_, etc.
}

sub quit {
    my $self = shift;
    _write_history( $self->term );
    $self->print( "Bye.\n" ); # XXX
    exit;
}

sub run_with_args {
    my $self = shift;

    # XXX do something with @ARGV (Getopt)
    my %options = ( ornaments => 1 );
    if ( @ARGV ) {
        # only require Getopt::Long if there are actually command line arguments
        require Getopt::Long;
        Getopt::Long::GetOptions( \%options, 'ornaments!', 'version|v' );
    }

    my $shell = Shell::Perl->new(%options);
    if ( $options{version} ) {
        $shell->_show_version;
    } else {
        $shell->run;
    }
}

sub _show_version {
    my $self = shift;
    printf "This is %s, version %s (%s, using Shell::Perl %s)\n",
           _shell_name,
           $main::VERSION,
           $0,
           $Shell::Perl::VERSION;
    exit 0;
}

sub dump_history {
    my $self = shift;
    my $file = shift;

    if ( !$self->term->Features->{getHistory} ) {
        print "Your Readline doesn't support getHistory\n";
        return;
    }

    if ( $file ) {
        open( my $fh, ">>", $file )
            or do { warn "Couldn't open '$file' for history dump\n"; return; };
        for ( $self->term->GetHistory ) {
            print $fh $_, "\n";
        }
        close $fh;

        print "Dumped history to '$file'\n\n";
    } else {
        print $_, "\n" for($self->{term}->GetHistory);
        print "\n";
    }
    return 1;
}

1;

# OUTPUT Data::Dump, Data::Dumper, YAML, others
# document: use a different package when eval'ing
# reset the environment
# implement shell commands (:quit, :set, :exit, etc.)
# how to implement array contexts?
#    IDEA:    command  ":set ctx scalar | list | void"
#             terminators "#s" "#l" "#v" "#$" #@ #_
# allow multiline entries. how?

##sub set {} # sets up the instance variables of the shell
##
##sub run {} # run the read-eval-print loop
##
##sub read {} # read a chunk
##
##sub readline {} # read a line
##
##sub eval {}
##
##sub print {}
##
##sub warn {}
##
##sub help { shift->print(HELP) }
##
##sub out { ? }

# svn:keywords Id
# svn:eol-style LF

__END__

=pod

=encoding utf-8

=head1 NAME

Shell::Perl - A read-eval-print loop in Perl

=head1 SYNOPSYS

    use Shell::Perl;
    Shell::Perl->run_with_args;

=head1 DESCRIPTION

This is the implementation of a command-line interpreter for Perl.
I wrote this because I was tired of using B<irb> when
needing a calculator with a real language within. Ah,
that and because it was damn easy to write it.

This module is the heart of the B<pirl> script provided with
B<Shell-Perl> distribution, along with this module.

=head2 EXAMPLE SESSION

    $ pirl
    Welcome to the Perl shell. Type ':help' for more information


    pirl @> 1+1
    2

    pirl @> use YAML qw(Load Dump);
    ()

    pirl @> $data = Load("--- { a: 1, b: [ 1, 2, 3] }\n");
    { a => 1, b => [1, 2, 3] }

    pirl @> $var = 'a 1 2 3'; $var =~ /(\w+) (\d+) (\d+)/
    ("a", 1, 2)

    pirl @> :q

=head2 COMMANDS

Most of the time, the shell reads Perl statements, evaluates them
and outputs the result.

There are a few commands (started by ':') that are handled
by the shell itself.

=over 4

=item :h(elp)

Handy for remembering what the shell commands are.

=item :q(uit)

Leave the shell. The Perl statement C<exit> will work too.

SYNONYMS: :exit, :x

=item :set out (D|DD|DDS|Y|P)

Changes the dumper for the expression results used before
output. The current supported are:

=over 4

=item D

C<Data::Dump>

=item DD

C<Data::Dumper>, the good and old core module

=item DDS

C<Data::Dump::Streamer>

=item Y

C<YAML>

=item P

a plain dumper ("$ans" or "@ans")

=back

When creating the shell, the dump format is searched
among the available ones in the order "D", "DD", "DDS", "Y"
and "P". That means L<Data::Dump> is preferred and will
be used if available/installed. Otherwise, L<Data::Dumper>
is tried, and so on.

Read more about dumpers at L<Shell::Perl::Dumper>.

=item :set ctx (scalar|list|void|s|l|v|$|@|_)

Changes the default context used to evaluate the entered expression.
The default is C<'list'>.

Intuitively, 'scalar', 's' and '$' are synonyms, just
like 'list', 'l', and '@' or 'void', 'v', '_'.

There is a nice way to override the default context in a given expression.
Just a '#' followed by one of 'scalar|list|void|s|l|v|$|@|_' at the end
of the expression.

    pirl @> $var = 'a 1 2 3'; $var =~ /(\w+) (\d+) (\d+)/
    ("a", 1, 2)

    pirl @> $var = 'a 1 2 3'; $var =~ /(\w+) (\d+) (\d+)/ #scalar
    1

=item :reset

Resets the environment, erasing the symbols created
at the current evaluation package. See the
section L<"ABOUT EVALUATION">.

=back

=head2 METHODS

Remember this is an alpha version, so the API may change
and that includes the methods documented here. So consider
this section as implementation notes for a while.

In later versions, some of these information may be promoted
to a public status. Others may be hidden or changed and
even disappear without further notice.

=over 4

=item B<new>

    $sh = Shell::Version->new;

The constructor.

=item B<run_with_args>

    Shell::Perl->run_with_args;

Starts the read-eval-print loop after reading
options from C<@ARGV>. It is a class method.

If an option B<-v> or B<--version> is provided,
instead of starting the REPL, it prints
the script identification and exits with 0.

   $ pirl -v
   This is pirl, version 0.0017 (bin/pirl, using Shell::Perl 0.0017)

=item B<run>

    $sh->run;

The same as C<run_with_args> but with no code for
interpreting command-line arguments. It is an instance method,
so that C<Shell::Perl->run_with_args> is kind of:

    Shell::Perl->new->run;

=item B<eval>

    $answer = $sh->eval($exp);
    @answer = $sh->eval($exp);

Evaluates the user input given in C<$exp> as Perl code and returns
the result. That is the 'eval' part of the
read-eval-print loop.

=item B<print>

    $sh->print(@args);

Prints a list of args at the output stream currently used
by the shell.

=item B<help>

    $sh->help;

Outputs the help as provided by the command ":help".

=item B<reset>

    $sh->reset;

Does nothing by now, but it will.

=item B<dump_history>

    $sh->dump_history();
    $sh->dump_history($file);

Prints the readline history to C<STDOUT> or the optional file.
Used to implement experimental command ":dump history".

This is experimental code and should change in the future.
More control should be added and integrated with other
terminal features.

=item B<set_ctx>

    $sh->set_ctx($context);

Assigns to the current shell context. The argument
must be one of C< ( 'scalar', 'list', 'void',
's', 'l', 'v', '$', '@', '_' ) >.

=item B<set_package>

    $sh->set_package($package);

Changes current evaluation package. Doesn't change if the
new package name is malformed.

=item B<set_out>

    $sh->set_out($dumper);

Changes the current dumper used for printing
the evaluation results. Actually must be one of
"D" (for Data::Dump), "DD" (for Data::Dumper),
"DDS" (for Data::Dump::Streamer),
"Y" (for YAML) or "P" (for plain string interpolation).

=item B<prompt_title>

    $prompt = $sh->prompt_title;

Returns the current prompt which changes with
executable name and context. For example,
"pirl @>", "pirl $>", and "pirl >".

=item B<quit>

    $sh->quit;

This method is invoked when these commands and
statements are parsed by the REPL:

    :q
    :quit
    :x
    :exit
    quit
    exit

It runs the shutdown procedures for a smooth
termination of the shell. For example, it
saves the terminal history file.

=back

=head1 GORY DETAILS

=head2 ABOUT EVALUATION

When the statement read is evaluated, this is done
at a different package, which is C<Shell::Perl::sandbox>
by default.

So:

    $ perl -Mlib=lib bin/pirl
    Welcome to the Perl shell. Type ':help' for more information

    pirl @> $a = 2;
    2

    pirl @> :set out Y # output in YAML

    pirl @> \%Shell::Perl::sandbox::
    ---
    BEGIN: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: BEGIN
    a: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: a
      SCALAR: 2

This package serves as an environment for the current
shell session and :reset can wipe it away.

    pirl @> :reset

    pirl @> \%Shell::Perl::sandbox::
    ---
    BEGIN: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: BEGIN


=head1 TO DO

There is a lot to do, as always. Some of the top priority tasks are:

=over 4

=item *

Accept multiline statements;.

=item *

Refactor the code to promote easy customization of features.

=back

=head1 SEE ALSO

This project is hosted at Google Code:

    http://code.google.com/p/iperl/

To know about interactive Perl interpreters, there are two
FAQS contained in L<perlfaq3> which are good starting points.
Those are

    How can I use Perl interactively?
    http://perldoc.perl.org/perlfaq3.html#How-can-I-use-Perl-interactively%3f

    Is there a Perl shell?
    http://perldoc.perl.org/perlfaq3.html#How-can-I-use-Perl-interactively%3f

An extra list of Perl shells can be found here:

    http://www.focusresearch.com/gregor/document/psh-1.1.html#other_perl_shells

=head1 BUGS

It is a one-line evaluator by now.

I don't know what happens if you eval within an eval.
I don't expect good things to come. (Lorn who prodded
me about this will going to find it out and then
I will tell you.)

There are some quirks with Term::Readline (at least on Windows).

There are more bugs. I am lazy to collect them all and list them now.

Please report bugs via CPAN RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Shell-Perl>
or L<mailto://bugs-Shell-Perl@rt.cpan.org>.

=head1 AUTHORS

Adriano R. Ferreira, E<lt>ferreira@cpan.orgE<gt>

Caio Marcelo, E<lt>cmarcelo@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007–2011 by Adriano R. Ferreira

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: