File Coverage

blib/lib/Gnuplot/Builder/Script.pm

Criterion	Covered	Total	%
statement	228	238	95.8
branch	70	86	81.4
condition	12	18	66.6
subroutine	53	54	98.1
pod	26	27	96.3
total	389	423	91.9

package Gnuplot::Builder::Script;
use strict;
use warnings;
use Gnuplot::Builder::PrototypedData;
use Gnuplot::Builder::Util qw(quote_gnuplot_str);
use Gnuplot::Builder::Process;
use Scalar::Util qw(weaken blessed refaddr);
use Carp;
use overload '""' => "to_string";

sub new {
    my ($class, @set_args) = @_;
    my $self = bless {
        pdata => undef,
        parent => undef,
    };
    $self->_init_pdata();
    if(@set_args) {
        $self->set(@set_args);
    }
    return $self;
}

sub _init_pdata {
    my ($self) = @_;
    weaken $self;
    $self->{pdata} = Gnuplot::Builder::PrototypedData->new(
        entry_evaluator => sub {
            my ($key, $value_code) = @_;
            if(defined($key)) {
                return $value_code->($self, substr($key, 1));
            }else {
                return $value_code->($self);
            }
        }
    );
}

sub add {
    my ($self, @sentences) = @_;
    foreach my $sentence (@sentences) {
        $self->{pdata}->add_entry($sentence);
    }
    return $self;
}

sub _set_entry {
    my ($self, $prefix, $quote, @pairs) = @_;
    $self->{pdata}->set_entry(
        entries => \@pairs,
        key_prefix => $prefix,
        quote => $quote,
    );
    return $self;
}

sub set {
    my ($self, @pairs) = @_;
    return $self->_set_entry("o", 0, @pairs);
}

*set_option = *set;

sub setq {
    my ($self, @pairs) = @_;
    return $self->_set_entry("o", 1, @pairs);
}

*setq_option = *setq;

sub unset {
    my ($self, @names) = @_;
    return $self->set(map { $_ => undef } @names);
}

sub _get_entry {
    my ($self, $prefix, $name) = @_;
    croak "name cannot be undef" if not defined $name;
    return $self->{pdata}->get_resolved_entry("$prefix$name");
}

sub get_option {
    my ($self, $name) = @_;
    return $self->_get_entry("o", $name);
}

sub _delete_entry {
    my ($self, $prefix, @names) = @_;
    foreach my $name (@names) {
        croak "name cannot be undef" if not defined $name;
        $self->{pdata}->delete_entry("$prefix$name");
    }
    return $self;
}

sub delete_option {
    my ($self, @names) = @_;
    return $self->_delete_entry("o", @names);
}

sub _create_statement {
    my ($raw_key, $value) = @_;
    return $value if !defined $raw_key;
    my ($prefix, $name) = (substr($raw_key, 0, 1), substr($raw_key, 1));
    my @words = ();
    if($prefix eq "o") {
        @words = defined($value) ? ("set", $name, $value) : ("unset", $name);
    }elsif($prefix eq "d") {
        @words = defined($value) ? ($name, "=", $value) : ("undefine", $name);
    }else {
        confess "Unknown key prefix: $prefix";
    }
    return join(" ", grep { "$_" ne "" } @words);
}

sub to_string {
    my ($self) = @_;
    my $result = "";
    $self->{pdata}->each_resolved_entry(sub {
        my ($raw_key, $values) = @_;
        foreach my $value (@$values) {
            my $statement = _create_statement($raw_key, $value);
            $result .= $statement;
            $result .= "\n" if $statement !~ /\n$/;
        }
    });
    return $result;
}

sub define {
    my ($self, @pairs) = @_;
    return $self->_set_entry("d", 0, @pairs);
}

*set_definition = *define;

sub undefine {
    my ($self, @names) = @_;
    return $self->define(map { $_ => undef } @names);
}

sub get_definition {
    my ($self, $name) = @_;
    return $self->_get_entry("d", $name);
}

sub delete_definition {
    my ($self, @names) = @_;
    return $self->_delete_entry("d", @names);
}

sub set_parent {
    my ($self, $parent) = @_;
    if(!defined($parent)) {
        $self->{parent} = undef;
        $self->{pdata}->set_parent(undef);
        return $self;
    }
    if(!blessed($parent) || !$parent->isa("Gnuplot::Builder::Script")) {
        croak "parent must be a Gnuplot::Builder::Script"
    }
    $self->{parent} = $parent;
    $self->{pdata}->set_parent($parent->{pdata});
    return $self;
}

sub get_parent { return $_[0]->{parent} }

*parent = *get_parent;

sub new_child {
    my ($self) = @_;
    return Gnuplot::Builder::Script->new->set_parent($self);
}

sub _collect_dataset_params {
    my ($dataset_arrayref) = @_;
    my @params_str = ();
    my @dataset_objects = ();
    foreach my $dataset (@$dataset_arrayref) {
        my $ref = ref($dataset);
        if(!$ref) {
            push(@params_str, $dataset);
        }else {
            if(!$dataset->can("params_string") || !$dataset->can("write_data_to")) {
                croak "You cannot use $ref object as a dataset.";
            }
            my ($param_str) = $dataset->params_string();
            push(@params_str, $param_str);
            push(@dataset_objects, $dataset);
        }
    }
    return (\@params_str, \@dataset_objects);
}

sub _wrap_writer_to_detect_empty_data {
    my ($writer) = @_;
    my $ended_with_newline = 0;
    my $data_written = 0;
    my $wrapped_writer = sub {
        my @nonempty_data = grep { defined($_) && $_ ne "" } @_;
        return if !@nonempty_data;
        $data_written = 1;
        $ended_with_newline = ($nonempty_data[-1] =~ /\n$/);
        $writer->(join("", @nonempty_data));
    };
    return ($wrapped_writer, \$data_written, \$ended_with_newline);
}

sub _write_inline_data {
    my ($writer, $dataset_objects_arrayref) = @_;
    my ($wrapped_writer, $data_written_ref, $ended_with_newline_ref) =
        _wrap_writer_to_detect_empty_data($writer);
    foreach my $dataset (@$dataset_objects_arrayref) {
        $$data_written_ref = $$ended_with_newline_ref = 0;
        $dataset->write_data_to($wrapped_writer);
        next if !$$data_written_ref;
        $writer->("\n") if !$$ended_with_newline_ref;
        $writer->("e\n");
    }
}

sub _wrap_commands_with_output {
    my ($commands_ref, $output_filename) = @_;
    if(defined($output_filename)) {
        unshift @$commands_ref, "set output " . quote_gnuplot_str($output_filename);
        push @$commands_ref, "set output";
    }
}

sub _draw_with {
    my ($self, %args) = @_;
    my $plot_command = $args{command};
    my $dataset = $args{dataset};
    croak "dataset parameter is mandatory" if not defined $dataset;
    if(ref($dataset) ne "ARRAY") {
        $dataset = [$dataset];
    }
    croak "at least one dataset is required" if !@$dataset;

    my $plotter = sub {
        my $writer = shift;
        my ($params, $dataset_objects) = _collect_dataset_params($dataset);
        $writer->("$plot_command " . join(",", @$params) . "\n");
        _write_inline_data($writer, $dataset_objects);
    };
    my @commands = ($plotter);
    return $self->run_with(
        do => \@commands,
        _pair_slice(\%args, qw(writer async output no_stderr on_exit))
    );
}

sub _pair_slice {
    my ($hash_ref, @keys) = @_;
    return map { exists($hash_ref->{$_}) ? ($_ => $hash_ref->{$_}) : () } @keys;
}

sub plot_with {
    my ($self, %args) = @_;
    return $self->_draw_with(%args, command => "plot");
}

sub splot_with {
    my ($self, %args) = @_;
    return $self->_draw_with(%args, command => "splot");
}

sub plot {
    my ($self, @dataset) = @_;
    return $self->_draw_with(command => "plot", dataset => \@dataset);
}

sub splot {
    my ($self, @dataset) = @_;
    return $self->_draw_with(command => "splot", dataset => \@dataset);
}

sub multiplot_with {
    my ($self, %args) = @_;
    my $do = $args{do};
    croak "do parameter is mandatory" if not defined $do;
    croak "do parameter must be a code-ref" if ref($do) ne "CODE";
    my $wrapped_do = sub {
        my $writer = shift;
        my ($wrapped_writer, $data_written_ref, $ended_with_newline_ref) =
            _wrap_writer_to_detect_empty_data($writer);
        $do->($wrapped_writer);
        if($$data_written_ref && !$$ended_with_newline_ref) {
            $writer->("\n");
        }
    };
    my $multiplot_command =
        (defined($args{option}) && $args{option} ne "")
            ? "set multiplot $args{option}" : "set multiplot";
    my @commands = ($multiplot_command, $wrapped_do, "unset multiplot");
    return $self->run_with(
        do => \@commands,
        _pair_slice(\%args, qw(writer async output no_stderr on_exit))
    );
}

sub multiplot {
    my ($self, $option, $code) = @_;
    if(@_ == 2) {
        $code = $option;
        $option = "";
    }
    croak "code parameter is mandatory" if not defined $code;
    croak "code parameter must be a code-ref" if ref($code) ne "CODE";
    return $self->multiplot_with(do => $code, option => $option);
}

our $_context_writer = undef;

sub run_with {
    my ($self, %args) = @_;
    my $commands = $args{do};
    if(!defined($commands)) {
        $commands = [];
    }elsif(ref($commands) ne "ARRAY") {
        $commands = [$commands];
    }
    my $on_exit = $args{on_exit};
    if(defined($on_exit) && ref($on_exit) ne "CODE") {
        croak "on_exit must be a CODE-REF";
    }
    _wrap_commands_with_output($commands, $self->_plotting_option(\%args, "output"));
    my $do = sub {
        my $writer = shift;
        (!defined($_context_writer) || refaddr($_context_writer) != refaddr($writer))
            and local $_context_writer = $writer;

        $writer->($self->to_string);
        foreach my $command (@$commands) {
            if(ref($command) eq "CODE") {
                $command->($writer);
            }else {
                $command = "$command";
                $writer->($command);
                $writer->("\n") if $command !~ /\n$/;
            }
        }
    };

    my $result = "";
    my $got_writer = $self->_plotting_option(\%args, "writer");
    if(defined($got_writer)) {
        if(defined($on_exit)) {
            croak "on_exit should not be set if writer is set";
        }
        $do->($got_writer);
    }elsif(defined($_context_writer)) {
        if(defined($on_exit)) {
            croak "on_exit should not be set if there is a writer in the context"
        }
        $do->($_context_writer);
    }else {
        $result = Gnuplot::Builder::Process->with_new_process(
            async => $self->_plotting_option(\%args, "async"),
            do => $do,
            no_stderr => $self->_plotting_option(\%args, "no_stderr"),
            on_exit => $on_exit,
        );
    }
    return $result;
}

sub _plotting_option {
    my ($self, $given_args_ref, $key) = @_;
    return (exists $given_args_ref->{$key})
        ? $given_args_ref->{$key}
        : $self->get_plot($key);
}

sub run {
    my ($self, @commands) = @_;
    return $self->run_with(do => \@commands);
}

my %KNOWN_PLOTTING_OPTIONS = map { ($_ => 1) } qw(output no_stderr writer async);

sub _check_plotting_option {
    my ($arg_name) = @_;
    croak "Unknown plotting option: $arg_name" if !$KNOWN_PLOTTING_OPTIONS{$arg_name};
}

sub set_plot {
    my ($self, %opts) = @_;
    foreach my $key (keys %opts) {
        _check_plotting_option($key);
        $self->{pdata}->set_attribute(
            key => $key,
            value => $opts{$key}
        );
    }
    return $self;
}

sub get_plot {
    my ($self, $arg_name) = @_;
    _check_plotting_option($arg_name);
    croak "arg_name cannot be undef" if not defined $arg_name;
    return $self->{pdata}->get_resolved_attribute($arg_name);
}

sub delete_plot {
    my ($self, @arg_names) = @_;
    foreach my $arg_name (@arg_names) {
        _check_plotting_option($arg_name);
        $self->{pdata}->delete_attribute($arg_name)
    }
    return $self;
}

sub Lens {
    my ($self, $key) = @_;
    require Gnuplot::Builder::Lens;
    return Gnuplot::Builder::Lens->new(
        "get_option", "set_option", $key
    );
}

1;

__END__