view release on metacpan or  search on metacpan

bin/prima-repl  view on Meta::CPAN

#!/usr/bin/env perl
use strict;
use warnings;

use Prima qw(Buttons Notebooks ScrollWidget Application Edit
			FileDialog ImageViewer ImageDialog);
use Carp;
use File::Spec;
use FindBin;

use PrimaX::InputHistory;
my $fileName = '.prima.repl.history';
my $historyLength = 200;	# total number of lines to save to disk

#use Eval::WithLexicals;

my $DEBUG_OUTPUT = 0;
my $initrc_filename = 'prima-repl.initrc';
# Load PDL if they have it
my ($loaded_PDL, $loaded_Prima_Graphics);
BEGIN {
	$loaded_PDL = 0;
	eval {
		require PDL;
		PDL->import;
		require PDL::NiceSlice;
		$loaded_PDL = 1;
	};
	print $@ if $@ and $@ !~ /^Can't locate/;
	
	# Load PDL::Graphics::Prima if they have it
	$loaded_Prima_Graphics = 0;
	eval {
		require PDL::Graphics::Prima;
		PDL::Graphics::Prima->import;
		require PDL::Graphics::Prima::Simple;
		PDL::Graphics::Prima::Simple->import;
		$loaded_Prima_Graphics = 1;
	};
	print $@ if $@ and $@ !~ /^Can't locate/;
}

my $app_filename = File::Spec->catfile($FindBin::Bin, $FindBin::Script);
my $version = 0.3;

#########################
# Main Application Code #
#########################

package REPL;
my $history_output_handler = PrimaX::InputHistory::Output::REPL->new;

our @text_file_extension_list = (
		  ['Perl scripts'		=> '*.pl'	]
		, ['PDL modules'		=> '*.pdl'	]
		, ['Perl modules'		=> '*.pm'	]
		, ['POD documents'	=> '*.pod'		]
		, ['Test suite'		=> '*.t'		]
		, ['All'				=> '*'		]
);

# A dialog box that will be used for opening and saving files:
our $open_text_dialog = Prima::OpenDialog-> new(filter => \@text_file_extension_list);
our $open_dialog = Prima::OpenDialog->new(filter => [[All => '*']]);

# Very handy functions that I use throughout, but which I define later.
sub goto_page;
sub goto_output;
sub warn {
	chomp(my $text = join('', @_));
	warn $text . "\n";
	goto_output;
}

our $padding = 10;
our $window = Prima::MainWindow->new(
#	pack => { fill => 'both', expand => 1, padx => $padding, pady => $padding },

bin/prima-repl  view on Meta::CPAN

	my $page = shift || $notebook->pageIndex + 1;
	my $tabs = $notebook->tabs;
	$tabs->[$page - 1] = "$name, #$page";
	$notebook->tabs($tabs);
}


# convenience function for clearing the output:
my $output_line_number = 0;
my $output_column = 0;
sub clear {
	$output->text('');
	$output_line_number = 0;
	$output_column = 0;
}

# Convenience function for PDL folks.
sub p {	print @_ }

################################
# Output handling and mangling #
################################

# Set autoflush on stdout:
$|++;

# Useful function to simulate user input. This is useful for initialization
# scripts when you want to run commands and put them into the command history
sub REPL::simulate_run {
    my $command = shift;
    # Get the current content of the inline and cursor position:
    my $old_text = $inline->text;
    my $old_offset = $inline->charOffset;
    # Set the content to the new command:
    $inline->text($command);
    # run it:
    $inline->PressEnter();
    # put the original content back on the inline:
    $inline->text($old_text);
    $inline->charOffset($old_offset);
}

# Here is a utility function to print to the output window. Both standard output
# and standard error are later tied to printing to this interface, so you can
# just use 'print' or 'say' in all your code and it'll go to this.

sub REPL::outwindow {
	# The first argument is a boolean indicating whether the output should go
	# to stderr or stdout. I would like to make this print error text in red
	# eventually, but I need to figure out how to change the color of specific
	# text items: working here
	my $to_stderr = shift;
	
	# Join the arguments and split them at the newlines and carriage returns:
	my @args = map {defined $_ ? $_ : ''} ('', @_);
	my @lines = split /([\n\r])/, join('', @args);
	# Remove useless parts of error messages (which refer to lines in this code)
	s/ \(eval \d+\)// for @lines;
	# Open the logfile, which I'll print to simultaneously:
	open my $logfile, '>>', 'prima-repl.logfile';
	IO::OutWindow::print_to_terminal(@lines) if $DEBUG_OUTPUT or $to_stderr;
	# Go through each line and carriage return, overwriting where appropriate:
	foreach(@lines) {
		# If it's a carriage return, set the current column to zero:
		if (/\r/) {
			$output_column = 0;
			print $logfile "\\r\n";
		}
		# If it's a newline, increment the output line and set the column to
		# zero:
		elsif (/\n/) {
			$output_column = 0;
			$output_line_number++;
			print $logfile "\n";
		}
		# Otherwise, add the text to the current line, starting at the current
		# column:
		else {
			print $logfile $_;
			my $current_text = $output->get_line($output_line_number);
			# If the current line is blank, set the text to $_:
			if (not $current_text) {
				$current_text = $_;
			}
			# Or, if the replacement text exceeds the current line's content,
			elsif (length($current_text) < length($_) + $output_column) {
				# Set the current line to contain everything up to the current
				# column, and append the next text:
				$current_text = substr($current_text, 0, $output_column) . $_;
			}
			# Or, replace the current line's text with the next text:
			else {
				substr($current_text, $output_column, length($_), $_);
			}
			$output->delete_line($output_line_number);
			$output->insert_line($output_line_number, $current_text);
			# increase the current column:
			$output_column += length($_);
		}
	}
	
	# close the logfile:
	close $logfile;
	
	# Let the application update itself:
	$::application->yield;

	# I'm not super-enthused with manually putting the cursor at the end of
	# the text, or with forcing the scrolling. I'd like to have some way to
	# determine if the text was already at the bottom, in which case I would
	# continue scrolling, if it was not, I would not scroll. But, I cannot find
	# how to do that at the moment, so it'll just force scroll with every
	# printout. working here:
	$output->cursor_cend;
}

###############################
# Tie STDOUT to Output window #
###############################
# Redirect standard output using this filehandle tie. Thanks to 
# http://stackoverflow.com/questions/387702/how-can-i-hook-into-perls-print