package RRDTool::Rawish;
use strict;
use warnings;
use 5.008;
use Carp ();
use Capture::Tiny qw(capture);
use File::Which ();
our $VERSION = '0.02';
sub new {
my ($class, @args) = @_;
my %args = @args == 1 && ref $args[0] eq 'HASH' ? %{$args[0]} : @args;
my $rrdtool_path = $args{rrdtool_path} || File::Which::which('rrdtool')
or Carp::croak 'Not found rrdtool command';
if (not -x $rrdtool_path) {
Carp::croak "Cannot execute $rrdtool_path";
}
return bless {
command => $rrdtool_path,
remote => $args{remote},
rrdfile => $args{rrdfile},
rrderror => "",
}, $class;
}
sub errstr { $_[0]->{rrderror} }
sub create {
my ($self, $params, $opts) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
Carp::croak 'Not ARRAY reference: params' if ref($params) ne 'ARRAY';
Carp::croak 'Not HASH reference: opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my $exit_status = $self->_system($self->{command}, 'create', $self->{rrdfile}, _opt_array($opts), @$params);
return $exit_status;
}
sub update {
my ($self, $params, $opts) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
Carp::croak 'Not ARRAY reference: params' if ref($params) ne 'ARRAY';
Carp::croak 'Not HASH reference: opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my $exit_status = $self->_system($self->{command}, 'update', $self->{rrdfile}, _opt_array($opts), @$params);
return $exit_status;
}
sub graph {
my ($self, $params, $opts) = @_;
Carp::croak 'Not ARRAY reference: $params' if ref($params) ne 'ARRAY';
Carp::croak 'Not HASH reference: $opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my ($img, $exit_status) = $self->_readpipe($self->{command}, 'graph', _opt_array($opts), @$params);
return $img;
}
sub dump {
my ($self, $opts) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
Carp::croak 'Not HASH reference: $opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my ($xml, $exit_status) = $self->_readpipe($self->{command}, 'dump', $self->{rrdfile}, _opt_array($opts));
return $xml;
}
sub restore {
my ($self, $xmlfile, $opts) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
Carp::croak 'Require xmlfile' if not defined $xmlfile;
Carp::croak 'Not HASH reference: opts' if defined $opts && ref($opts) ne 'HASH';
my $ret = $self->_system($self->{command}, 'restore', $xmlfile, $self->{rrdfile}, _opt_array($opts));
return $ret;
}
sub lastupdate {
my ($self) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
my $opts = {};
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my ($text, $exit_status) = $self->_readpipe($self->{command}, 'lastupdate', $self->{rrdfile}, _opt_array($opts));
return $text if (!$text and $exit_status != 0);
my $lines = [ split "\n", $text ];
my ($timestamp, $tmp) = split ':', $lines->[2];
return $timestamp;
}
sub fetch {
my ($self, $CF, $opts) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
Carp::croak 'Require CF' if not defined $CF;
Carp::croak 'Not HASH reference: opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my ($text, $exit_status) = $self->_readpipe($self->{command}, 'fetch', $self->{rrdfile}, $CF, _opt_array($opts));
return $text if (!$text and $exit_status != 0);
my $lines = [ split "\n", $text ];
return $lines;
}
sub xport {
my ($self, $params, $opts) = @_;
Carp::croak 'Not ARRAY reference: params' if ref($params) ne 'ARRAY';
Carp::croak 'Not HASH reference: opts' if defined $opts && ref($opts) ne 'HASH';
$opts->{'--daemon'} = $self->{remote} if $self->{remote};
my ($xml, $exit_status) = $self->_readpipe($self->{command}, 'xport', _opt_array($opts), @$params);
return $xml;
}
sub info {
my ($self) = @_;
Carp::croak 'Require rrdfile' if not defined $self->{rrdfile};
my $opts_str = $self->{remote} ? "--daemon" : "";
my ($text, $exit_status) = $self->_readpipe($self->{command}, 'info', $self->{rrdfile}, $opts_str);
return $text if (!$text and $exit_status != 0);
my $value = {};
my $lines = [ split "\n", $text ];
for (@$lines) {
my ($k, $v) = split ' = ', $_;
$v =~ s/"(.+)"/$1/g;
if ($k =~ /^rra\[(\d+)]\.(.+)\[(\d+)\]\.(.+)$/) { # rra[0].cdp_prep[0].value = NaN
$value->{rra}->[$1]->{$2}->[$3]->{$4} = $v;
}
elsif ($k =~ /^rra\[(\d+)\]\.(.+)$/) { # rra[0].cf = "LAST"
$value->{rra}->[$1]->{$2} = $v;
}
elsif ($k =~ /^ds\[(.+)\]\.(.+)$/) { # ds[rx].type = "DERIVE"
$value->{ds}->{$1}->{$2} = $v;
}
else {
$value->{$k} = $v;
}
}
return $value;
}
sub _system {
my ($self, @expr) = @_;
my ($stdout, $stderr, $exit_status) = capture {
system(_sanitize(join(" ", @expr)));
};
chomp $stderr;
$self->{rrderror} = $stderr if $exit_status != 0;
return $exit_status;
}
sub _readpipe {
my ($self, @expr) = @_;
my ($stdout, $stderr, $exit_status) = capture {
system(_sanitize(join(" ", @expr)));
};
chomp $stderr;
$self->{rrderror} = $stderr if $exit_status != 0;
return ($stdout, $exit_status);
}
sub _sanitize {
my $command = shift;
$command =~ s/[^a-z0-9#_@\s\-\.\,\:\/=\+\-\*\%]//gi;
return $command;
}
sub _opt_array {
my ($opts) = @_;
return map {
($opts->{$_} eq 1) ? $_ : ($_, $opts->{$_})
} sort(keys %$opts);
}
1;
__END__
1;
__END__
=head1 NAME
RRDTool::Rawish - A RRDtool wrapper with rawish interface
=head1 SYNOPSIS
use RRDTool::Rawish;
my $rrd = RRDTool::Rawish->new(
rrdfile => 'rrdtest.rrd', # option
remote => 'rrdtest.com:11111', # option for rrdcached
);
my $exit_status = $rrd->create(["DS:rx:DERIVE:40:0:U", "DS:tx:DERIVE:40:0:U", "RRA:LAST:0.5:1:240"], {
'--start' => '1350294000',
'--step' => '20',
'--no-overwrite' => '1',
});
my $exit_status = $rrd->update([
"1350294020:0:0",
"1350294040:50:100",
"1350294060:80:150",
"1350294080:100:200",
"1350294100:180:300",
"1350294120:220:380",
"1350294140:270:400"
]);
my $img = $rrd->graph([
"DEF:rx=rrdtest2.rrd:rx:LAST",
"DEF:tx=rrdtest2.rrd:tx:LAST",
"LINE1:rx:rx#00F000",
"LINE1:tx#0000F0",
]);
# error message
$rrd->errstr; # => "ERROR: hogehoge"
=head1 DESCRIPTION
RRDTool::Rawish is a RRDtool wrapper class with rawish interface.
You can use the class like RRDtool command interface.
And RRDTool::Rawish has less dependencies and it is easy to install it.
=head1 METHODS
=over 4
=item my $rrd = RRDTool::Rawish->new([%args|\%args])
Creates a new instance of RRDTool::Rawish.
=item $rrd->create($params, [\%opts])
Returns exit status
rrdtool create
=item $rrd->update($params, [\%opts])
Returns exit status
rrdtool update
=item $rrd->graph($params, [\%opts])
Returns exit status
rrdtool graph
Returns image binary.
=item $rrd->dump([\%opts])
rrdtool dump
Returns xml data.
=item $rrd->restore($xmlfile, [\%opts])
rrdtool restore
Returns exit status
=item $rrd->lastupdate
rrdtool lastupdate
Returns timestamp
=item $rrd->fetch
rrdtool fetch
Returns output lines as an ARRAY refarence
=item $rrd->xport
rrdtool xport
Returns xml data
=item $rrd->info
rrdtool info
Returns info as a HASH refarence
Examples:
is $value->{filename}, "rrd_test.rrd";
is $value->{rrd_version}, "0003";
is $value->{step}, 20;
is $value->{last_update}, 1350294000;
is $value->{header_size}, 904;
is $value->{ds}->{rx}->{index}, 0;
is $value->{ds}->{rx}->{minimal_heartbeat}, 40;
is $value->{ds}->{rx}->{min}, "0.0000000000e+00";
is $value->{ds}->{rx}->{max}, "NaN";
is $value->{ds}->{rx}->{last_ds}, "U";
is $value->{ds}->{rx}->{value}, "0.0000000000e+00";
is $value->{ds}->{rx}->{unknown_sec}, 0;
is $value->{ds}->{tx}->{index}, 1;
is $value->{ds}->{tx}->{type}, "DERIVE";
is $value->{ds}->{tx}->{minimal_heartbeat}, 40;
is $value->{ds}->{tx}->{min}, "0.0000000000e+00";
is $value->{ds}->{tx}->{max}, "NaN";
is $value->{ds}->{tx}->{last_ds}, "U";
is $value->{ds}->{tx}->{value}, "0.0000000000e+00";
is $value->{ds}->{tx}->{unknown_sec}, 0;
is $value->{rra}->[0]->{cf}, "LAST";
is $value->{rra}->[0]->{rows}, 240;
is $value->{rra}->[0]->{cur_row}, 95;
is $value->{rra}->[0]->{pdp_per_row}, 1;
is $value->{rra}->[0]->{xff}, "5.0000000000e-01";
is $value->{rra}->[0]->{cdp_prep}->[0]->{value}, "NaN";
is $value->{rra}->[0]->{cdp_prep}->[0]->{unknown_datapoints}, 0;
is $value->{rra}->[0]->{cdp_prep}->[1]->{value}, "NaN";
is $value->{rra}->[0]->{cdp_prep}->[1]->{unknown_datapoints}, 0;
=back
=head1 AUTHOR
Yuuki Tsubouchi C<< <yuuki@cpan.org> >>
=head1 THANKS TO
Shoichi Masuhara
=head1 SEE ALSO
L<RRDtool Documetation|http://oss.oetiker.ch/rrdtool/>
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2013, Yuuki Tsubouchi C<< <yuuki@cpan.org> >>. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
=cut