#!/usr/bin/perl
package IPL::Shell;
use strict;

BEGIN {
    use vars qw{$VERSION $RCSID};

    $VERSION    = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
    $RCSID      = q$Id: ipl,v 1.3 2004/11/11 00:51:38 deveiant Exp $;

    use base qw{Shell::Base};

    use Carp            qw{carp croak confess};
    use Data::Dumper    qw{};
    use Term::ANSIColor qw{color};
    use Cwd             qw{cwd};
    use File::Basename  qw(basename);
    use Net::Domain     qw(hostfqdn);
    use String::Format  qw(stringf);
    use Sys::Hostname   qw(hostname);
    use Devel::Symdump  qw{};

    $Shell::Base::RE_QUIT = '(?i)^\s*(exit|q(uit)?|logout)';
}



#####################################################################
###	C L A S S   G L O B A L S
#####################################################################

# Default configuration values
our %Defaults = (
    prompt_fmt  => '%{bold cyan}C%p%{white}C %!> ',
);



#####################################################################
###	I N S T A N C E   M E T H O D S
#####################################################################

### Shell initialization
sub init {
    my ( $self, $args ) = @_;

    # Merge defaults
    %$args = ( %Defaults, %$args );

    # Add instance vars
    $self->{result_history} = [];
    $self->{package} = 'main';
    $self->{prompt_fmt} = $args->{prompt_fmt};
}


### METHOD: init_completions()
### Initialize the internal COMPLETIONS list.
sub init_completions {
    my $self = shift;
    $self->SUPER::init_completions;
    $self->completions( map { ":$_" } $self->completions );
}


### Intro/outro message
sub intro { return qq{IPL: Interactive Perl Shell $VERSION} }
sub outro { "" }


### Prompt callback
sub prompt {
    my $self = shift;
    my $fmt = $self->{prompt_fmt};

    my $prompt = stringf $fmt => {
        '!' => $self->term->{history_length},
        '$' => $$,
        '0' => $self->progname,
        'C' => sub { color($_[0]) },
        'H' => hostfqdn,
        'W' => basename(cwd),
        'c' => ref($self),
        'g' => scalar getgrgid($(),
        'h' => hostname,
        'p' => $self->{package},
        'u' => scalar getpwuid($<),
        'w' => cwd,
    };

    # Append a reset to clean up if there are color escapes in the prompt
    $prompt .= color( 'reset' ) if $prompt =~ m{\e\[};

    return "\n$prompt";
}


### METHOD: print( $output )
### Output method.
sub print {
    my $self = shift;
    my $output = join( "", @_ );

    my $nlcount = $output =~ tr/\n/\n/;

    if ( $nlcount >= $self->{ROWS} - 3 ) {
        my $pager = $self->pager;
        open my $P, "|$pager" or carp "Can't open $pager: $!";
        CORE::print $P $output;
        close $P;
    } else {
        CORE::print $output;
    }

}


### METHOD: parseline( $input )
### Command-parsing method: parse the specified I<input>, run the specified
### command, and output the result.
sub parseline {
    my ( $self, $input ) = @_;

    if ( $input =~ m{^:(\S+.*)} ) {
        return $self->SUPER::parseline( $1 );
    }

    else {
        return ( "eval", {}, $input );
    }
}


### METHOD: prettyPrint( $value )
### Return the given I<value> as a pretty-printed string.
sub prettyPrint {
    my ( $self, $val ) = @_;

    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Indent = 1;
    local $Data::Dumper::Pad = "    ";

    my $rval = Data::Dumper->Dumpxs( [$val] );
    $rval =~ s{^\s+}{};
    $rval = " => $rval ";

    return $rval;
}



#####################################################################
###	C O M M A N D   M E T H O D S
#####################################################################

### METHOD: do_shellobj( undef )
### Implementation of the 'shellobj' command
sub do_shellobj {
    my $self = shift;
    return Data::Dumper->Dumpxs( [$self], [qw{self}] );
}


### METHOD: help_shellobj( undef )
### Callback for help on the 'shellobj' command.
sub help_shellobj {
    return q{Show a dump of the IPL shell object itself.};
}


### METHOD: do_eval( @args )
### Implementation of the 'eval' command.
sub do_eval {
    my ( $self, @args ) = @_;

    my (
        $input,
        $res,
        $rval,
       );

    $input = join( ' ', @args );
    #$self->print( "[Evaluating '$input']\n" );
    $res = eval qq{
        package $self->{package};
        no strict;
        $input ;
    };

    # Show error message for errors
    if ( $@ ) {
        ( $rval = $@ ) =~ s{at \S+ line \d+\..*}{};
    }

    # Dump everything else
    else {
        $rval = $self->prettyPrint( $res );
    }

    return $rval;
}

### METHOD: help_eval( undef )
### Provide help text for the 'eval' command.
sub help_eval {
    return q{Evaluate the input as Perl and display the result.};
}


### METHOD: do_rl( $subcmd, @args )
### Implementation of the 'readline' command.
sub do_rl {
    my ( $self, $subcmd, @args ) = @_;

    my $rval = '';

    if ( $subcmd =~ m{features} ) {
        $rval = $self->prettyPrint( $self->term->Features );
    }

    elsif ( $subcmd =~ m{module} ) {
        $rval = "Readline features provided by: " .
            $self->term->ReadLine;
    }

    elsif ( $subcmd =~ m{completions} ) {
        $rval = "Tab-completions: \n" .
            $self->prettyPrint( [sort $self->completions] );
    }

    else {
        $rval = $self->prettyPrint( $self->term );
    }

    return $rval;
}


### METHOD: help_rl( undef )
### Return help text for the 'rl' (readline) command.
sub help_rl {q{
rl [<subcommand>]

Provide information about the readline implementation used by the shell. The
<subcommand> can be one of:

features    Dump the hash of features understood by the implementation.
module      Show the name of the actual module that is providing readline
            features.
completions Dump the list of tab-completions.

}}


### METHOD: do_perldoc( @args )
### Implementation of the 'perldoc' command.
sub do_perldoc {
    my ( $self, @args ) = @_;

    if ( @args ) {
        system 'perldoc', @args;
        return undef;
    } else {
        return "'perldoc' requires at least one argument.";
    }
}


### METHOD: help_perldoc()
### Help method for the 'perldoc' command.
sub help_perldoc {q{
Run the 'perldoc' program.
}}


### METHOD: do_package( $newpkg )
### Change the package future evals will take place in.
sub do_package {
    my ( $self, $package ) = @_;

    if ( $package ) {
        return "Invalid package name '$package'"
            unless $package =~ m{^[a-z]\w+(?:::[a-z]\w+)*$}i;
        $self->{package} = $package;
        return "Set eval package to: '$package'.";
    } else {
        return "Current package is: '$self->{package}'.";
    }
}


### METHOD: help_package()
### Help method for the 'package' command.
sub help_package {q{
  package [<newpackage>]

Set the package future evaluations will occur in to 'newpackage' if the optional
argument is given, else just print the name of the current package.
}}




### METHOD: do_reload()
### Implementation of the 'reload' command.
sub do_reload {
    my $self = shift;

    if ( my $h = $self->histfile ) {
        $self->term->WriteHistory( $h );
    }

    $self->print( "Re-execing shell...\n" );
    local $ENV{IPL_RELOAD} = 1;
    exec $0;
    return "Hmmm... something funky happened.";
}

sub help_reload {q{
  reload

Reload the shell.
}}


### METHOD: do_inspect( [$package] )
### Implementation of the 'inspect' command.
sub do_inspect {
    my $self = shift;
    my $package = shift || $self->{package};

    my $inspector = new Devel::Symdump $package;

    no strict;
    my @out = ( "Symbol table for $package" );
    my ( %scalars, %arrays, %hashes, %functions, %packages, %filehandles );

    # Grab entries for each type from the symbol table for the inspected
    # package.
    %scalars     = map { $_ => ${*{$_}{SCALAR}} } $inspector->scalars;
    %arrays      = map { $_ => *{$_}{ARRAY} } $inspector->arrays;
    %hashes      = map { $_ => *{$_}{HASH} } $inspector->hashes;
    %functions   = map { $_ => *{$_}{CODE} } $inspector->functions;
    %packages    = map { $_ => undef } $inspector->packages;
    %filehandles = map { $_ => *{$_}{IO} } $inspector->filehandles;

    # Build displays for each entry in the symbol table, sorted by type,
    # prepending the sigil for each one. In part stolen from Matthew Simon
    # Cavalletto's Term::ShellKit::Dev
    foreach my $output (
        [ 'Scalars', \%scalars, '$', ],
        [ 'Arrays', \%arrays, '@'],
        [ 'Hashes', \%hashes, '%'],
        [ 'Subs', \%functions, 'sub '],
        [ 'Packages', \%packages, '::'],
        [ 'Filehandles', \%filehandles, '*'],
       ) {
        next unless scalar keys %{$output->[1]};
        push @out, "$output->[0]:", '-' x length($output->[0]);
        foreach ( sort keys %{$output->[1]} ) {
            if ( defined $output->[1]{$_} ) {
                push @out, qq{  $output->[2]$_ = "$output->[1]{$_}"};
            } else {
                push @out, qq{  $output->[2]$_};
            }
        }
    }

    return join "\n", @out;


}

sub help_inspect {q{
  inspect [<package>]

Inspect the contents of the specified package, or the current package if no
package is given.
}}



#####################################################################
###	R U N T I M E   P A C K A G E
#####################################################################
package ipl;
use strict;

BEGIN {
    use Getopt::Long qw{GetOptions};
    $GetOpt::Long::Bundling = 1;
}


if ( $0 eq __FILE__ ) {
    my %opts = (
        HISTFILE => glob("~/.ipl_history"),
        RCFILES => [glob("~/.iplrc"), ".iplrc"],
       );

    IPL::Shell->new( %opts )->run;
}