File Coverage

blib/lib/R/Writer.pm

Criterion	Covered	Total	%
statement	38	39	97.4
branch	2	2	100.0
condition			n/a
subroutine	12	13	92.3
pod			n/a
total	52	54	96.3

# $Id: /mirror/coderepos/lang/perl/R-Writer/trunk/lib/R/Writer.pm 43085 2008-03-01T12:28:42.888222Z daisuke  $

package R::Writer;
use strict;
use warnings;
use 5.008;
use base qw(Class::Accessor::Fast);
use R::Writer::Call;
use R::Writer::Encoder;
use R::Writer::Range;
use R::Writer::Var;

__PACKAGE__->mk_accessors($_) for qw(encoder statements);

our $VERSION = '0.00001';
use Sub::Exporter -setup => {
    exports => [ 'R' ]
};

sub R { return __PACKAGE__->new(@_) }

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new({
        encoder    => R::Writer::Encoder->new,
        @_,
        statements => [],
        delimiter  => undef,
    });
    return $self;
}

sub __push_statement { push @{ $_[0]->statements }, $_[1]; }

# Call is a statement to call functions
sub call
{
    my ($self, $function, @args) = @_;

    # If this is the end of the call chain, then push the
    # statement. Otherwise, return it
    my $end_of_call_chain = ! defined wantarray;
    my $call = R::Writer::Call->new(
        call => $function,
        args => [@args],
        end_of_call_chain => $end_of_call_chain,
    );

    if ($end_of_call_chain) {
        $self->__push_statement( $call );
    }
    return $call;
}

BEGIN
{
    foreach my $method qw(c expression) {
        eval sprintf(<<'        EOSUB', $method, $method);
            sub %s {
                my $self = shift;
                return R::Writer::Call->new(
                    call => '%s',
                    args => [ @_ ],
                );
            }
        EOSUB
        die if $@;
    }
}

sub var
{
    my ($self, $var, $value) = @_;

    my $obj = R::Writer::Var->new($var, $value, $self);
    $self->__push_statement($obj);
    return $obj;
}

sub range
{
    my ($self, $start, $end) = @_;
    my $obj = R::Writer::Range->new($start, $end);
    $obj;
}

# Turn myself into a string
sub as_string
{
    my $self = shift;
    my $ret = "";

    for my $s (@{$self->{statements}}) {
        my $delimiter = defined $s->{delimiter}  ? $s->{delimiter} : ";";
        if (my $c = $s->{code}) {
            $ret .= $c;
        }
        else {
            $ret .= $s->as_string($self);
        }
        $ret .= $delimiter unless $ret =~ /$delimiter\s*$/s;
        $ret .= "\n";
    }
    return $ret;
}

# Turn arbitrary objects to string
sub __obj_as_string
{
    my ($self, $obj) = @_;

    my $ref = ref($obj);

    if ($ref eq 'CODE') {
        return $self->__obj_as_string($obj->());
    }
    elsif ($ref =~ /^R::Writer/) {
        return $obj->as_string($self);
    }
    elsif ($ref eq "SCALAR") {
        return $$obj
    }
    elsif ($ref eq 'ARRAY') {
        my @ret = map {
            $self->__obj_as_string($_)
        } @$obj;

        return "[" . join(",", @ret) . "]";
    }
    elsif ($ref eq 'HASH') {
        my %ret;
        while (my ($k, $v) = each %$obj) {
            $ret{$k} = $self->__obj_as_string($v)
        }
        return "{" . join (",", map { $self->encoder->encode($_) . ":" . $ret{$_} } keys %ret) . "}";
    }
    else {
        return $self->encoder->encode($obj)
    }
}

sub save
{
    my ($self, $file) = @_;

    my $fh;
    my $close = 1;
    my $ref = ref $file;

    if ($ref && ( $ref eq 'GLOB' || eval { $file->can('print') } )) {
        $close = 0;
        $fh = $file;
    } else {
        open($fh, '>', $file) or die "Failed to open $file for writing: $!";
    }
    print $fh $self->as_string;
    close($fh) if $close;
}

sub reset { shift->statements([]) }

1;

__END__