File Coverage

blib/lib/Chart/Graph/XrtUtils.pm

Criterion	Covered	Total	%
statement	33	191	17.2
branch	7	86	8.1
condition			n/a
subroutine	9	23	39.1
pod			n/a
total	49	300	16.3

## XrtUtils.pm is a sub-module of Graph.pm. It has all the subroutines
## needed for the Xrt3d part of the package.
##
## $Id: XrtUtils.pm,v 1.13 2006/06/07 21:09:33 emile Exp $ $Name:  $
##
## This software product is developed by Michael Young and David Moore,
## and copyrighted(C) 1998 by the University of California, San Diego
## (UCSD), with all rights reserved. UCSD administers the CAIDA grant,
## NCR-9711092, under which part of this code was developed.
##
## There is no charge for this software. You can redistribute it and/or
## modify it under the terms of the GNU General Public License, v. 2 dated
## June 1991 which is incorporated by reference herein. This software is
## distributed WITHOUT ANY WARRANTY, IMPLIED OR EXPRESS, OF MERCHANTABILITY
## OR FITNESS FOR A PARTICULAR PURPOSE or that the use of it will not
## infringe on any third party's intellectual property rights.
##
## You should have received a copy of the GNU GPL along with this program.
##
##
## IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY
## PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
## DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF THE USE OF THIS
## SOFTWARE, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF
## THE POSSIBILITY OF SUCH DAMAGE.
##
## THE SOFTWARE PROVIDED HEREIN IS ON AN "AS IS" BASIS, AND THE
## UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO PROVIDE MAINTENANCE,
## SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. THE UNIVERSITY
## OF CALIFORNIA MAKES NO REPRESENTATIONS AND EXTENDS NO WARRANTIES
## OF ANY KIND, EITHER IMPLIED OR EXPRESS, INCLUDING, BUT NOT LIMITED
## TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A
## PARTICULAR PURPOSE, OR THAT THE USE OF THE SOFTWARE WILL NOT INFRINGE
## ANY PATENT, TRADEMARK OR OTHER RIGHTS.
##
##
## Contact: [e-mail]
##
##
package Chart::Graph::XrtUtils;
use Exporter ();

@ISA = qw(Exporter);
@EXPORT = qw();
%EXPORT_TAGS = (UTILS => [qw(&_set_xrtpaths &_set_ldpath &_print_matrix
			     &_print_array &_verify_ticks &_exec_xrt3d &_exec_xrt2d
			     &_exec_netpbm &_exec_xvfb &_try_port &_convert_raster
			     &_childpid_dead &_transfer_file)],
	       );

Exporter::export_ok_tags('UTILS');

use Carp;
use POSIX ":sys_wait_h";	# for waitpid()
use Chart::Graph::Utils qw(:UTILS);

$cvs_Id = '$Id: XrtUtils.pm,v 1.13 2006/06/07 21:09:33 emile Exp $';
$cvs_Author = '$Author: emile $';
$cvs_Name = '$Name:  $';
$cvs_Revision = '$Revision: 1.13 $';

$VERSION = 3.2;

use strict;
use File::Basename;

use vars qw($xrt2d $xrt3d);

#
# Subroutine: set_converterpaths()
#
# Description: set paths for converter programs in particular.  This
#              subroutine can take one or two arguments and tests if
#              the required converter programs are indeed available
#              for the choosen method to convert a file from one
#              graphics format to another.
#
sub _set_converterpaths {
	my @converters = @_;

	# Loop through the list of converter seeing which are available
	foreach my $converter (@converters) {
	  if (not -x $$converter) {
		if (not $$converter = _get_path($$converter)) {
		  return(0);
		}
	  }
	}
	return(1);
  }

#
# Subroutine: _convert_raster($plot_file, $output_file)
#
# Description: A subroutine to over see the conversion process from
#              one raster graphic format to another.  It will try
#              ImageMagick convert first and if that fails try Netpbm
#              utilities if they are available in that format.
#
sub _convert_raster {
    my $FORMAT = shift;
    my $plot_file = shift;
    my $output_file = shift;

  # First try ImageMagick as it is more robust and simpler
  if (_set_converterpaths(\$convert)) {
	if (_exec_convert($convert, $FORMAT, $plot_file, $output_file)) {
	  return(1);
	} else {
	  carp "Attempt to use ImageMagick failed, will try Netpbm."
	}
  }	else {
	carp "No ImageMagick found, will try Netpbm."
  }

  if ($FORMAT eq 'GIF') {
	_try_netpbm_combo($xwdtopnm, $ppmtogif, $plot_file, $output_file);
  }
  elsif ($FORMAT eq 'JPG') {
	_try_netpbm_combo($xwdtopnm, $ppmtojpg, $plot_file, $output_file);
  }
  elsif ($FORMAT eq 'PNG') {
	_try_netpbm_combo($xwdtopnm, $pnmtopng, $plot_file, $output_file);
  } else {
	carp "Untrapped raster image format - XrtUtils.pm internal error";
	return(0);
  }
}

#
# Subroutine _try_netpbm_combo($xwdtopbm, pbmtotarget, $xwd_file, $target_file)
#
#
# Description: Contains the logic for testing if a combination of
#              netpbm programs can be accessed and executed to perform
#              the desired conversion.  If not, it produces the
#              appropriate error messages.  Basically, it saves a
#              batch of conditional statements that would otherwise be
#              repeated.
#
sub _try_netpbm_combo {
    my ($xwdtopbm, $pbmtotarget, $xwd_file, $target_file) = @_;

	if (_set_converterpaths(\$xwdtopbm, \$pbmtotarget)) {
	  if (_exec_netpbm($xwdtopbm, $pbmtotarget, $xwd_file, $target_file)) {
		return(1);
	  } else {
		carp "Failure to execute any suitable image " .
		  "converters for create file: $target_file";
		return(0);
	  }
	} else {
	carp "Unable to find any suitable image converters to " .
	  "create file: $target_file";
	return(0);
  }
}

#
# Subroutine: set_xrtpaths()
#
# Description: set paths for external programs required by xrt()
#              if they are not defined already
#
sub _set_xrtpaths {

    my $xrtver = shift;



    if (defined($xrtver)) {
	  if ($xrtver eq "xrt2d") {
	    if (not $Chart::Graph::xrt2d = _get_path("xrt2d")) {
		  return 0;
	    }
	  }

	  if ($xrtver eq "xrt3d") {
	    if (not $Chart::Graph::xrt3d = _get_path("xrt3d")) {
		  return 0;
	    }
	  }
    }

    if (not defined($xwdtopnm)) {
	if (!($xwdtopnm = _get_path("xwdtopnm"))) {
	    return 0;
	}
    }

    if (not defined($xvfb)) {
	if (not $xvfb = _get_path("Xvfb")) {
	    return 0;
	}
    }

    # make sure /usr/dt/lib is in the library path
    _set_ldpath("/usr/dt/lib");

    return 1;
}

#
# Subroutine: set_ldpath()
#
# Description: Xvfb has trouble finding libMrm, so we have to add
#              /usr/dt/lib to LD_LIBRARY_PATH
#

sub _set_ldpath {
    my ($libpath) = @_;

    if (not defined($ENV{LD_LIBRARY_PATH})) {
	$ENV{LD_LIBRARY_PATH} = "$libpath";
	return 1;
    }

    my @ldpath = split (/:/, $ENV{LD_LIBRARY_PATH});

    # make sure library path isn't already defined
    foreach my $i(@ldpath){
	if ($i eq $libpath) {
	    return 1;
	}
    }

    # add library path to LD_LIBRARY_PATH
    $ENV{LD_LIBRARY_PATH} = "$libpath:$ENV{LD_LIBRARY_PATH}";
    return 1;
}

#
# Subroutine: print_matrix()
#
# Description: print out all the elements
#              in a X by Y  matrix, row by row
#

sub _print_matrix {
    my ($handle, @matrix) = @_;

    foreach my $row (@matrix){
	foreach my $i (@{$row}){
	    print $handle "$i\t";
	}
	print $handle "\n";
    }
    return 1;
}


#
# Subroutine:  _transfer_file($handle, $data_filename)
#
# Description: open file $data_filename.  Read the contents
# and write it into the command file tab delimited.  Don't
# assume data was tab delimited to be safe.
#
sub  _transfer_file {
  my $handle = shift;
  my $data_filename = shift;
  my $data;
  my @elements;

  unless(open(DATAHDL, $data_filename)) {
	carp "Unable to open data file: $data_filename for reading";
	return(0);
  }
  while (defined($data = )) {
	chomp($data);
	@elements = split(/\s+/, $data);
	foreach my $element (@elements) {
	  print $handle $element, "\t";
	}
	print $handle  "\n";
  }
  unless(close(DATAHDL)) {
    carp "Unable to close data file: $data_filename after reading";
  }
  return(1);
}

#
# Subroutine: print_array()
#
# Description:  print out each element of array, one per line
#

sub _print_array {
    my ($handle, @array) = @_;
    my $i;

    foreach $i (@array) {
	print $handle "$i\n";
    }
    return 1;
}

#
# Subroutine: verify_ticks();
#
# Description: check that the number of tick labels is the same
#              as the number of xy rows and columns. we can only have
#              as many ticks as the number of rows or columns
#              we make this subroutine so that the calling subroutine
#              is kept cleaner.

sub _verify_ticks {
    my ($cnt, $ticks_ref) = @_;

    # if no ticks are given then just
    # give the xrt binary "1, 2,..."
    if (not defined($ticks_ref)) {
	my @def_ticks;
	for (my $i = 0; $i < $cnt; $i++) {
	    $def_ticks[$i] = $i + 1;
        }
	$ticks_ref = \@def_ticks;
    }

    my $tick_cnt = @{$ticks_ref};

    if ($cnt ne $tick_cnt){
	carp "number of tick labels must equal the number of xy rows and columns";
	return 0;
    }
    return 1;
}

#
# Subroutine: exec_xrt3d()
#
# Description: execute the xrt3d program on the command file.
#              xrt3d generates a xwd file.
#
sub _exec_xrt3d {
    my ($command_file) = @_;
    my ($output);
    my ($childpid, $port);
    my $display_env = $ENV{DISPLAY};
    my $status;

    if ($Chart::Graph::use_xvfb) {
	# start the virtual X server
	($childpid, $port) = _exec_xvfb();
	$status = system("$Chart::Graph::xrt3d -display :$port.0 < $command_file");
    } else {
	# use the local X server
	# warning: colors might be messed up
	# depending on your current setup
	$status = system("$Chart::Graph::xrt3d -display $display_env < $command_file");
    }

    #my $status = system("$xrt -display :$port.0 < $command_file");
    if (not _chk_status($status)) {
	return 0;
    }

    if ($Chart::Graph::use_xvfb) {
	kill('KILL', $childpid);
    }

    return 1;
}

#
# Subroutine: exec_xrt2d()
#
# Description: execute the xrt2d program on the command file.
#              xrt2d generates a xwd file.
#
sub _exec_xrt2d {
    my ($command_file, $options) = @_;
    my ($output);
    my ($childpid, $port);
    my $display_env = $ENV{DISPLAY};
    my $status;

    if ($Chart::Graph::use_xvfb) {
	# start the virtual X server
	($childpid, $port) = _exec_xvfb();
	printf STDERR "\tXRT is $Chart::Graph::xrt2d\n";
	my $status = system("$Chart::Graph::xrt2d -display ipn:$port.0 < $command_file $options");
    } else {
	# use the local X server
	# warning: colors might be messed up
	# depending on your current setup
	$status = system("$Chart::Graph::xrt2d -display $display_env < $command_file $options");
    }

    if (not _chk_status($status)) {
	return 0;
    }

    if ($Chart::Graph::use_xvfb) {
	kill('KILL', $childpid);
    }

    return 1;
}

#
# Subroutine: exec_convert
#
#
# Description: Use the Imagemagick 'convert' utility to convert the xwd
#              file into any one of the other common raster image
#              formats used commonly in web page production.
#
sub _exec_convert {
    my ($convert, $FORMAT, $xwd_file, $target_file) = @_;
    my ($status);


    if ($Chart::Graph::debug) {
	$status = system(join('', "$convert -verbose $xwd_file ",
                              $FORMAT, ":$target_file"));
    } else {
	$status = system(join('', "( $convert $xwd_file ",  $FORMAT,
                                  ":$target_file; ) 2> /dev/null"));
    }

    if (not _chk_status($status)) {
	return 0;
    }
    return 1;
}
#
# Subroutine: _exec_netpbm
#
#
# Description: Convert a raster image using the older utilities now
#              collected under the name 'netpbm.'  Note that not all
#              conversions are commonly included wiht all UNIX
#              distributions so that while older conversions such as
#              'xwd' -> 'gif' are likely to work, others such as
#              conversions to 'png' may not without downloading new
#              software.
#
#              The conversion strategy always involves a pipe from the
#              X-windows 'xwd' format to some sort 'pbm' format and
#              then from that universal format into the target format.
#              For this reason, it is more prone to machine
#              architecture issues and other errors.
#
sub _exec_netpbm {
    my ($xwdtopbm, $pbmtotarget, $xwd_file, $target_file) = @_;
    my ($status);

    if ($Chart::Graph::debug) {
	$status = system("$xwdtopbm $xwd_file | $pbmtotarget > $target_file");
    } else {
	$status = system(join('', "( $xwdtopbm -quiet $xwd_file | ",
                              "$pbmtotarget -quiet > $target_file; ) ",
                              "2> /dev/null"));
    }

    if (not _chk_status($status)) {
	return 0;
    }
    return 1;
}

#
# Subroutine: exec_xvfb()
#
# Description:  this starts the vitualX server(X is required by xrt, so
#               we fake out xrt with Xvfb, for speed and compatability)
#
#
sub _exec_xvfb {
    my $port = 99;
    my $childpid;
    my $sleep_time = 1;
    my $try_count = 0;
    my $trialnumber;
    my $childpid_status;

    # starting with port 100, we try to start
    # the virtual server until we find an open port
    # because of the nature of the virtual x server
    # we use, in order to know if we have found an
    # open port, we have to sleep.
    # we check the pid of the virtual x process we started
    # and see if it died or not.

    while ($childpid_status = _childpid_dead($childpid)) {
	$port++;
	$try_count++;
	if ($try_count > 10) {
	    die "Error: Failed too many times\n";
	}
	$trialnumber = _number_to_eng($try_count);
	print STDERR "*** $trialnumber try ***" unless (not $Chart::Graph::debug);
	$childpid = _try_port($port);
	sleep($sleep_time);
    }
    print STDERR " SUCCESS!!!\n" unless (not $Chart::Graph::debug);

    # save the childpid so we can stop the virtual server later
    # save the $port so we can tell xrt where the virtual server is.
    return ($childpid, $port);
}
#
# Subroutine: try_port();
#
# Description:  will try to start Xvfb on specified port
sub _try_port {

    my ($port) = @_;
    my ($childpid);

    #fork a process
    if (not defined($childpid = fork())){
	# the fork failed
	carp "cannot fork: $!";
	return 0;
    } elsif ($childpid == 0) {
	# we are in the child process
	if ($Chart::Graph::debug) {
	    if (not exec "$xvfb :$port") {
		die "can't do $xvfb :$port: $!\n";
	  }
	}
	else {
	    if (not exec "$xvfb :$port 2> /dev/null") {
		die "can't do $xvfb :$port 2> /dev/null: $!\n";
	    }
	}

	die "should never reach here\n";

    } else {
	# we are in the parent, return the childpid
	# so we can kill it later.
	return $childpid;
    }

}

#
# Subroutine: childpid_dead
#
# Description: check to see if a PID has died or not
#
#
sub _childpid_dead {
    my ($childpid) = @_;

    if (not defined($childpid)) {
	return 1;
    }

    # WNOHANG: waitpid() will not suspend execution  of
    # the  calling  process  if  status is not
    # immediately available  for  one  of  the
    # child processes specified by pid.
    return waitpid($childpid, &WNOHANG);
}

1;