This file is indexed.

/usr/bin/perlsh is in libterm-readline-gnu-perl 1.28-2build1.

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
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
#!/usr/bin/perl
#
#	$Id: perlsh 475 2014-12-13 03:20:00Z hayashi $	
#
#	Copyright (c) 1996 Hiroo Hayashi. All Rights Reserved.
#
#	This program is free software; you can redistribute it and/or
#	modify it under the same terms as Perl itself.

=head1 NAME

perlsh - one-line perl evaluator with line editing function and
	 variable name completion function

=head1 SYNOPSIS

  perlsh

=head1 DESCRIPTION

This program reads input a line, and evaluates it by perl interpreter,
and prints the result.  If the result is a list value then each value
of the list is printed line by line.  This program can be used as a
very strong calculator which has whole perl functions.

This is a sample program Term::ReadLine::Gnu module.  When you input a
line, the line editing function of GNU Readline Library is available.
Perl symbol name completion function is also available.

=cut

package PerlSh;

use strict;
use warnings;
use Term::ReadLine;
use POSIX;			#  for sigaction below

use vars qw($PS1 $PS2 $HISTFILE $HISTSIZE $INPUTRC $STRICT
	    $HOSTNAME $LOGNAME $CWP);

#$PS1 = '$ ';
$PS1='\w[\!]$ ';
$PS2 = '> ';
$HISTFILE = ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlsh_history";
$HISTSIZE = 256;
$INPUTRC = ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlshrc";
$STRICT = 0;

$HOSTNAME = $ENV{HOSTNAME};
$LOGNAME = $ENV{LOGNAME};
$CWP = 'main';			# current working package

package main;
if (-f $PerlSh::INPUTRC) {
    do $PerlSh::INPUTRC;
}

package PerlSh;

use vars qw($term $attribs);	# to access as `$PerlSh::term' from prompt
$term = new Term::ReadLine 'PerlSh';
$attribs = $term->Attribs;

$term->bind_key(ord "^", 'history-expand-line', 'emacs-meta');
$term->bind_key(ord "\cv", 'display-readline-version', 'emacs-ctlx');
$term->bind_key(ord "\cc", 'abort'); # not works yet FIXME!!!

if (defined &main::afterinit) {
    package main;
    &afterinit;
    package PerlSh;
}

&toplevel;			# never returns

########################################################################
sub toplevel {
    # disable implicit add_history() call
    $term->MinLine(undef);

    $term->stifle_history($HISTSIZE);
    if (-f $HISTFILE) {
	$term->ReadHistory($HISTFILE)
	    or warn "perlsh: cannot read history file: $!\n";
    }
    $attribs->{attempted_completion_function} = \&attempt_perl_completion;
    $attribs->{special_prefixes} = '$@%&';
    $attribs->{completion_display_matches_hook}
	= \&perl_symbol_display_match_list;

    # See http://perldoc.perl.org/perlipc.html#Deferred-Signals-%28Safe-Signals%29
    # was '$SIG{INT} = sub { ...'
    sigaction SIGINT, new POSIX::SigAction sub {
	$term->modifying;
	$term->delete_text;
	$attribs->{point} = $attribs->{end} = 0;
	$term->redisplay;
    } or die "Error setting SIGINT handler: $!\n";

    my ($strict, $command, @result);
    $strict = $STRICT ? '' : 'no strict;';
    while (defined($command = &reader)) {
	@result = eval ("$strict package $CWP; $command");
	use strict;
	if ($@) { print "Error: $@\n"; next; }
	printer (@result);
	$CWP = $1 if ($command =~ /^\s*package\s+([\w:]+)/);
    }
    &quit;
}

sub sigint {
    $term->modifying;
    $term->delete_text;
    $attribs->{point} = $attribs->{end} = 0;
    $term->redisplay;
}

sub quit {
    $term->WriteHistory($HISTFILE)
	or warn "perlsh: cannot write history file: $!\n";
    exit (0);
}

sub reader {
    my ($line, $command);
    $command = '';
    while (1) {
	$line = $term->readline($command ? $PS2 : prompt($PS1));
	return undef unless (defined $line);
	
	if ($line =~ /\\$/) {
	    chop $line;
	    $command = $command ? $command . " $line" : $line;
	} else {
	    $command = $command ? $command . " $line" : $line;
	    $term->addhistory($command) if (length($command) > 0);
	    return $command;
	}
    }
}

sub printer {
    my (@res) = @_;
    my ($i);
    foreach $i (@res) { print "$i\n"; }
}

sub prompt {
    local($_) = @_;
    # if reference to a subroutine return the return value of it
    return &$_ if (ref($_) eq 'CODE');

    # \h: hostname, \u: username, \w: package name, \!: history number
    s/\\h/$HOSTNAME/g;
    s/\\u/$LOGNAME/g;
    s/\\w/$CWP/g;
    s/\\!/$attribs->{history_base} + $attribs->{history_length}/eg;
    $_;
}

#
#	custom completion for Perl
#

sub perl_symbol_display_match_list ($$$) {
    my($matches, $num_matches, $max_length) = @_;
    map { $_ =~ s/^((\$#|[\@\$%&])?).*::(.+)/$3/; }(@{$matches});
    $term->display_match_list($matches);
    $term->forced_update_display;
}

sub attempt_perl_completion ($$$$) {
    my ($text, $line, $start, $end) = @_;
    
    no strict qw(refs);
    if (substr($line, 0, $start) =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/) {
	# $foo{key, $foo->{key
	$attribs->{completion_append_character} = '}';
	return $term->completion_matches($text,
					 \&perl_hash_key_completion_function);
    } elsif (substr($line, 0, $start) =~ m/\$([\w:]+)\s*->\s*['"]?$/) {
	# $foo->method
	$attribs->{completion_append_character} = ' ';
	return $term->completion_matches($text,
					 \&perl_method_completion_function);
    } else { # Perl symbol completion
	$attribs->{completion_append_character} = '';
	return  $term->completion_matches($text,
					  \&perl_symbol_completion_function);
    }
}

# static global variables for completion functions
use vars qw($i @matches);

sub perl_hash_key_completion_function ($$) {
    my($text, $state) = @_;
    
    if ($state) {
	$i++;
    } else {
	# the first call
	$i = 0;			# clear index
	my ($var,$arrow) = (substr($attribs->{line_buffer},
				   0, $attribs->{point} - length($text))
			    =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/); # });
	no strict qw(refs);
	$var = "${CWP}::$var" unless ($var =~ m/::/);
	if ($arrow) {
	    my $hashref = eval "\$$var";
	    @matches = keys %$hashref;
	} else {
	    @matches = keys %$var;
	}
	
    }
    for (; $i <= $#matches; $i++) {
	return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
    }
    return undef;
}

sub _search_ISA ($) {
    my ($mypkg) = @_;
    no strict 'refs';
    no warnings 'prototype';
    my $isa = "${mypkg}::ISA";
    return $mypkg, map _search_ISA($_), @$isa;
}

sub perl_method_completion_function ($$) {
    my($text, $state) = @_;
    
    if ($state) {
	$i++;
    } else {
	# the first call
	my ($var, $pkg, $sym, $pk);
	$i = 0;			# clear index
	$var = (substr($attribs->{line_buffer},
		       0, $attribs->{point} - length($text))
		=~ m/\$([\w:]+)\s*->\s*$/)[0];
	$pkg = ref eval (($var =~ m/::/) ? "\$$var" : "\$${CWP}::$var");
	no strict qw(refs);
	@matches = map { $pk = $_ . '::';
			 grep (/^\w+$/
			       && ($sym = "${pk}$_", defined *$sym{CODE}),
			       keys %$pk);
		     } _search_ISA($pkg);
    }
    for (; $i <= $#matches; $i++) {
	return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
    }
    return undef;
}

#
#	Perl symbol name completion
#
{
    my ($prefix, %type, @keyword);

    sub perl_symbol_completion_function ($$) {
	my($text, $state) = @_;

	if ($state) {
	    $i++;
	} else {
	    # the first call
	    my ($pre, $pkg, $sym);
	    $i = 0;		# clear index

	    no strict qw(refs);
	    ($prefix, $pre, $pkg) = ($text =~ m/^((\$#|[\@\$%&])?(.*::)?)/);
	    @matches = grep /::$/, $pkg ? keys %$pkg : keys %::;
	    $pkg = ($CWP eq 'main' ? '::' : $CWP . '::') unless $pkg;

	    if ($pre) {		# $foo, @foo, $#foo, %foo, &foo
		@matches = (@matches,
			    grep (/^\w+$/
				  && ($sym = $pkg . $_,
				      defined *$sym{$type{$pre}}),
				  keys %$pkg));
	    } else {		# foo
		@matches = (@matches,
			    !$prefix && @keyword,
			    grep (/^\w+$/
				  && ($sym = $pkg . $_,
				      defined *$sym{CODE} || defined *$sym{IO}
				     ),
				  keys %$pkg));
	    }
	}
	my $entry;
	for (; $i <= $#matches; $i++) {
	    $entry = $prefix . $matches[$i];
	    return $entry if ($entry =~ /^\Q$text/);
	}
	return undef;
    }

    BEGIN {
	%type = ('$' => 'SCALAR', '*' => 'SCALAR',
		 '@' => 'ARRAY', '$#' => 'ARRAY',
		 '%' => 'HASH',
		 '&' => 'CODE'); # '

	# from perl5.004_02 perlfunc
	@keyword = qw(
		    chomp chop chr crypt hex index lc lcfirst
		    length oct ord pack q qq
		    reverse rindex sprintf substr tr uc ucfirst
		    y
		    
		    m pos quotemeta s split study qr

		    abs atan2 cos exp hex int log oct rand sin
		    sqrt srand

		    pop push shift splice unshift

		    grep join map qw reverse sort unpack
		    
		    delete each exists keys values
		    
		    binmode close closedir dbmclose dbmopen die
		    eof fileno flock format getc print printf
		    read readdir rewinddir seek seekdir select
		    syscall sysread sysseek syswrite tell telldir
		    truncate warn write
		    
		    pack read syscall sysread syswrite unpack vec
		    
		    chdir chmod chown chroot fcntl glob ioctl
		    link lstat mkdir open opendir readlink rename
		    rmdir stat symlink umask unlink utime
		    
		    caller continue die do dump eval exit goto
		    last next redo return sub wantarray
		    
		    caller import local my package use
		    
		    defined dump eval formline local my reset
		    scalar undef wantarray
		    
		    alarm exec fork getpgrp getppid getpriority
		    kill pipe qx setpgrp setpriority sleep
		    system times wait waitpid
		    
		    do import no package require use
		    
		    bless dbmclose dbmopen package ref tie tied
		    untie use
		    
		    accept bind connect getpeername getsockname
		    getsockopt listen recv send setsockopt shutdown
		    socket socketpair
		    
		    msgctl msgget msgrcv msgsnd semctl semget
		    semop shmctl shmget shmread shmwrite
		    
		    endgrent endhostent endnetent endpwent getgrent
		    getgrgid getgrnam getlogin getpwent getpwnam
		    getpwuid setgrent setpwent
		    
		    endprotoent endservent gethostbyaddr
		    gethostbyname gethostent getnetbyaddr
		    getnetbyname getnetent getprotobyname
		    getprotobynumber getprotoent getservbyname
		    getservbyport getservent sethostent setnetent
		    setprotoent setservent
		    
		    gmtime localtime time times
		    
		    abs bless chomp chr exists formline glob
		    import lc lcfirst map my no prototype qx qw
		    readline readpipe ref sub sysopen tie tied
		    uc ucfirst untie use
		    
		    dbmclose dbmopen
		   );
    }
}

__END__

=pod

Before invoking, this program reads F<~/.perlshrc> and evaluates the
content of the file.

When this program is terminated, the content of the history buffer is
saved in a file F<~/.perlsh_history>, and it is read at next
invoking.

=head1 VARIABLES

You can customize the behavior of C<perlsh> by setting following
variables in F<~/.perlshrc>;

=over 4

=item C<$PerlSh::PS1>

The primary prompt string.  The following backslash-escaped special
characters can be used.

	\h: host name
	\u: user name
	\w: package name
	\!: history number

The default value is `C<\w[\!]$ >'.

=item C<$PerlSh::PS2>

The secondary prompt string.  The default value is `C<E<gt> >'.

=item C<$PerlSh::HISTFILE>

The name of the file to which the command history is saved.  The
default value is C<~/.perlsh_history>.

=item C<$PerlSh::HISTSIZE>

If not C<undef>, this is the maximum number of commands to remember in
the history.  The default value is 256.

=item C<$PerlSh::STRICT>

If true, restrict unsafe constructs.  See C<use strict> in perl man
page.  The default value is 0;

=back

=head1 FILES

=over 4

=item F<~/.perlshrc>

This file is eval-ed at initialization.  If a subroutine C<afterinit>
is defined in this file, it will be eval-ed after initialization.
Here is a sample.

	# -*- mode: perl -*-
	# decimal to hexa
	sub h { map { sprintf("0x%x", $_ ) } @_;}

	sub tk {
	    $t->tkRunning(1);
	    use Tk;
	    $mw = MainWindow->new();
	}

	# for debugging Term::ReadLine::Gnu
	sub afterinit {
	    *t = \$PerlSh::term;
	    *a = \$PerlSh::attribs;
	}

=item F<~/.perlsh_history>

=item F<~/.inputrc>

A initialization file for the GNU Readline Library.  Refer its manual
for details.

=back

=head1 SEE ALSO

L<Term::ReadLine::Gnu|http://search.cpan.org/dist/Term-ReadLine-Gnu/>

L<GNU Readline Library|http://cnswww.cns.cwru.edu/php/chet/readline/rltop.html>

=head1 AUTHOR

Hiroo Hayashi <hiroo.hayashi@computer.org>

=cut