App::Textcast - Light weight text casting

  use App::Textcast qw(record_textcast play_textcast) ;

  record_textcast(COMMAND => 'bash') ;
  play_textcast(TEXTCAST_DIRECTORY => $input_directory) ;

  use App::Textcast 'record_textcast' ;

  record_textcast
	(
	COMMAND => 'bash',
	OUTPUT_DIRECTORY => shift @ARGV,
	COMPRESS => $compress,
	COLUMNS => $columns,
	ROWS => $rows,
	) ;

  use App::Textcast 'play_textcast' ;

  play_textcast
	(
	TEXTCAST_DIRECTORY => $input_directory,
	OVERLAY_DIRECTORY => $overlay_directory,
	DISPLAY_STATUS => $display_status,
	START_PAUSED => $start_paused,
	) ; 

  print_play_information
	(
	$total_play_time,
	$total_frames,
	$played_frames,
	\@skipped_frames,
	) ;

	Nadim ibn hamouda el Khemir
	CPAN ID: NH
	mailto: nadim@cpan.org

    perldoc App::Textcast

package App::Textcast ;

use strict;
use warnings ;
use Carp qw(carp croak confess) ;

use English qw( -no_match_vars ) ;
$OUTPUT_AUTOFLUSH++;

my $get_terminal_size ;

BEGIN
{
if($OSNAME ne 'MSWin32')
	{
	eval 'use Term::Size;' ; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	croak "Error: $EVAL_ERROR" if $EVAL_ERROR;
	
	$get_terminal_size = eval ' sub { Term::Size::chars *STDOUT{IO} } ' ; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	croak "Error: $EVAL_ERROR" if $EVAL_ERROR ;
	}
else
	{
	eval 'use Win32::Console;' ; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	croak "Error: $EVAL_ERROR" if $EVAL_ERROR ;
	
	my $WIN32_CONSOLE = new Win32::Console;
	$get_terminal_size = eval { sub { $WIN32_CONSOLE->Size() } } ;
	croak "Error: $EVAL_ERROR" if $EVAL_ERROR ;
	}
}

BEGIN 
{
use Sub::Exporter -setup => 
	{
	exports => [ qw(record_textcast play_textcast) ],
	groups  => 
		{
		all  => [ qw() ],
		},
	};
 
use vars qw ($VERSION);
$VERSION = '0.06';
}

#-------------------------------------------------------------------------------

use Readonly ;

#~ http://www.termsys.demon.co.uk/vtansi.htm
Readonly my $CLEAR => "\e[2J" ; 
Readonly my $HOME => "\e[1;1H" ;
Readonly my $CLEAR_LINE => "\e[2K" ;
Readonly my $SAVE_CURSOR_POSITION => "\e7"  ; 
Readonly my $RESTORE_CURSOR_POSITION => "\e8"  ; 
Readonly my $HIDE_CURSOR => "\e[?25l" ;
Readonly my $SHOW_CURSOR => "\e[?25h" ;

Readonly my $EMPTY_STRING => q{} ;

use IO::Handle;
use POSIX ':sys_wait_h';
use IO::Pty;

use Term::VT102;
use File::Slurp ;
use Time::HiRes qw(gettimeofday tv_interval usleep);

#-------------------------------------------------------------------------------

#---------------------------------------------------------------------------------------------------------
# recording
#---------------------------------------------------------------------------------------------------------

sub record_textcast
{

my (%arguments) = @_;

my ($terminal_columns, $terminal_rows) = $get_terminal_size->() ;

my $output_directory = check_output_directory($arguments{OUTPUT_DIRECTORY}) ;
my $vt_process = create_vt102_sub_process
				(
				$arguments{COMMAND},
				$arguments{COLUMNS} || $terminal_columns,
				$arguments{ROWS}  || $terminal_rows, 
				) ;

print $CLEAR ;
	
my $previous_time = my $start_time = [gettimeofday]  ;

my ($screenshot_index, $sub_process_ended) = (0, 0) ;

while (not $sub_process_ended) 
	{
	($sub_process_ended, my $screen_diff, my $cursor_x, my $cursor_y) = check_sub_process_output($vt_process) ;
	
	my $now = [gettimeofday] ;
	my $elapsed = tv_interval($previous_time, $now);
	$previous_time = $now ;
	
	my $screenshot_file_name = "$output_directory/$screenshot_index" ;
	
	write_file($screenshot_file_name, $screen_diff) ;
			
	my ($terminal_columns, $terminal_rows) = $get_terminal_size->() ;
		
	append_file 
		(
		"$output_directory/index",
		
		'{'
		. "file => $screenshot_index, "
		. sprintf('delay => %0.3f, ', $elapsed)
		. "cursor_x => $cursor_x, "
		. "cursor_y => $cursor_y, "
		. 'size => ' . length($screen_diff) . ', '
		. "terminal_rows => $terminal_rows, "
		. "terminal_columns => $terminal_columns, "
		. "},\n" 
		) ;
			
	$screenshot_index++ ;
	}

my $record_time = tv_interval($start_time, [gettimeofday]);
printf("record_textcast: $screenshot_index frames in %.02f seconds. Textcast is in '$output_directory'.\r\n", $record_time) ;

close_vt102_sub_process($vt_process) ;

return ;
}

#---------------------------------------------------------------------------------------------------------

sub check_output_directory
{

my ($directory) = @_ ;

unless(defined $directory)
	{
	my $now_string = localtime;  # e.g., "Thu Oct 13 04:54:34 1994"
	$now_string=~ s/[^[:digit:][:alpha:]]/_/sxmg ;
	
	$directory = "textcast_recorded_on_$now_string" ;
	}
	
if(-e $directory)
	{
	local $ERRNO = 1 ;
	croak "Error: Textcast directory '$directory' already exists!\n" ;
	}
else
	{
	#todo: get the max path on this platform
	local $ERRNO = 2 ;
	
	Readonly my $MAX_PATH_LENGTH => 256 ;
	croak 'Error: Path too long' if length($directory) > $MAX_PATH_LENGTH ;

	if($directory =~ /([[:alnum:]\/_-]+)/sxm)
		{
		$directory = $1 ;
		}
	else
		{
		Readonly my $ERRNO_INVALID_PATH => 3 ;
		local $ERRNO = $ERRNO_INVALID_PATH  ;
		croak 'Error: Invalid path! Path can only contain alphanumerics and path separator.'
		}
		
	mkdir $directory or croak "Can't create directory '$directory'! $!\n" ;
	}

return $directory ;
}

#---------------------------------------------------------------------------------------------------------
# Playing
#---------------------------------------------------------------------------------------------------------

sub play_textcast
{

my (%arguments) = @_ ;

my $input_directory = $arguments{TEXTCAST_DIRECTORY} or croak 'Error: Expected textcast location!' ;
my $display_status =  $arguments{DISPLAY_STATUS} || 0 ;

local $SIG{INT} = sub 
			{
			print "\n" ;
			local $ERRNO = 1  ;
			croak "Caught interrupt signal!\n" ; 
			} ;

my $screenshot_information = load_index($input_directory) ;

my ($max_rows, $max_columns) = (-1, -1) ; 

for my $screenshot_data (@{$screenshot_information})
	{
	#~ print "$screenshot_data->{terminal_rows}, $screenshot_data->{terminal_columns}  \n" ;
	
	$max_rows = $screenshot_data->{terminal_rows} if $screenshot_data->{terminal_rows} > $max_rows ;
	$max_columns = $screenshot_data->{terminal_columns} if $screenshot_data->{terminal_columns} > $max_columns ;
	}

my ($terminal_columns, $terminal_rows) = $get_terminal_size->() ;

my ($status_row,$status_column) = (1, 1) ;

if($max_rows + $display_status > $terminal_rows || $max_columns > $terminal_columns)
	{
	Readonly my $ERRNO_TERMINAL_TOO_SMALL => 3 ;
	local $ERRNO = $ERRNO_TERMINAL_TOO_SMALL  ;
	croak "Error: Terminal too small [$terminal_columns, $terminal_rows] need at least [$max_columns, $max_rows]!\n"  ;
	}
else
	{
	$status_row = $max_rows + 1 ;
	}
	
#~ print DumpTree \@screenshot_information ;

print $CLEAR, $HOME ;

my ($total_play_time, $played_frames, $skipped_frames)
	= display_text_cast_data
		(
		$input_directory,
		$screenshot_information,
		{
			DISPLAY => $display_status,
			ROW => $status_row,
			COLUMN => $status_column,
		}
		) ;
	
print_play_information($total_play_time, $played_frames, $skipped_frames) ;

return ;
}

#---------------------------------------------------------------------------------------------------------

sub display_text_cast_data
{

my ($input_directory, $screenshot_information, $display_status,) = @_ ;

my $total_frames = scalar(@{$screenshot_information}) ;

my ($total_play_time, $played_frames, @skipped_frames) ;

my $frame_display_time = 0 ;

for my $file_information (@{$screenshot_information})
	{
	my $file = "$input_directory/$file_information->{file}" ;
	$total_play_time += $file_information->{delay} ;
	
	if(-e $file)
		{
		$played_frames++ ;
		
		status
			(
			sprintf( "F: $played_frames/$total_frames [%0.2f]", $file_information->{delay}),
			$display_status->{ROW},
			$display_status->{COLUMN},
			) if $display_status->{DISPLAY} ;
		
		my $sleep_time = $file_information->{delay} - $frame_display_time ;
		
		# split sleep time in smaller chunks if we want to handle the user input
		Readonly my $ONE_MILLION => 1_000_000 ;
		
		usleep $sleep_time * $ONE_MILLION if($sleep_time > 0) ;
		
		$frame_display_time = [gettimeofday]  ;
		
		print #$SHOW_CURSOR,
			read_file($file),
			position_cursor($file_information->{cursor_y}, $file_information->{cursor_x}) ;
		
		$frame_display_time = tv_interval($frame_display_time , [gettimeofday]) ;
		}
	else
		{
		carp "Error: Can't find '$file'! Skipping.\n" ;
		push @skipped_frames, $file ;
		}
	}

return ($total_play_time, $played_frames, \@skipped_frames) ;
}

#---------------------------------------------------------------------------------------------------------

sub print_play_information
{

my ($total_play_time, $played_frames, $skipped_frames) = @_ ;

my $play_time = sprintf('%0.2f', $total_play_time) ;

print "play_textcast: $played_frames frames played in $play_time seconds.\n" ;

if(@{$skipped_frames})
	{
	print "Skipped:\n\t" . join("\n\t", @{$skipped_frames}) . "\n" ;
	}
	
return ;
}

#---------------------------------------------------------------------------------------------------------

sub status
{

my ($status, $status_row, $status_column) = @_ ;

print $SAVE_CURSOR_POSITION, 
	position_cursor($status_row, $status_column),
	$CLEAR_LINE,
	$status,
	$RESTORE_CURSOR_POSITION ;

return ;
}

#---------------------------------------------------------------------------------------------------------

sub position_cursor
{

my ($row, $column) = @_ ;

return "\e[${row};${column}H" ;
}

#---------------------------------------------------------------------------------------------------------

sub load_index
{

my ($input_directory) = @_ ;

my @screenshot_information ;

if(-e "$input_directory/index")
	{
	print "Parsing index ...\n" ;
	my @entries = read_file("$input_directory/index") ;
	
	my $line = 0 ;
	
	my $regex = '{file => 0, delay => 0.0, cursor_x => 1, cursor_y => 1, size => 1, terminal_rows => 1, terminal_columns => 1, },' ;
	$regex =~ s/^{/^{/sxm ;
	$regex =~ s/([^[:digit:]]+)$/$1\$/sxmg ;
	$regex =~ s/[[:digit:]]+/[[:digit:]]+/sxmg ;
	
	my @errors ;
	
	for my $entry (@entries)
		{
		unless($entry =~ $regex)
			{
			push @errors, "\tInvalid index entry at line $line!\n" ;
			}
			
		$line++ ;
		}
	
	if(@errors)
		{
		local $ERRNO = 2 ;
		croak "Error: Invalid index!\n@errors" ;
		}
	
	@screenshot_information = eval "@entries"  ## no critic (BuiltinFunctions::ProhibitStringyEval)
		or croak "Error: Couldn't parse index file! $@ $!\n" ;
	}
else
	{
	local $ERRNO = 2 ;
	croak "Error: No index found! $!\n"  ;
	}
	
return \@screenshot_information ;
}

#---------------------------------------------------------------------------------------------------------
# VT102
# Everything below is based on the Term::VT102 example
# Logs all terminal output to STDERR if STDERR is redirected to a file.
#---------------------------------------------------------------------------------------------------------

sub create_vt102_sub_process
{

my ($shell_command, $columns, $rows) = @_ ;

# Create a pty for the command to run.
my $pty = new IO::Pty;
$pty->autoflush();

croak 'Error: Could not assign a pty' if (not defined $pty->ttyname()) ;

# Create the terminal object.
my ($vt, $terminal_change_buffer) = create_vt102_terminal($pty, $columns, $rows) ;

# Run the command in a child process.
my $pid = create_child_process($shell_command, $pty, $vt) ;

# IO::Handle for standard input - unbuffered.
my $iot = new IO::Handle;
$iot->fdopen (fileno(STDIN), 'r');

return
	{
	PTY => $pty,
	VT => $vt,
	TERMINAL_CHANGE_BUFFER => $terminal_change_buffer, 
	IOT => $iot,
	PREVXY => $EMPTY_STRING,
	
	PID => $pid,
	DIED => 0,
	} ;
}

#---------------------------------------------------------------------------------------------------------

sub close_vt102_sub_process
{

my ($vt_process) = @_ ;
$vt_process->{PTY}->close;

# Reset the terminal parameters.
system 'stty sane';

return ;
}

#---------------------------------------------------------------------------------------------------------

sub create_vt102_terminal
{

my ($pty, $columns, $rows) = @_ ;

my $terminal_change_buffer = {};
my $vt = Term::VT102->new (cols => $columns, rows => $rows,);

$vt->option_set ('LFTOCRLF', 1); # Convert linefeeds to linefeed + carriage return.
$vt->option_set ('LINEWRAP', 1); # Make sure line wrapping is switched on.

# Set up the callback for OUTPUT; this callback function simply sends
# whatever the Term::VT102 module wants to send back to the terminal and
# sends it to the child process - see its definition below.
$vt->callback_set ('OUTPUT', \&vt_output, $pty);

# Set up a callback for row changes, so we can process updates and display
# them without having to redraw the whole screen every time. We catch CLEAR,
# SCROLL_UP, and SCROLL_DOWN with another function that triggers a
# whole-screen repaint. You could process SCROLL_UP and SCROLL_DOWN more
# elegantly, but this is just an example.
$vt->callback_set ('ROWCHANGE', \&vt_rowchange, $terminal_change_buffer );
$vt->callback_set ('CLEAR', \&vt_changeall, $terminal_change_buffer );
$vt->callback_set ('SCROLL_UP', \&vt_changeall, $terminal_change_buffer );
$vt->callback_set ('SCROLL_DOWN', \&vt_changeall, $terminal_change_buffer );

# Set stdin's terminal to raw mode so we can pass all keypresses straight
# through immediately.
system 'stty raw -echo';

return ($vt, $terminal_change_buffer ) ;
}

#---------------------------------------------------------------------------------------------------------

sub vt_output 
{

my ($vtobject, $type, $arg1, $arg2, $private) = @_;

if ($type eq 'OUTPUT') 
	{
	$private->syswrite ($arg1, length $arg1);
	}

return ;
}

#---------------------------------------------------------------------------------------------------------

sub vt_rowchange 
{

my ($vtobject, $type, $arg1, $arg2, $private) = @_;
$private->{$arg1} = time if (not exists $private->{$arg1});

return ;
}

#---------------------------------------------------------------------------------------------------------

sub vt_changeall 
{

my ($vtobject, $type, $arg1, $arg2, $private) = @_;
for my $row (1 .. $vtobject->rows) 
	{
	$private->{$row} = 0;
	}
	
return ;
}

#---------------------------------------------------------------------------------------------------------

sub create_child_process
{

my ($shell_command, $pty, $vt) = @_ ;
my $pid = fork;

croak  "Error: Can not fork to run sub process, $!" if (not defined $pid)  ;

if ($pid == 0) 
	{
	# never comes back
	run_child_process($shell_command, $pty, $vt) ; 
	}

return $pid ;
}

#---------------------------------------------------------------------------------------------------------

sub run_child_process
{

my ($command, $pty, $vt) = @_ ;

# Child process - set up stdin/out/err and run the command.
# Become process group leader.
if (not POSIX::setsid ()) 
	{
	carp "Couldn't perform setsid: $!";
	}

# Get details of the slave side of the pty.
my $tty = $pty->slave ();
my $tty_name = $tty->ttyname();

# Linux specific - commented out, we'll just use stty below.
#
#	# Set the window size - this may only work on Linux.
#	#
#	my $winsize = pack ('SSSS', $vt->rows, $vt->cols, 0, 0);
#	ioctl ($tty, &IO::Tty::Constant::TIOCSWINSZ, $winsize);

# File descriptor shuffling - close the pty master, then close
# stdin/out/err and reopen them to point to the pty slave.
close ($pty);

close (STDIN);
open (STDIN, '<&' . $tty->fileno ()) || croak 'Error: Couldn\'t reopen ' . $tty_name . " for reading: $!";

close (STDOUT);
open (STDOUT, '>&' . $tty->fileno()) || croak 'Error: Couldn\'t reopen ' . $tty_name . " for writing: $!";

close (STDERR);
open (STDERR, '>&' . $tty->fileno()) || croak "Error: Couldn't redirect STDERR: $!";

# Set sane terminal parameters.
system 'stty sane';

# Set the terminal size with stty.
system 'stty rows ' . $vt->rows;
system 'stty cols ' . $vt->cols;

# Finally, run the command, and die if we can't.
exec $command or croak "Error: Cannot exec '$command': $!";
}

#---------------------------------------------------------------------------------------------------------

sub check_sub_process_output
{

my ($vt_process) = @_;	
my $vt = $vt_process->{VT} ;

my ($eof, $screen_data) ;

my $rin = $EMPTY_STRING ;
vec ($rin, $vt_process->{PTY}->fileno, 1) = 1;
vec ($rin, $vt_process->{IOT}->fileno, 1) = 1;

my ($win, $ein) = ($EMPTY_STRING, $EMPTY_STRING) ;
my($rout, $wout, $eout) ;
select ($rout=$rin, $wout=$win, $eout=$ein, 1);

# Read from the command if there is anything coming in, and
# pass any data on to the Term::VT102 object.
my $cmdbuf = $EMPTY_STRING ;

Readonly my $BUFFER_READ_SIZE => 1024 ;

if (vec($rout, $vt_process->{PTY}->fileno, 1)) 
	{
	my $bytes_read = $vt_process->{PTY}->sysread ($cmdbuf, $BUFFER_READ_SIZE);
	$eof = 1 if ((defined $bytes_read) && ($bytes_read == 0));
	
	if ((defined $bytes_read) && ($bytes_read > 0)) 
		{
		$vt->process ($cmdbuf);
		syswrite STDERR, $cmdbuf if (! -t STDERR);
		}
	}
	
# End processing if we've gone 1 round after command died with no output.
$eof = 1 if ($vt_process->{DIED} && $cmdbuf eq $EMPTY_STRING);

# Do your stuff here - use $vt->row_plaintext() to see what's on various
# rows of the screen, for instance, or before this main loop you could set
# up a ROWCHANGE callback which checks the changed row, or whatever.

# In this example, we just pass standard input to the SSH command, and we
# take the data coming back from SSH and pass it to the Term::VT102 object,
# and then we repeatedly dump the Term::VT102 screen.

# Read key presses from standard input and pass them to the command
# running in the child process.
if (vec ($rout, $vt_process->{IOT}->fileno, 1)) 
	{
	my $stdinbuf = $EMPTY_STRING ;
	my $bytes_read = $vt_process->{IOT}->sysread ($stdinbuf, $BUFFER_READ_SIZE );
	$eof = 1 if ((defined $bytes_read) && ($bytes_read == 0));
	$vt_process->{PTY}->syswrite ($stdinbuf, $bytes_read) if ((defined $bytes_read) && ($bytes_read > 0));
	}

# Dump what Term::VT102 thinks is on the screen. We only output rows
# we know have changed, to avoid generating too much output.
my $didout = 0;
foreach my $row (sort keys %{ $vt_process->{TERMINAL_CHANGE_BUFFER} }) 
	{
	printf "\e[%dH%s\r", $row, $vt->row_sgrtext ($row);
	$screen_data .= sprintf "\e[%dH%s\r", $row, $vt->row_sgrtext ($row);
	
	delete $vt_process->{TERMINAL_CHANGE_BUFFER}{$row};
	$didout ++;
	}
	
if (($didout > 0) || ($vt_process->{PREVXY} ne $EMPTY_STRING . $vt->x . q{,} . $vt->y)) 
	{
	printf "\e[%d;%dH", $vt->y, ($vt->x > $vt->cols ? $vt->cols : $vt->x);
	
	$screen_data .= sprintf "\e[%d;%dH", $vt->y, ($vt->x > $vt->cols ? $vt->cols : $vt->x);
	#todo: shouldn't prevxy be updated here?
	}

# Make sure the child process has not died.
$vt_process->{DIED} = 1 if (waitpid ($vt_process->{PID}, WNOHANG) > 0);

return($eof, $screen_data, $vt->x(), $vt->y()) ;
}

#---------------------------------------------------------------------------------------------------------

1 ;