File Coverage

blib/lib/Win32/PrintBox.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Win32::PrintBox;

use warnings;
use strict;
use Win32;
use Win32::Console::ANSI qw/ Cursor /;
require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw(set_page_size get_page_size);

our $VERSION = sprintf "%d.%03d", q$Revision: 0.004 $ =~ /: (\d+)\.(\d+)/;

our @COLLECTED_TEXT = ();
our $DEFAULT_PAGE_SIZE = 25;
our $PAGE_SIZE = $DEFAULT_PAGE_SIZE;
our $PAGE_NUM = 1;
our ($WinMode, $CMDExists);
# init();

END {
    pause();
}

##################################
# Put module initialization in a sub, so it can be called in testing
sub init {
    $WinMode = $^X =~ m/wperl/i;
# Use fileno(STDOUT) to see if STDOUT is open (-1 for wperl)

    $CMDExists = CMD_Cursor();
    # Warn handler
    if ($WinMode) {
    	tie *MSG_FH, 'Win32::PrintBox::IO';
    	select MSG_FH;
    }

    # DIE handler (removed - END block is sufficient)
	return 1;
}
##################################
sub pause {
    return if $WinMode || $CMDExists;
    # Otherwise, ask the user for permission to close, so any output is acknowledged
    $|++;                       # Flush any pending output
    print STDERR "Press Enter to continue\n";
    pause_in();
}
##################################
# put this in a subroutine, so we can override it for testing
sub pause_in {
    ;
}
############]######################
sub CMD_Cursor {
    # If a new command prompt window is opened, then the 'y' cursor position will be at the top
    # This can be faked by running cls & my_perl_script.pl
    my ($x, $y) = Cursor();     # reads cursor position
    return $y>1;                # Home is 1,1
}

##################################
# Accessor for number or elements to cache in @COLLECTED_TEXT
sub get_page_size {
    return $PAGE_SIZE;
}
##################################
# Mutator for number or elements to cache in @COLLECTED_TEXT
sub set_page_size {
    my $temp = shift // $DEFAULT_PAGE_SIZE;
    $PAGE_SIZE = $temp;
}

##################################
##################################
package Win32::PrintBox::IO;

use constant VB_OK => 0;
use constant VB_OK_CANCEL => 1;
use constant VB_CANCEL => 2;

##################################
sub new {
	my $self = bless {}, shift;

	# Do not re-define warn Handler if already called once by this package
	return if defined $main::W32_PRINT_BOX_OLD_WARN;

	# Using a "__WARN__" handler provides the way to re-direct warn statements to a MsgBox
	$main::W32_PRINT_BOX_OLD_WARN = $SIG{__WARN__};
	$SIG{__WARN__} = sub { WarnBox(@_) };
	return $self;
}

##################################
sub WarnBox {											# Send Warnings immediately
	my $msg = join("\n", @_);
	return if $msg eq '';
	my $answer = Win32::MsgBox($msg, VB_OK_CANCEL, 'Warning!');
	die if $answer == VB_CANCEL;
	my $h = $main::W32_PRINT_BOX_OLD_WARN;
	$h->(@_) if $h;                                # invoke the old handler
	return 1;
}

##################################
sub PrintMsgBox {
	my $self = shift;
	push (@COLLECTED_TEXT, @_);
	if ($#COLLECTED_TEXT >= $PAGE_SIZE - 1) {
		my $answer = Win32::MsgBox( join('', @COLLECTED_TEXT), VB_OK_CANCEL, 'Page ' . $PAGE_NUM++);
		die if $answer == VB_CANCEL;
		@COLLECTED_TEXT = ();
	}
}

sub TIEHANDLE	{ shift->new(@_) }
sub PRINT		{ shift->PrintMsgBox(@_) }
sub PRINTF		{ shift->PrintMsgBox(sprintf(@_)) }
# DESTROY only applies in WinMode; in DOS mode, we didnt tie anything, so nothing to destroy
sub DESTROY     { Win32::MsgBox( join('', @COLLECTED_TEXT), VB_OK, 'Done') if @COLLECTED_TEXT}

1;
__END__