File Coverage

blib/lib/Chart/Graph/Xmgrace.pm

Criterion	Covered	Total	%
statement	238	492	48.3
branch	99	218	45.4
condition	1	6	16.6
subroutine	23	35	65.7
pod	0	1	0.0
total	361	752	48.0

## Xmgrace.pm is a sub-module of Graph.pm. It has all the subroutines
## needed for the gnuplot part of the package.
##
## $Id: Xmgrace.pm,v 1.34 2006/06/07 21:09:33 emile Exp $ $Name:  $
##
## This software product is developed by Esmond Lee 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::Xmgrace;
use Exporter();

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(&xmgrace);

use Carp;			# for carp() and croak()
use Chart::Graph::Utils qw(:UTILS);	# get global subs and variable
use Chart::Graph::XrtUtils qw(:UTILS);
use Chart::Graph::Xmgrace::Grace;
use Chart::Graph::Xmgrace::Graph_Presentation_Type;
use Chart::Graph::Xmgrace::Dataset;
use FileHandle;

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

$VERSION = 3.2;

use strict;

#for debugging purposes.
my $stdout = 0;

# these variables hold default options for xmgrace
my %def_xmgrace_global_opts = (
			       "title" => "untitled", # @description
			       "subtitle" => "",
			       "type of graph" => "XY graph", # XY graph, XY chart, Polar Graph, Smith Chart, Fixed
			       "output type" => "PNG", # png, jpeg, ps
   			       "output file" => "untitled-grace",
			       "grace output file" => "untitled-grace.agr",
			       "xrange" => undef,
			       "yrange" => undef,
			       "x-axis label" => "x-axis",
			       "y-axis label" => "y-axis",
			       "alt x-axis label" => undef,
			       "alt y-axis label" => undef,
			       "logscale x" => undef,
			       "logscale y" => undef,
			       "xtics" => undef,
			       "ytics" => undef,
			       "alt xtics" => undef,
			       "alt ytics" => undef,
			       "stacked" => "false",
			       "extra opts" => undef,
			      );


my $def_graph_appearance = new Chart::Graph::Xmgrace::Graph_Presentation_Type;

my %def_xmgrace_data_opts = (
			     "set presentation" => "XY",
			     "options" => $def_graph_appearance->{"XY graph"},
			     "title" => "untitled data set", # comment, legend
			     "data format" => undef, # columns, matrix, or file
			    );

# New Hash of array references to hold list of options that might need to
# be checked against options.  If Xmgrace program changes.  Update here
my %def_xmgrace_available_options =
    ( "type of graph" => ["XY graph", "XY chart", "Bar chart",
			  "Polar graph", "Smith chart", "Fixed",
			  # "Pie Chart", # Not yet implemented
			  ],
    );


#
#
# Subroutine: xmgrace()
#
# Description: this is the main function you will be calling from
#              our scripts. please see
#              www.caida.org/Tools/Graph/graph_xmgrace.html for a
#              full description and how-to of this subroutine
#

sub xmgrace {
    my ($user_global_opts_ref, @data_sets) = @_;
    my (%data_opts, %global_opts,);
    my ($plottype, $output_file, $plot_file, $output_type, $data_set_ref);
    #my $autoscale = 1;		# by default use autoscale
    #my ($xscale, $yscale) = (0,0);
    my $autoscale = "";

    # create a new filehandle to be used throughout package
    my $handle = new FileHandle;
    my $grace_output_file;

    my $grace = new Chart::Graph::Xmgrace::Grace("g0");

    # create tmpdir
    _make_tmpdir("_Xmgrace_");	# grace files should be saved for user tweaking

    # set paths for external programs
    if (not _set_xmgrace_paths()) {
    	_cleanup_tmpdir();
    	return 0;
    }

    # check first arg for hash
    if (ref($user_global_opts_ref) ne "HASH") {
	carp "Global options must be a hash";
	_cleanup_tmpdir();
	return 0;
    }

    # check for data sets
    if (not @data_sets) {
	carp "no data sets";
	$handle->close;
	_cleanup_tmpdir();
	return 0;
    }

    my $command_file = _make_tmpfile("command", "agr");
    # remember to close the file if we return
    if (not $handle->open(">$command_file")) {
	carp "could not open file: $command_file";
	_cleanup_tmpdir();
	return 0;
    }

    # process global options
    # call to combine user options with default options
    %global_opts = _mesh_opts($user_global_opts_ref, \%def_xmgrace_global_opts);

    # crunch on the global options
    while (my ($key, $value) = each %global_opts) {

	if ($key eq "title") {
	    $grace->title_options->title($value);
	}

	if ($key eq "subtitle") {
	    $grace->subtitle_options->title($value);
	}

	if ($key eq "type of graph") {
	    unless(_is_available_option($key, $value,
					\%def_xmgrace_available_options)) {
		carp "Not a valid Xmgrace graph type";
		$handle->close();
		_cleanup_tmpdir();
		return 0;
	    }
	    if ($value =~ "graph") {
		$grace->graph_global_options->type("XY");
	    } elsif ($value =~ "chart") {
		$grace->graph_global_options->type("Chart");
	    }
	}

	if ($key eq "stacked") {
	    if ($value eq "true" || $value eq "false") {
		$grace->graph_global_options->stacked("$value");
	    } else {		# anything else is considered "false"
		carp join ('',
			   "Warning: ambiguous setting for stacking",
			   "bar chart\nAssuming no stacking"
			  );
		$grace->graph_global_options->stacked("false");
	    }
	}

	if ($key eq "x-axis label") {
	    $grace->axes_options->xaxis->label_options->label($value);
	}

	if ($key eq "y-axis label") {
	    $grace->axes_options->yaxis->label_options->label($value);
	}

	if ($key eq "alt x-axis label") {
	    if (defined($value)) {
		$grace->axes_options->altxaxis->status("on");
		$grace->axes_options->altxaxis->label_options->label($value);
	    }
	    # else altxaxis  off
	}

	if ($key eq "alt y-axis label") {
	    if (defined($value)) {
		$grace->axes_options->altyaxis->status("on");
		$grace->axes_options->altyaxis->label_options->label($value);
	    }
	    # else altyaxis  off
	}


	if ($key eq "xrange") {
	    if (defined($value)) {
		if (ref($value) ne "ARRAY") {
		    carp "xrange values must be an ARRAY\n";
		    $handle->close();
		    _cleanup_tmpdir();
		    return 0;
		}
		$grace->world_options->xmin($value->[0]);
		$grace->world_options->xmax($value->[1]);
		$autoscale = "x";
	    }
	}

	if ($key eq "yrange") {
	    if (defined($value)) {
		if (ref($value) ne "ARRAY") {
		    carp "yrange values must be an ARRAY\n";
		    $handle->close();
		    _cleanup_tmpdir();
		    return 0;
		}
		$grace->world_options->ymin($value->[0]);
		$grace->world_options->ymax($value->[1]);
		$autoscale = "y";
	    }
	}

	if ($key eq "xtics") {
	    if (defined($value)) {
		$grace->axes_options->xaxis->tick_options->type("spec");
		$grace->axes_options->xaxis->ticklabel_options->type("spec");
		$grace->axes_options->xaxis->ticklabel_options->ticklabels($value);
	    }
	}


	if ($key eq "ytics") {
	    if (defined($value)) {
		$grace->axes_options->yaxis->tick_options->type("spec");
		$grace->axes_options->yaxis->ticklabel_options->type("spec");
		$grace->axes_options->yaxis->ticklabel_options->ticklabels($value);
	    }
	}

	if ($key eq "alt xtics") {
	    if (defined($value)) {
		$grace->axes_options->altxaxis->tick_options->type("spec");
		$grace->axes_options->altxaxis->ticklabel_options->type("spec");
		$grace->axes_options->altxaxis->ticklabel_options->ticklabels($value);
	    }
	}


	if ($key eq "alt ytics") {
	    if (defined($value)) {
		$grace->axes_options->altyaxis->tick_options->type("spec");
		$grace->axes_options->altyaxis->ticklabel_options->type("spec");
		$grace->axes_options->altyaxis->ticklabel_options->ticklabels($value);
	    }
	}

	if ($key eq "logscale x") {
	    if (defined($value)) {
		$grace->axes_options->xaxes->scale("Logarithmic");
	    }
	}

	if ($key eq "logscale y") {
	    if (defined($value)) {
		$grace->axes_options->yaxes->scale("Logarithmic");
	    }
	}

	if ($key eq "output type") {
	    $output_type = uc($value);
	    if (not _check_output_type($output_type)) {
		$output_type = $def_xmgrace_global_opts{"output type"};
	    }
	    #print "output type = $value\n";
	    $grace->output_type($output_type);
	}

	if ($key eq "output file") {
	    #print "output file = $value\n";
	    $grace->output_file($value);
	}

	if ($key eq "grace output file") {
	    if (defined($value)) {
		$grace->grace_output_file(_make_gracefile("$value"));
		#print "grace output file = $value\n";
	    }
	}

	if ($key eq "extra opts") {
	    if (defined($value)) {
		$grace->extra_options->extras($value);
	    }
	}
    }

    # process data sets
    my @cum_data_set_objects;
    my $dataset_count = 0;

    while (@data_sets) {
	$data_set_ref = shift @data_sets;

	if (ref($data_set_ref) ne "ARRAY") {
	    carp "Data set must be an array";
	    $handle->close();
	    _cleanup_tmpdir();
	    return 0;
	}

	# create a new Dataset object with each new datase
	my $data_set_object = new Chart::Graph::Xmgrace::Dataset;
	my ($user_data_opts_ref, @data) = @{$data_set_ref};

	# set values in the dataset object
	$data_set_object->set_number($dataset_count);
	$data_set_object->data(\@data);

	# process data
	$data_set_object->data_format($user_data_opts_ref->{"data format"});
	my $formatted_data = _xmgrace_data_set($data_set_object);

	if (not $formatted_data) {
	    # error message already printed
	    $handle->close();
	    _cleanup_tmpdir();
	    return 0;
	}

	# stick formatted data back in the dataset object
	$data_set_object->data($formatted_data);

	# set set_type
	my $tog = $global_opts{"type of graph"}; # type of graph
	if ($tog =~ "XY") {
	    $data_set_object->set_type("XY");
	} elsif ($tog =~ m/BAR/i) {
	    $data_set_object->set_type("BAR");
	} else {
	    carp "Untrapped graph type - Xmgrace.pm internal error";
	}

	# need to create a new Presentation Type object for each dataset
	my $gpt = new Chart::Graph::Xmgrace::Graph_Presentation_Type($dataset_count);
	my $graph_appearance = $gpt->{$global_opts{"type of graph"}};
	$def_xmgrace_data_opts{options} = $graph_appearance;

	# mesh data options
	my $data_options_ref = _mesh_xmgrace_opts($user_data_opts_ref,
						  \%def_xmgrace_data_opts);

	if (not $data_options_ref) {
	    # error message already printed
	    $handle->close();
	    _cleanup_tmpdir();
	    return 0;
	}

	# change the "title" into "comment" and "legend"
	_set_title($data_options_ref);

	# set data options in the dataset object
	$data_set_object->options($data_options_ref);

	# create new set presention for each data set
	my $sp = $user_data_opts_ref->{"set presentation"};
	if ($sp) {
	    if ($sp eq "XY") {
		_set_XY($data_set_object);
	    } elsif ($sp =~ m/BAR/i) {
		_set_BAR($data_set_object);
	    } else {
		carp "Untrapped graph type - Xmgrace.pm internal error";
	    }
	}

	# process data
	# accumulate data objects into an array.
        push @cum_data_set_objects, $data_set_object;
	$dataset_count++;
    }

    # print commandfile
    if ($stdout) {
	$handle = \*STDOUT;
    }
    $grace->print($handle);

    # we're done crunching on the data now print something!
    # print data options


     foreach my $set_object (@cum_data_set_objects) {
#       XXX This code breaks under Perl 5.6 - not sure why XXX
# 	$set_object->{options}->{options}->print($handle,"s" .
# 						 "$set_object->{set_number}");
     }

    # print data sets
    foreach my $set_object (@cum_data_set_objects) {
	_printline($handle, "target G0.S$set_object->{\"set_number\"}\n");
	_printline($handle, "type $set_object->{\"set_type\"}\n");
	if (not _print_data_set($handle, $set_object)) {
	    # already printed error message
	    return 0;
	}
    }

    # commandfile successfully completed
    $handle->close unless ($stdout);

    # if user chooses to, can save the .agr file
    if (defined $grace->{grace_output_file}) {
	_copy_commandfile($command_file, $grace->{grace_output_file});
    }

    # run xmgrace with commandline args to create the specified graph type
    # $xmgrace needs to be defined in the user's script

    _exec_xmgrace($command_file, $grace, $autoscale); # could probably put the autoscale flag inside the grace object


}				# end of xmgrace()


############################################################
#
# The following functions are internal functions used by this package. The
# user won't know about these functions.
#
############################################################

#
#
# Subroutine _is_available_option($$$)
#
# Description: Modest helper subroutine to loop through available
#              options for more complex Xmgrace options and return
#              true if a match is found.
#
#
sub _is_available_option($$$) {
    my $key = shift;
    my $to_match = shift;
    my $avail_options_ref = shift;

    if (exists($avail_options_ref->{$key})) {
	foreach my $option (@{$avail_options_ref->{$key}}) {
	    if ($to_match =~ m/$option/i) {
		return($option);
	    }
	}
    }
    return(undef);
}



sub _exec_xmgrace ($$$) {
    my ($command_file, $grace, $autoscale) = @_;
    my ($childpid, $port);
    my $display_env = $ENV{DISPLAY};
    my $status;
    my $framebuffer;

    #if ($Chart::Graph::use_xvfb) {
	# start the virtual X server
	#($childpid, $port) = _exec_xvfb();
#	$status = system("$xmgrace -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);
 #   }


    if ($autoscale eq "") {
	_run_app("$xmgrace", "-hardcopy -hdevice $grace->{output_type}",
		 "-printfile $grace->{output_file} $command_file -pexec autoscale") unless $stdout;
	if ($Chart::Graph::debug) {
	    print STDERR "$xmgrace -hardcopy -hdevice $grace->{output_type} -printfile $grace->{output_file} $command_file -pexec autoscale\n";
	    print STDERR "done.\n";
	    ### fill in tmp files...
	}
	1;
    } elsif ($autoscale eq "x") {
	_run_app("$xmgrace", "-autoscale y", "-hardcopy -hdevice $grace->{output_type}",
		 "-printfile $grace->{output_file} $command_file -pexec autoscale") unless $stdout;
	print STDERR "xscale\n";
    } elsif ($autoscale eq "y") {
	_run_app("$xmgrace", "-autoscale x", "-hardcopy -hdevice $grace->{output_type}",
		 "-printfile $grace->{output_file} $command_file -autoscale") unless $stdout;
	print STDERR "yscale\n";
    } else {
	_run_app("$xmgrace", "-autoscale xy", "-hardcopy -hdevice $grace->{output_type}",
		 "-printfile $grace->{output_file} $command_file -autoscale") unless $stdout;
    	print STDERR "both\n";
    }
}


#
# Subroutine: set_xmgrace_paths()
#
# Description: set paths for external programs required by gnuplot()
#              if they are not defined already
#

sub _set_xmgrace_paths {

    if (not defined($xmgrace)) {
	if (not $xmgrace = _get_path("xmgrace")) {
	    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");	# defined in Xrtutils.pm

    return 1;
}


#
# Subroutine: _xmgrace_data_set()
#
# Description: this function sets up the data sets into a columns format
#              and returns a formatted data reference
#
#

sub _xmgrace_data_set {
    my $data_set_object = shift;

    my $data_format = $data_set_object->{"data_format"};
    my @data = @{$data_set_object->data};
    my $formatted_data_ref;

    # we give the user 3 formats for supplying the data set
    # 1) matrix
    # 2) column
    # 3) file
    # please see the online docs for a description of these
    # formats

    if ($data_format eq "matrix") {
	$formatted_data_ref = _matrix_to_columns(@data);
    } elsif ($data_format eq "columns") {
	$formatted_data_ref = _columns_to_columns(@data);
    } elsif ($data_format eq "file") {
	$formatted_data_ref = _file_to_columns(@data); # single item list (filename)
    } elsif ($data_format eq "") {
	carp "Need to specify data set type";
	return 0;
    } else {
	carp "Illegal data format: $data_format";
        return 0;
    }
    return $formatted_data_ref;
}

#
#
# Subroutine: matrix_to_columns()
#
# Description: converts the matrix data input into a an array
#              of pairs of input. See www for the specific on
#              the matrix format
#
#

sub _matrix_to_columns (\@ ) {
    my ($matrix_ref) = @_;
    my $entry_ref;
    my $matrix_len;
    my @pairs = ();
    my $single_pair = "";
    my (@x_col, @y_col);

    if (ref($matrix_ref) ne "ARRAY") {
	carp "Matrix data must be a reference to an array";
	return 0;
    }

    $matrix_len = @{$matrix_ref};
    for (my $i = 0; $i < $matrix_len; $i++) {
	$entry_ref = $matrix_ref->[$i];

	if (ref($entry_ref) ne "ARRAY") {
	    carp "Matrix entry must be a reference to an array";
	    return 0;
	}

	# check that each entry ONLY has two entries
	if (@{$entry_ref} != 2) {
	    carp "Each entry must be an array of size 2";
	    return 0;
	}

	push @x_col, $entry_ref->[0];
	push @y_col, $entry_ref->[1];

	@pairs = (\@x_col, \@y_col);
    }

    return \@pairs;
}

#
#
# Subroutine: columns_to_columns()
#
# Description: converts the column data input into a the gnuplot
#              data file format. please see www page for specifics
#              on this format.
#

sub _columns_to_columns (\@ ) {
    my ($x_col, $y_col) = @{$_[0]};
    my ($x_len, $y_len);
    my @pairs = ();
    my $single_pair = "";

    if ((ref($x_col) ne "ARRAY") or (ref($y_col) ne "ARRAY")) {
	unless($x_col) {
	    carp "No data in X column";
	}
	unless($y_col) {
	    carp "No data in Y column";
	}
	carp "Column data must be a reference to an array";
	return 0;
    }

    $x_len = @{$x_col};
    $y_len = @{$y_col};

    if ($x_len != $y_len) {
	carp "x and y columns must be of same length";
	return 0;
    }

    if ($x_len == 0) {
	carp "Warning: x column has no data";
    }

    if ($y_len == 0) {
	carp "Warning: y column has no data";
    }

    @pairs = ($x_col, $y_col);
    return \@pairs;
}

#
# Subroutine: file_to_columns()
#
# Description: If a gnuplot data set was given in
#              file format, we simply copy the data
#              and read it into
#

sub _file_to_columns (\@ ) {
    my ($file_in) = @_;
    my $single_pair = "";
    my @pairs = ();
    my (@x_col, @y_col);
    my ($x_len, $y_len);

    if (not $file_in) {
	carp "File data format selected but data set file missing";
	return 0;
    }

    if (not -f $file_in) {
	carp "Data set file, '$file_in', does not exist.";
	return 0;
    }

    my $fh = new FileHandle;

    if (not $fh->open("<$file_in")) {
	carp "Could not open file: '$file_in'";
	cleanup_tmpdir();
	return 0;
    }

    while (<$fh>) {
	chomp;
	my @data = split /\s+/;
	push @x_col, $data[0];
	push @y_col, $data[1];
    }

    $x_len = @x_col;
    $y_len = @y_col;

    if ($x_len != $y_len) {
	carp "x and y columns must be of same length";
	return 0;
    }

    if ($x_len == 0) {
	carp "Warning: x column has no data";
    }

    if ($y_len == 0) {
	carp "Warning: y column has no data";
    }

    @pairs = (\@x_col, \@y_col);
    $fh->close;
    return \@pairs;
}

#
# Subroutine: _printline()
#
# Description: prints out an Xmgrace formatted line
#
#

sub _printline ($$$ ) {
    my ($handle, $string, $length) = @_;

    unless ($length) {$length = 1;}
    print $handle "@";
    print $handle ' ' x $length;
    print $handle "$string";

    return 1;                   # just for fun

}

#
# Subroutine: _copy_commandfile()
#
# Description: copies the temp commandfile into a grace
#              output file (.agr)
#

sub _copy_commandfile ($$ ) {

    my ($commandfile, $grace_output_file) = @_;
    my $status = system("cp", "$commandfile", "$grace_output_file");
    if (not _chk_status($status)) {
	return 0;
    }
}

#
# Subroutine: _make_gracefile()
#
# Description: constructs the gracefile.agr name
#

sub _make_gracefile ($ ) {

    my $file = shift;
    my $ext = ".agr";

    if ($file !~ m|\.agr$|) {
	return "$file$ext";
    } else {
	return "$file";
    }
}

#
# Subroutine: _check_output_type()
#
# Description: checks user output type to known output types.
#

sub _check_output_type ($ ) {

    my $user_type = shift;
    my @types = ("PNG", "PS", "JPEG", "PNM");
    my $seen = 0;

    foreach my $known_type (@types) {
	if ($user_type =~ m|$known_type|i)  {
	    $seen = 1;
	}
	if ($seen) {
	    return 1;
	}
    }
    carp "Unknown output type: \'$user_type\'\nUsing default output type: \'PNG\'";
    return 0;
}


#
# Subroutine: _run_app()
#
# Description: to simplify calls to external applications
#

sub _run_app($@ ) {
  my $application = shift;
  my @arguments = @_;
  my $command_str;

        # Run application
        # Test if an executable file exists as specified location
        if (-x "$application") {
          # Try to run application.  Quit if that fails.
          $command_str = join(' ', $application, @arguments);
          my $rc = 0xffff & system ($command_str);
          if ($rc != 0) {
	      die "Execution error: $application";
	  }
        } else {
          die "No such application: $application";
        }
}

#
# Subroutine: _mesh_xmgrace_opts
#
# Description: meshes the user's data_options with the default
#              data options these "options" include: title, set
#              presentation, options, and data format
#

sub _mesh_xmgrace_opts {
    my ($user_opts_ref, $default_opts_ref) = @_;

    my %user_opts = %{$user_opts_ref};
    my %default_opts = %{$default_opts_ref};
    my %opts;

    # check user opts against defaults and mesh
    # the basic algorithm here is to override the
    # the default options against the ones that
    # the user has passed in.
    while (my ($key, $value) = each %default_opts) {

	if ($key eq "options") {
	    my $opts_obj = $def_xmgrace_data_opts{options};
	    my $def_options = $opts_obj->{options};

	    if (defined($user_opts{options})) {
		# if user provides options for the datasets we mesh them
		my $data_options_obj = _mesh_option_opts($user_opts_ref->{options},
							 $def_options);
		$opts_obj->{options} = $data_options_obj;
		$opts{options} = $opts_obj;
		delete $user_opts{$key}; # remove options
	    } else {
		$opts_obj->{options} = $def_options;
		$opts{options} = $opts_obj;
	    }
	} else {
	    if (defined($user_opts{$key})) {
		$opts{$key} = $user_opts{$key};
		delete $user_opts{$key}; # remove options
		# that are matching
	    } else {
		$opts{$key} = $default_opts{$key};
	    }
	}
    }

    # any left over options in the table are unknown
    # if the user passes in illegal options then we
    # warn them with an error message but still
    # proceed.
    while (my ($key, $value) = each %user_opts) {
	carp "unknown option: $key";
    }

    return \%opts;
}

#
# Name: _mesh_option_opts
#
# Description: if the user introduces a "option" in their dataset
#              hash, we use this function to mesh those options
#              with the default options of a particular dataset.
#              note: default options depend on the type of
#              graph
#

sub _mesh_option_opts {
    my ($user_opts_ref, $default_opts_ref) = @_;
    my %user_opts = %{$user_opts_ref};
    my %def_options = %{$default_opts_ref};

    # check user opts against defaults and mesh
    # the basic algorithm here is to override the
    # the default options against the ones that
    # the user has passed in.
    while (my ($key, $value) = each %def_options) {
	if (defined($user_opts{$key})) {

	    if (!ref($value)) {	# scalar
		$def_options{$key} = $user_opts{$key};
		delete $user_opts{$key}; # remove options
	    }

	    else {		# blessed object
		my $return_obj;
		my $class = ref($def_options{$key});
		$return_obj = _mesh_option_opts($user_opts_ref->{$key},
						$def_options{$key}->{options});
		bless($return_obj, $class);
		$def_options{$key}->{options} = $return_obj;
		delete $user_opts{$key};
	    }
	}
    }

    # any left over options in the table are unknown
    # if the user passes in illegal options then we
    # warn them with an error message but still
    # proceed.
    while (my ($key, $value) = each %user_opts) {
	carp "unknown option: $key";
    }

    my $ret_obj = \%def_options;
    return $ret_obj;
}

#
# Name: _print_data_set
#
# Description: used to print out the data in the dataset in a
#              formatted manner
#

sub _print_data_set ($\@ ) {
    my ($handle, $set_object) = @_;
    my ($x_col, $y_col);
    my $length;
    my $i;
    my $delimeter = "\t\t"; # set to 15 spaces, nice one xmgrace!
    my $pairs = $set_object->data;

    ($x_col, $y_col) = ($pairs->[0], $pairs->[1]);
    $length = $#{$x_col};

    #
    # data set format
    # @target G.S
    # @type $type_of_graph
    #                x1                y1
    #                 .                 .
    #                 .                 .
    #                xn                yn
    # &
    #

    # we don't print out the hidden data set
    # XXX Protection against trying to access nonexistentant
    # XXX accessor function or OVERLOADED function?
    if (exists($set_object->{options}->{options}->{hidden})) {
	# This statement now breaks in 5.6 - unblessed reference.
	if ($set_object->{options}->{options}->hidden eq "true") {
	    return 1;
	}
    }

    for ($i = 0; $i <= $length; $i++) {
        print $handle "$delimeter", "$x_col->[$i]", "$delimeter",
                      "$y_col->[$i]\n";
    }

    # each data set is separated by a "&"
    print $handle "&\n";
    return 1;
}


#
# Name: _set_BAR
#
# Description: sets up the necessary characteristics of a BAR
#              dataset type
#

sub _set_BAR ($ ) {
    my $ds_object = shift;
    my $data_options_ref = $ds_object->{options};
    $ds_object->set_type("BAR");
    $data_options_ref->{options}->type("BAR");
    $data_options_ref->{options}->symbol->fill_pattern("1");
    $data_options_ref->{options}->symbol->color("1");
    $data_options_ref->{options}->line->type("0");
    return 1;
}

#
# Name: _set_XY
#
# Description: sets up the necessary characteristics of an XY
#              dataset type
#

sub _set_XY ($ ) {
    my $ds_object = shift;
    my $data_options_ref = $ds_object->{options};
    $ds_object->set_type("XY");
    $data_options_ref->{options}->type("XY");
    $data_options_ref->{options}->symbol->fill_pattern("0");
    $data_options_ref->{options}->line->type("1");
    return 1;
}

# Name: _set_title
#
# Description: sets up the necessary characteristics for the
#              title of the graph
#

sub _set_title ($ ) {
    my $ds_ref = shift;
    my $title = $ds_ref->{title};
    $ds_ref->{options}->{options}->{comment} = $title;
    $ds_ref->{options}->{options}->{legend} = $title;
    return 1;
}

####################################################################
#
# The following functions are used to map an option value from
# prose to it's corresponding number value which grace understands
# Note: these routines are not used in the current version. the user
#       must use numbers (NOT prose) for now.
#
###################################################################


#
# Subroutine: _get_color()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the color
#

sub _get_color ($ ) {
    my $color = shift;
    my %colortable = (
		      "white" => "0",
		      "black" => "1",
		      "red" => "2",
		      "green" => "3",
		      "blue" => "4",
		      "yellow" => "5",
		      "brown" => "6",
		      "grey" => "7",
		      "violet" => "8",
		      "cyan" => "9",
		      "magenta" => "10",
		      "orange" => "11",
		      "indigo" => "12",
		      "maroon" => "13",
		      "turquoise" => "14",
		      "green4" => "15",
		      );

    $color = lc($color);
    # "\L$color\E"
    #color =~ y/A-Z/a-z/;
    my $retval = $colortable{$color};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}

#
# Subroutine: _get_symbol()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the symbol
#

sub _get_symbol ($ ) {
    my $symbol = shift;
    my %symtab = (
		  "none" => "0",
		  "circle" => "1",
		  "square" => "2",
		  "diamond" => "3",
		  "triangle up" => "4",
		  "triangle left" => "5",
		  "triangle down" => "6",
		  "triangle right" => "7",
		  "plus" => "8",
		  "x" => "9",
		  "star" => "10",
		  "char" => "11",
		 );

    $symbol = lc($symbol);
    my $retval = $symtab{$symbol};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}


#
# Subroutine: _get_linetype()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the linetype
#

sub _get_linetype ($ ) {
    my $linetype = shift;
    my %linetypetab = (
		  "none" => "0",
		  "straight" => "1",
		  "left stairs" => "2",
		  "right stairs" => "3",
		  "segments" => "4",
		  "3-segments" => "5",
		 );

    $linetype = lc($linetype);
    my $retval = $linetypetab{$linetype};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}

#
# Subroutine: _get_linestyle()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the linestyle
#

sub _get_linestyle ($ ) {
    my $linestyle = shift;
    my %linestyletab = (
		  "none" => "0",
		  "solid" => "1",
		  "dotted" => "2",
		  "en dash" => "3",
		  "em dash" => "4",
		  "dot-en dash" => "5",
		  "dot-em dash" => "6",
		  "dot-en-dot dash" => "7",
		  "en-dot-en dash" => "8",
		 );

    $linestyle = lc($linestyle);
    my $retval = $linestyletab{$linestyle};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}

#
# Subroutine: _get_baselinetype()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the baselinetype
#

sub _get_baselinetype ($ ) {
    my $baselinetype = shift;
    my %baselinetypetab = (
		  "zero" => "0",
		  "set min" => "1",
		  "set max" => "2",
		  "graph min" => "3",
		  "graph max" => "4",
		 );

    $baselinetype = lc($baselinetype);
    my $retval = $baselinetypetab{$baselinetype};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}


#
# Subroutine: _get_filltype()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the filltype
#

sub _get_filltype ($ ) {
    my $filltype = shift;
    my %filltypetab = (
		  "none" => "0",
		  "as polygon" => "1",
		  "to baseline" => "2",
		 );

    $filltype = lc($filltype);
    my $retval = $filltypetab{$filltype};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}

#
# Subroutine: _get_avaluetype()
#
# Description: simply looks up a hash table and returns
#              a number that xmgrace understands that
#              corresponds to the avaluetype
#

sub _get_avaluetype ($ ) {
    my $avaluetype = shift;
    my %avaluetypetab = (
		  "none" => "0",
		  "x" => "1",
		  "y" => "2",
		  "xy" => "3",
		  "string" => "4",
		  "z" => "5",
	 );

    $avaluetype = lc($avaluetype);
    my $retval = $avaluetypetab{$avaluetype};

    if ($retval) {
	return $retval;
    } else {
	return 0;
    }
}


1;

__END__