File Coverage

blib/lib/Chart/EPS_graph.pm

Criterion	Covered	Total	%
statement	21	263	7.9
branch	0	84	0.0
condition	0	18	0.0
subroutine	7	25	28.0
pod	0	18	0.0
total	28	408	6.8

# $Source: /usr/pkg/lib/perl5/site_perl/5.8.0/Chart/EPS_graph.pm $
# $Date: 2006-08-19 $

package Chart::EPS_graph;

use strict;
use warnings;
use Carp qw(carp croak);
use Config;
use IPC::Open3;
use English qw(-no_match_vars);
use Chart::EPS_graph::PS;
require File::Find;

our ($VERSION) = '$Revision: 0.01 $' =~ m{ \$Revision: \s+ (\S+) }xm;

my $EMPTY = q{};

# The test module is stand-alone OO and makes own object.
sub full_test {
	my ($ignored, $dir_path) = @_;
	require Chart::EPS_graph::Test;
	return Chart::EPS_graph::Test->full_test($dir_path);
}

# Yack at user about what goes on.
sub verbose {
	ref( my $self = shift ) or croak 'Oops! Method verbose() is instance, not class.';
	print $_[0] if $_[1] <= $self->{verbosity};
	return 'Pthhht! to Perl::Critic';
}

sub version { return $VERSION }

# Create new object.
sub new {
	ref( my $class = shift ) and croak 'Oops! Method new() is class, not instance.';
	my $self = {};
	for (keys %Chart::EPS_graph::PS::ps_defaults){
		$self->{$_} = $Chart::EPS_graph::PS::ps_defaults{$_}
	}
	if ( $_[0] ) { $self->{pg_width}  = shift }
	if ( $_[0] ) { $self->{pg_height} = shift }
	$self->{ps_header}   = $Chart::EPS_graph::PS::ps_header;
	$self->{ps_header}   =~
		s/BoundingBox:.*\n/BoundingBox: 0 0 $self->{pg_width} $self->{pg_height}\n/m;
	$self->{names}       = [];
	$self->{data}        = [];
	$self->{y1}          = [];
	$self->{y2}          = [];
	$self->{shown}       = [];
	$self->{not_shown}   = [];
	$self->{close_gap}   = 0;
	$self->{x_is_zeroth} = 1;
	$self->{x_scale}     = 1;
	$self->{ps_path}     = $EMPTY;
	$self->{verbosity}   = 1; # 0 = Quiet, 1 = Info, 2 = Diagnostic.
	bless $self, $class;
	return $self;
}

# Allow user to change defaults and input data.
sub set {
	ref( my $self = shift ) or croak 'Oops! Method set() is instance, not class.';
	my %user_defs = @_;
	while ( my ($key, $value) = each %user_defs ) {
		if ( exists $self->{$key}) {$self->{$key} = $value }
		else { carp "Oops! Key '$key' non-existant in hash '$self'.\n" }
	}
	return 'Pthhht! to Perl::Critic';
}

# Make custom adjustments to default Prolog defs.
sub ps_defs_insert {
	ref( my $self = shift ) or croak 'Oops! Method ps_defs_insert() is instance, not class.';
	$self->chans_elect();
	my $str = ();

	$str .= "/bg_color ($self->{bg_color}) def \n";
	$str .= "/fg_color ($self->{fg_color}) def \n";
	$str .= '/web_colors [ ';
	for ( @{$self->{web_colors}} ) { $str .= "/$_ " }
	$str .= "] def \n";

	$str .= "/font_name /$self->{font_name} def \n";
	$str .= "/font_size $self->{font_size} def \n";


	# Set not-to-be-shown labels as empty strings.
	$str .= "/label_top ($self->{label_top}) def \n";
	$str .= "/label_y1 ($self->{label_y1}) def \n";
	$str .= "/label_y1_2 ($self->{label_y1_2}) def \n";
	$str .= "/label_y2 ($self->{label_y2}) def \n";
	$str .= "/label_y2_2 ($self->{label_y2_2}) def \n";
	$str .= "/label_x ($self->{label_x}) def \n";
	$str .= "/label_x_2 ($self->{label_x_2}) def \n";

	$str .= '/fake_col_zero_flag ';
	$str .= $self->{x_is_zeroth} ? 'false' : 'true';
	$str .= " def \n";

	$str .= "/fake_col_zero_scale $self->{x_scale} def \n";

	$str .= "/data_sets 1 def \n";

	# This is an ugly, ex-post-facto hack.
	# When chans skipped, patch up the bottom string to cover up remove gap in
	# channel ID's. In short, make legend ID match the gap-free curve ID.
	if ($self->{close_gap}) {
		$self->{shown} = [ @{ $self->{y1} }, @{ $self->{y2} } ];
		my @gap_free = gap_free_skip( $self->{shown}, $self->{not_shown} );
		for my $i ( 0 .. $#gap_free ) {
			$self->{label_x_proc} =~ s/  $self->{shown}->[$i] /  $gap_free[$i] /m;
			$self->{label_x_proc} =~ s/  $self->{shown}->[$i] show_color_id/ $gap_free[$i] show_color_id/m;
		}
	}

	$str .= $self->{label_x_proc}; # List of chans shown

	# An array of data chans embeded in PostScript but whose curves are not to be shown
	# and their colors skipped over by those curves which are shown.
	$str .= '/not_shown [ ';
	$str .= join q{ }, @{$self->{not_shown}} unless $self->{close_gap}; # 'Pthhht!'
	$str .= " ] def \n";

	# Y2 axis (re-)numbered for PostScript.
	$str .= '/y2 [';
	if ($self->{close_gap}) {
		$str .= join q{ }, gap_free_skip( $self->{y2}, $self->{not_shown} );
	}
	else {
		$str .= join q{ }, @{ $self->{y2} };
	}

	$str .= "] def \n";    # Y2 axis
	return $str;
}

# Given two arrays retrun a copy of 2nd array after decrementing its elements
# for each lesser element of 1st array. Used to provide PostScript with /column_arrays
# named 0 thru N with no gaps when chans have been skipped over to graph.
sub gap_free_skip {
	my ( $shown_aref, $not_shown_aref ) = @_; # Local, not part of $self->{foo} hash!
	my @gap_free = @$shown_aref;
	for my $i ( 0 .. $#gap_free ) {
		for my $j (@$not_shown_aref) {

			# Index decremented for each gap beneath it.
			if ( $j < $shown_aref->[$i] ) { --$gap_free[$i] }
		}
	}
	return @gap_free;
}

# Assign an arrow character from Symbol font to
# indicate which Y axis ought be read from.
sub y_arrow {
	ref( my $self = shift ) or croak 'Oops! Method y_arrow() is instance, not class.';
	my $i = shift;
	my $arrow = $EMPTY;
	my @y2 = @{$self->{y2}};
	if (@y2) {
		$arrow = '\254';
		for (@y2) { $arrow = '\256' if $_ == $i}
	}
	return $arrow;
}

# PostScript strings are ( ) delimited!
sub ps_str_esc {
	ref( my $self = shift ) or croak 'Oops! Method ps_str_esc() is instance, not class.';
	$_[0] =~ s/\(/\\(/gm;
	$_[0] =~ s/\)/\\)/gm;
	$self->verbose( "ps_str_esc(): $_[0] \n", 2);
	return $_[0];
}

# Build label for chans shown, list of those not to show.
sub chans_elect {
	ref( my $self = shift ) or croak 'Oops! Method chans_elect() is instance, not class.';

	for ( @{ $self->{names} } ) { $_ = $self->ps_str_esc($_) }

	my @ps_string_list = qw(
		label_top
		label_x
		label_x_2
		label_y1
		label_y1_2
		label_y2
		label_y2_2
	);

	for (@ps_string_list) { $self->{$_} = $self->ps_str_esc($self->{$_}) }

	# Collect list of shown-channel names
	# Prettify them into a graph legend good for B&W, not just color.
	for (@{ $self->{y1} }, @{ $self->{y2} }) {
		my $arrow = $self->y_arrow($_);
		$self->{label_x_proc} .= " ($arrow$_) $_ show_color_id ($self->{names}->[$_]  ) show ";
	}

	# Determine list of channels not to show.
	for ( 1 .. $#{$self->{names}} ) {

		# Mitigate an RE between Perl & PostScript by swaping all
		# escaped-for-PostScript string delimiters with Perl RE dots.
		my $re = $self->{names}->[$_];
		$re =~ tr/\\()/.../;

		push @{$self->{not_shown}}, $_ unless $self->{label_x_proc} =~ m/$re/m;

		# Problems may still exist between Perl RE's and PostScript syntax.
		# Diagnose these via CLI if in doubt by setting $verbosity = 2.
		$self->verbose(
			"RE Check 1: \n\t" . $self->{label_x_proc}
			. "\n\t =~ \n\t$re" . "\n"
			, 2
		);
		$self->verbose(
			'RE Check 2: not_shown = '
			. join(', ', @{$self->{not_shown}}) . "\n\n"
			, 2
		);
	}

	$self->{label_x_proc} = "/label_x_proc { $self->{label_x_proc} } def \n";
	$self->verbose( "LABEL X PROC: $self->{label_x_proc} \n", 2);
	return 'Pthhht! to Perl::Critic';
}

# Output data in PostScript file format.
sub write_eps {
	ref( my $self = shift ) or croak 'Oops! Method write_eps() is instance, not class.';
	$self->{ps_path} = qq|$_[0]|;
	local $OUTPUT_AUTOFLUSH = 1; # from 'use ENGLISH'

	my ( $ps_user_defs ) = $self->ps_defs_insert();

	if ( open my $fh, '>', "$self->{ps_path}" ) {

		# Embed filename sans path in PostScript header.
		$self->{ps_header} =~ s/%%Title:/%%Title: ($self->{ps_path})/m;

		# Embed document font resources.
		my $doc_rsrcs = "font Symbol $self->{font_name}";
		$self->{ps_header} =~ s/%%DocumentResources:/%%DocumentResources: $doc_rsrcs/m;

		# IMPORTANT NOTE: Know that Perl::Critic errs about the package vars
		# named like "$Chart::EPS_graph::PS::ps_foo" below. They are needed!

		print {$fh} $self->{ps_header};
		print {$fh} $Chart::EPS_graph::PS::ps_web_colors_dict;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_generic;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_graphing;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_data_arrays;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_drawing;
		print {$fh} $ps_user_defs;
		print {$fh} "/pg_width $self->{pg_width} def \n";
		print {$fh} "/pg_height $self->{pg_height} def \n";
		for ( $self->chans_pl2ps() ) { print {$fh} $_ }
		print {$fh} $Chart::EPS_graph::PS::ps_tail;
		close $fh;
		$self->verbose("Okay, EPS file written to path '$self->{ps_path}' \n", 1);
	}
	else { print qq|Oops! Cannot write to $self->{ps_path}: $!\n| }
	return 'Pthhht! to Perl::Critic';
}

# Convert kept Perl $self->{data} to sequential PostScript /column_arrays.
sub chans_pl2ps {
	ref( my $self = shift ) or croak 'Oops! Method chans_pl2ps() is instance, not class.';
	my @graph_ps;
	my $k = $self->{x_is_zeroth} ? 0 : 1; # Preserve /channel_array-0 for X axis only.

	# Write data from all chans into PostScript arrays
	for my $i ( 0 .. $#{$self->{data}} ) {
		my $array_ps = ' [ ';
		for ( 0 .. $#{ $self->{data}->[0] } ) {
			$array_ps .= sprintf '%.3e ', $self->{data}->[$i][$_];
		}
		$array_ps .= " ] def \n\n";

		# If skipping chans, is this chan among those not shown?
		my $flg = 0;
		if ($self->{close_gap}) {
			for (@{$self->{not_shown}}) {
				if ( $_ == $i ) { $flg = 1; last; }
			}
		}

		# Renumber chans so that PostScript progs /column_array's will
		# be innumerated in sequence with no gaps.
		if ( $i == 0 || $flg == 0 ) {
			$array_ps = "/column_array-$k $array_ps";
			push @graph_ps, $array_ps;
			++$k;
		}
	}
	push @graph_ps, "\n true \n";
	return @graph_ps;
}

# Narrow the search of directories made by win32_seek.
# If executable in dir named by numerical version, reduce the number of
# searched directories by matching to a regex.
sub single_dir {
	my ($parent, $re) = @_;
	my @fewer;
	opendir DIR, $parent || croak "Can't open $parent at sub single_dir().";
	my @files = readdir DIR;
	closedir DIR;
	for (@files) { push @fewer, $_ if $_ =~ m/$re/m}
	return scalar @fewer == 1 ? $fewer[0] : 0;
}

# On Win32 different veresions may be located variously.
# Not knowing which version user has, we mush seek it.
sub win32_seek {
	our ($reg_ex, $start_path) = @_;
	our $cmd_exe = $EMPTY;

	sub seek_exe {
		if (m/$reg_ex/m) { $cmd_exe = qq|"$File::Find::name"| }
		return 'Pthhht! to Perl::Critic';
	}

	# Hunt for its full path.
	File::Find::find(\&seek_exe, $start_path);

	$cmd_exe = qq|$cmd_exe|;
	$cmd_exe =~ s/\\/\//gm;
	return $cmd_exe;
}

# On Win32 different veresions may be located variously.
sub win32_run_gs {
	ref( my $self = shift ) or croak 'Oops! Method win32_run_gs() is instance, not class.';
	my $gs_args = shift;
	$self->verbose("Busy hunting for Ghostscript's executable...\n", 1);
	my $cmd = win32_seek('gswin32\.exe$','C:/Program Files/gs/');
	$self->verbose("Path to GhostScript: $cmd \n", 2);
	if ($cmd =~ m/gswin32/m) {
		`$cmd $gs_args`; # 'Pthhht!'
	} else {
		carp 'Oops! Could not find Ghostscript. Is it installed? '
	}
	return 'Pthhht! to Perl::Critic';
}

# On Win32 different versions may be located variously.
sub win32_run_gimp {
	ref( my $self = shift ) or croak 'Oops! Method win32_run_gimp() is instance, not class.';
	my $path = 'C:/Program Files/';
	$self->verbose("Busy hunting for The GIMP's executable...\n", 1);
	my $sub_dir = single_dir($path, 'GIMP-');
	$path .= "$sub_dir/" if $sub_dir;
	$self->verbose("Search path to The GIMP: $path \n", 2);
	my $cmd = win32_seek('gimp-[2-9]\.[2-9]+\.exe$', $path);
	$self->verbose("Path to The GIMP: $cmd \n", 2);
	if ($cmd =~ m/gimp-/m) {
		system qq|start $cmd $cmd|, qq|"$self->{ps_path}"|
	}
	else { carp 'Oops! Could not find The GIMP. Is it installed? '}
	return 'Pthhht! to Perl::Critic';
}

# Cause *.eps graph to be converted/displayed in by separate program.
# Configured so may be called by Chart::EPS_graph::Test.pm
sub display {
	ref( my $self = shift ) or croak 'Oops! Method display() is instance, not class.';
	my $cmd;
	my $gs_args = q{ }
		. '-dSAFER -dBATCH -dNOPAUSE -sDEVICE=png16m '
		. "-dDEVICEWIDTHPOINTS=$self->{pg_width} "
		. "-dDEVICEHEIGHTPOINTS=$self->{pg_height} "
		. '-dTextAlphaBits=2 -dGraphicsAlphaBits=4 -r96x96 '
		. qq|-sOutputFile="$self->{ps_path}.png" |
		. qq|"$self->{ps_path}" |;
		$self->verbose("Ghostscript args:\n$gs_args\n", 2);

	# Test OS: if not Windoze do as for UNIX-like.
	if ( $Config::Config{'osname'} =~ m/Win32/im ) {
		if (!$_[0] || $_[0] =~ m/EPS/im) { # Default argument.
			$cmd = qq|"gsview32.exe"|; # Perl::Critic errs about quotes here.
			system qq|start $cmd $cmd|, qq|"$self->{ps_path}"|;
		}
		elsif ($_[0] =~ m/^GIMP$/im)  { $self->win32_run_gimp() }
		elsif ($_[0] =~ m/^GS$/im) { $self->win32_run_gs($gs_args) }
		else {
			carp 'Oops! Sub display() expects "EPS", "GIMP", "GS" or nothing'
				. "not '$_[0]'.\n"
		}
	}
	else {

		# UNIX users get different choices.
		if (!$_[0] || $_[0] =~ m/EPS/im) { $cmd = 'gv --spartan ' } # Default
		elsif ($_[0] && $_[0] =~ m/GIMP/im)  { $cmd = 'gimp ' }
		elsif ($_[0] && $_[0] =~ m/GS/im)  { $cmd = 'gs' . $gs_args }
		else {
			carp 'Oops! Sub display() expects "EPS", "GIMP", "GS" or nothing'
				. " not '$_[0]'.\n";
		}

		$cmd .= qq|$self->{ps_path}|;

		`$cmd &` # Advice by Perl::Critic on backticks crashes program here.
	}
	return 'Pthhht! to Perl::Critic';
}

1;

__END__