libyaml-shell-perl 0.71-1 / usr / share / perl5 / YAML / Shell.pm

use strict; use warnings;
package YAML::Shell;
our $VERSION = '0.71';

use Term::ReadLine;
sub Term::ReadLine::Perl::Tie::FIRSTKEY {undef}
use Data::Dumper;
use Config;
$Data::Dumper::Indent = 1;
our $prompt = 'ysh > ';
my $round_trip = 0;
my $force = 0;
my $log = 0;
my $yaml_module = 'YAML::Any';
my $yaml_version;
$| = 1;
my $sh;

sub run {
    my $class = shift;
    set_version($yaml_module);
    my @env_args = split /\s+/, ($ENV{YSH_OPT} || '');
    my @args = (@env_args, @_);
    my $stream = -t STDIN ? '' : join('', <STDIN>);
    while (my $arg = shift @args) {
        set_version($1), next if $arg =~ /^-M(.*)/;

        handle_help(), exit if $arg eq '-h';
        handle_version(), exit if $arg eq '-v';
        handle_Version(), exit if $arg eq '-V';

        $YAML::Indent = $1, next if $arg =~ /^-i(\d+)$/;
        $YAML::UseFold = 1, next if $arg eq '-uf';
        $YAML::UseBlock = 1, next if $arg eq '-ub';
        $YAML::UseCode = 1, next if $arg eq '-uc';
        $YAML::UseHeader = 0, next if $arg eq '-nh';
        $YAML::UseVersion = 0, next if $arg eq '-nv';
        $round_trip = 1, next if $arg eq '-r';
        $round_trip = 2, next if $arg eq '-R';
        $log = 1, next if $arg eq '-l';
        $log = 2, next if $arg eq '-L';
        $force = 1, next if $arg eq '-F';
        warn(<<END), exit 1;
Unknown YAML Shell argument: '$arg'.
For help, try: perldoc ysh
END
    }

    set_version($yaml_module);

    check_install() unless $force;

    if ($log) {
        if ($log == 2) {
            open LOGFILE, "> ./ysh.log" or die $!;
        }
        else {
            open LOGFILE, ">> ./ysh.log" or die $!;
        }
        no strict 'refs';
        my $version = ${"${yaml_module}::VERSION"};
        print LOGFILE "\n$yaml_module Version $version\n";
        print LOGFILE "Begin logging at ", scalar localtime, "\n\n";
    }

    if (not length($stream)) {
        Print(<<END);
Welcome to the YAML Test Shell (@{[ $class->implementation ]})

Type ':help' for more information.

END
    }

    {
        {
            local @ENV{qw(HOME EDITOR)};
            local $^W;
            $sh = Term::ReadLine::->new('The YAML Shell');
        }

        sub my_readline {
            print LOGFILE $prompt if $log;
            my $input = $sh->readline($prompt);
            if (not defined $input) {
                $input = ':exit';
                Print("\n");
            }
            $input .= "\n";
        }
    }

    if (length($stream)) {
        my @objects;
        no strict 'refs';
        eval { @objects = &{"${yaml_module}::Load"}($stream) };
        if ($@) {
            print STDERR $@;
            exit 1;
        }
        else {
            print STDOUT Data::Dumper::Dumper(@objects);
            exit 0;
        }
    }

    while ($_ = my_readline()) {
        print LOGFILE $_ if $log;
        next if /^\s*$/;
        exec('ysh', @ARGV) if /^\/$/;
        handle_command($_),next if /^:/;
        handle_file($1),next if /^<\s*(\S+)\s*$/;
        handle_yaml($_),next if /^--\S/;
        handle_yaml(''),next if /^===$/;
        handle_perl($_,1),next if /^;/;
        handle_perl($_,0),next;
        Print("Unknown command. Type ':help' for instructions.\n");
    }
}

sub set_version {
    my $module = shift;
    eval "require $module";
    die $@ if $@;
    $yaml_module = $module;
    no strict 'refs';
    $yaml_version = ${"${yaml_module}::VERSION"};
}

sub Print {
    print @_;
    print LOGFILE @_ if $log;
}
local $SIG{__WARN__} = sub { Print @_ };

sub handle_file {
    my ($file) = @_;
    my @objects;
    eval {
        no strict 'refs';
        @objects = &{"${yaml_module}::LoadFile"}($file)
    };
    if ($@) {
        Print $@;
    }
    else {
        Print Data::Dumper::Dumper(@objects);
    }
}

sub handle_perl {
    my ($perl, $multi) = @_;
    my (@objects, $yaml, $yaml2);
    local $prompt = 'perl> ';
    my $line = '';
    if ($multi) {
        while ($line !~ /^;$/) {
            $line = my_readline();
            print LOGFILE $line if $log;
            $perl .= $line;
        }
    }
    @objects = eval "no strict;$perl";
    Print("Bad Perl expression:\n$@"), return if $@;
    {
        no strict 'refs';
        eval { $yaml = &{"${yaml_module}::Dump"}(@objects) };
    }
    $@ =~ s/^ at.*\Z//sm if $@;
    Print("Dump failed:\n$@"), return if $@;
    Print $yaml;
    if ($round_trip) {
        {
            local $SIG{__WARN__} = sub {};
            no strict 'refs';
            eval { $yaml2 = &{"${yaml_module}::Dump"}(&{"${yaml_module}::Load"}($yaml)) };
        }
        $@ =~ s/^ at.*\Z//sm if $@;
        Print("Load failed:\n$@"), return if $@;
        if ($yaml eq $yaml2) {
            if ($round_trip > 1) {
                Print "\nData roundtripped OK!!!\n";
            }
        }
        else {
            Print "================\n";
            Print "after roundtrip:\n";
            Print "================\n";
            # $yaml2 =~ s/ /_/g;  #
            # $yaml2 =~ s/\n/+/g; #
            # Print $yaml2, "\n"; #
            Print $yaml2;
            Print "=========================\n";
            Print "Data did NOT roundtrip...\n";
        }
    }
}

sub handle_yaml {
    my $yaml = shift;
    my $line = $yaml;
    my (@objects);
    local $prompt = 'yaml> ';
    $line = my_readline();
    print LOGFILE $line if $log;
    $line = '' unless defined $line;
    while ($line !~ /^\.{3}$/) {
        $yaml .= $line;
        $line = my_readline();
        print LOGFILE $line if $log;
        last unless defined $line;
    }
    $yaml =~ s/\^{2,8}/\t/g;
    no strict 'refs';
    eval { @objects = &{"${yaml_module}::Load"}($yaml) };
    $@ =~ s/^ at.*\Z//sm if $@;
    $@ =~ s/^/  /gm if $@;
    Print("YAML Load Failed:\n$@"), return if $@;
    Print Data::Dumper::Dumper(@objects);
}

sub handle_command {
    my $line = shift;
    chomp $line;
    my ($cmd, $args);
    if ($line =~ /^:(\w+)\s*(.*)$/) {
        $cmd = $1;
        $args = $2;
        exit if $cmd =~ /^(exit|q(uit)?)$/;
        handle_help(),return if $cmd eq 'help';
        print `clear`,return if $cmd =~ /^c(lear)?$/;
    }
    Print "Invalid command\n";
}

sub handle_help {
    Print <<END;

       Welcome to the YAML Test Shell (@{[ __PACKAGE__->implementation ]})

   When you to type in Perl, you get back YAML. And vice versa.

   By default, every line you type is a one line Perl program, the return value
   of which will be displayed as YAML.

   To enter multi-line Perl code start the first line with ';' and use as many
   lines as needed. Terminate with a line containing just ';'.

   To enter YAML text, start with a valid YAML separator/header line which is
   typically '---'. Use '===' to indicate that there is no YAML header. Enter
   as many lines as needed. Terminate with a line containing just '...'.

   Shell Commands:             (Begin with ':')
      :exit or :q(uit) - leave the shell
      :help - get this help screen

END
}

sub implementation {
    my $module = $yaml_module;
    if ($yaml_module eq 'YAML::Any') {
        $module .= " -> " . YAML::Any->implementation;
    }
    return $module;
}

sub check_install {
    if (-f "./YAML.pm" && -f "./pm_to_blib" &&
        -M "./YAML.pm" <  -M "./pm_to_blib"
       ) {
        die "You need to 'make install'!\n";
    }
}

sub handle_version {
    print STDERR <<END;

ysh: '$VERSION'
${yaml_module}: '$yaml_version'

END
}

sub handle_Version {
    my $TRP = get_version('Term::ReadLine::Perl');
    my $TRG = get_version('Term::ReadLine::Gnu');
    my $POE = get_version('POE');
    my $TO = get_version('Time::Object');

    print STDERR <<END;

ysh: '$VERSION'
${yaml_module}: '$yaml_version'
perl: '$Config::Config{version}'
Data::Dumper: '$Data::Dumper::VERSION'
Term::ReadLine::Perl: '$TRP'
Term::ReadLine::Gnu: '$TRG'
POE: '$POE'
Time::Object: '$TO'

END
}

sub get_version {
    my ($module) = @_;
    my $version;
    eval "no strict; use $module; \$version = \$${module}::VERSION";
    #$version = "$@" if $@;
    $version = "not installed" if $@;
    return $version;
}

1;