Instead of relying on version.pm for that.
lib/Test/Valgrind/Tool.pm
lib/Test/Valgrind/Tool/memcheck.pm
lib/Test/Valgrind/Util.pm
+lib/Test/Valgrind/Version.pm
samples/map.pl
samples/xml-output-protocol4.txt
samples/xml-output.txt
t/12-good-run-exception.t
t/20-bad.t
t/30-skip.t
+t/60-version.t
t/70-session.t
t/71-session-command.t
t/80-suppressions.t
'Test::More' => 0,
'XML::Twig' => 0,
'base' => 0,
- 'version' => 0,
+ 'overload' => 0,
);
my %CONFIGURE_REQUIRES = (
=head1 DEPENDENCIES
-L<XML::Twig>, L<
version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
+L<XML::Twig>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
=head1 SEE ALSO
my $self = shift;
my ($session, $fh) = @_;
- my $fd_opt = $session->version ge '3.5.0' ? '--xml-fd=' : '--log-fd=';
+ my $fd_opt = $session->version >= '3.5.0' ? '--xml-fd=' : '--log-fd=';
return (
$self->SUPER::args(@_),
use IO::Select;
use POSIX (); # SIGKILL, _exit()
-use version ();
-
use base qw<Test::Valgrind::Carp>;
+use Test::Valgrind::Version;
+
=head1 METHODS
=head2 C<new>
$class->_croak('Empty valgrind candidates list') unless @paths;
my $min_version = delete $args{min_version};
- defined and not ref and $_ = version->new($_) for $min_version;
+ if (defined $min_version) {
+ $min_version = Test::Valgrind::Version->new(string => $min_version);
+ }
my ($valgrind, $version);
for (@paths) {
next unless -x;
- my $ver = qx/$_ --version/;
- if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) {
- if ($min_version) {
- $version = version->new($1);
- next if $version < $min_version;
- } else {
- $version = $1;
- }
+ my $output = qx/$_ --version/;
+ $version = do {
+ local $@;
+ eval { Test::Valgrind::Version->new(command_output => $output) };
+ };
+ if (defined $version) {
+ next if defined $min_version and $version < $min_version;
$valgrind = $_;
last;
}
my $valgrind_version = $tvs->version;
-The L<version> object associated to the selected C<valgrind>.
-
-=cut
-
-sub version {
- my ($self) = @_;
-
- my $version = $self->{version};
- $self->{version} = $version = version->new($version) unless ref $version;
-
- return $version;
-}
+The L<Test::Valgrind::Version> object associated to the selected C<valgrind>.
=head2 C<regen_def_supp>
eval "sub $_ { \$_[0]->{$_} }" for qw<
valgrind
+ version
regen_def_supp
no_def_supp
allow_no_supp
L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Parser>.
-L<version>, L<File::HomeDir>.
+L<File::HomeDir>.
=head1 AUTHOR
1 while $supp =~ s/[^\r\n]*:\s*\*\s*$//;
# With valgrind 3.4.0, we can replace unknown series of frames by '...'
- if ($sess->version ge '3.4.0') {
+ if ($sess->version >= '3.4.0') {
$supp .= "...\n";
$supp =~ s/(?:^\s*(?:\.{3}|\*:\S*|obj:\*)\s*\n)+/...\n/mg;
}
'--error-limit=yes',
);
- push @args, '--track-origins=yes' if $sess->version ge '3.4.0'
+ push @args, '--track-origins=yes' if $sess->version >= '3.4.0'
and not $sess->do_suppressions;
push @args, $self->SUPER::args(@_);
--- /dev/null
+package Test::Valgrind::Version;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Version - Object class for valgrind versions.
+
+=head1 VERSION
+
+Version 1.17
+
+=cut
+
+our $VERSION = '1.17';
+
+=head1 DESCRIPTION
+
+This class is used to parse, store and compare C<valgrind> versions.
+
+=cut
+
+use base 'Test::Valgrind::Carp';
+
+use Scalar::Util ();
+
+my $instanceof = sub {
+ Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
+};
+
+=head1 METHODS
+
+=head2 C<new>
+
+ my $vg_version = Test::Valgrind::Version->new(
+ command_output => qx{valgrind --version},
+ );
+
+ my $vg_version = Test::Valgrind::Version->new(
+ string => '1.2.3',
+ );
+
+Creates a new L<Test::Valgrind::Version> object representing a C<valgrind> version from one of these two sources :
+
+=over 4
+
+=item *
+
+if the C<command_output> option is specified, then C<new> will try to parse it as the output of C<valgrind --version>.
+
+=item *
+
+otherwise the C<string> option must be passed, and its value will be parsed as a 'dotted-integer' version number.
+
+=back
+
+An exception is raised if the version number cannot be inferred from the supplied data.
+
+=cut
+
+sub new {
+ my ($class, %args) = @_;
+
+ my $output = $args{command_output};
+ my $string;
+ if (defined $output) {
+ ($string) = $output =~ /^valgrind-([0-9]+(?:\.[0-9]+)*)(?!\.)/;
+ } else {
+ $string = $args{string};
+ return $string if $string->$instanceof(__PACKAGE__);
+ if (defined $string and $string =~ /^([0-9]+(?:\.[0-9]+)*)(?!\.)/) {
+ $string = $1;
+ } else {
+ $string = undef;
+ }
+ }
+ $class->_croak('Invalid argument') unless defined $string;
+
+ my @digits = map int, split /\./, $string;
+ my $last = $#digits;
+ for my $i (reverse 0 .. $#digits) {
+ last if $digits[$i];
+ --$last;
+ }
+
+ bless {
+ _digits => [ @digits[0 .. $last] ],
+ _last => $last,
+ }, $class;
+}
+
+BEGIN {
+ local $@;
+ eval "sub $_ { \$_[0]->{$_} }" for qw<_digits _last>;
+ die $@ if $@;
+}
+
+=head1 OVERLOADING
+
+This class overloads numeric comparison operators (C<< <=> >>, C<< < >>, C<< <= >>, C< == >, C<< => >> and C<< > >>), as well as stringification.
+
+=cut
+
+sub _spaceship {
+ my ($left, $right, $swap) = @_;
+
+ unless ($right->$instanceof(__PACKAGE__)) {
+ $right = __PACKAGE__->new(string => $right);
+ }
+ ($right, $left) = ($left, $right) if $swap;
+
+ my $left_digits = $left->_digits;
+ my $right_digits = $right->_digits;
+
+ my $last_cmp = $left->_last <=> $right->_last;
+ my $last = ($last_cmp < 0) ? $left->_last : $right->_last;
+
+ for my $i (0 .. $last) {
+ my $cmp = $left_digits->[$i] <=> $right_digits->[$i];
+ return $cmp if $cmp;
+ }
+
+ return $last_cmp;
+}
+
+sub _stringify {
+ my $self = shift;
+ my @digits = @{ $self->_digits };
+ push @digits, 0 until @digits >= 3;
+ join '.', @digits;
+}
+
+use overload (
+ '<=>' => \&_spaceship,
+ '""' => \&_stringify,
+ fallback => 1,
+);
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Component
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2015 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of Test::Valgrind::Version
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 6 + 6 + 2 * 5 + 2 * 5 + 2 * 21 + 2 * 14;
+
+use Test::Valgrind::Version;
+
+sub TVV () { 'Test::Valgrind::Version' }
+
+sub sanitize {
+ my $str = shift;
+
+ $str = '(undef)' unless defined $str;
+ 1 while chomp $str;
+ $str =~ s/\n/\\n/g;
+
+ $str;
+}
+
+my @command_failures = (
+ undef,
+ 'valgrind',
+ '1.2.3',
+ 'valgrin-1.2.3',
+ 'VALGRIND-1.2.3',
+ "doo dah doo\nvalgrind-1.2.3",
+);
+
+for my $failure (@command_failures) {
+ my $desc = sanitize $failure;
+ local $@;
+ eval { TVV->new(command_output => $failure) };
+ like $@, qr/^Invalid argument/,
+ "\"$desc\" correctly failed to parse as command_output";
+}
+
+my @string_failures = (
+ undef,
+ 'valgrind',
+ 'valgrind-1.2.3',
+ '1.',
+ '1.2.',
+ '1.2.a',
+);
+
+for my $failure (@string_failures) {
+ my $desc = sanitize $failure;
+ local $@;
+ eval { TVV->new(string => $failure) };
+ like $@, qr/^Invalid argument/,
+ "\"$desc\" correctly failed to parse as string";
+}
+
+my @command_valid = (
+ 'valgrind-1' => '1.0.0',
+ 'valgrind-1.2' => '1.2.0',
+ 'valgrind-1.2.3' => '1.2.3',
+ 'valgrind-1.2.4-rc5' => '1.2.4',
+ 'valgrind-1.2.6a' => '1.2.6',
+);
+
+my @string_valid = map { my $s = $_; $s =~ s/^valgrind-//; $s }
+ @command_valid;
+
+while (@command_valid) {
+ my ($output, $exp) = splice @command_valid, 0, 2;
+ my $desc = sanitize $output;
+ local $@;
+ my $res = eval { TVV->new(command_output => $output)->_stringify };
+ is $@, '', "\"$desc\" is parseable as command_output";
+ is $res, $exp, "\"$desc\" parses correctly as command_output";
+}
+
+while (@string_valid) {
+ my ($str, $exp) = splice @string_valid, 0, 2;
+ my $desc = sanitize $str;
+ local $@;
+ my $res = eval { TVV->new(string => $str)->_stringify };
+ is $@, '', "\"$desc\" is parseable as string";
+ is $res, $exp, "\"$desc\" parses correctly as string";
+}
+
+sub tvv_s {
+ my ($string) = @_;
+ local $@;
+ eval { TVV->new(string => $string) };
+}
+
+my @compare = (
+ '1', '1', 0,
+ '1', '1.0', 0,
+ '1', '1.0.0', 0,
+ '1.1', '1', 1,
+ '1.1', '1.0', 1,
+ '1.1', '1.0.0', 1,
+ '1', '1.1', -1,
+ '1.0', '1.1', -1,
+ '1.0.0', '1.1', -1,
+ '1.1', '1.2', -1,
+ '1.1.0', '1.2', -1,
+ '1.1', '1.2.0', -1,
+ '1.1.0', '1.2.0', -1,
+ '1', '1', 0,
+ '1.0.1', '1', 1,
+ '1.0.1.0', '1', 1,
+ '1.0.0.1', '1', 1,
+ '1.0.0.1', '1.0.1', -1,
+ '1.0.0.2', '1.0.1', -1,
+ '3.4.0', '3.4.1', -1,
+ '3.5.2', '3.5.1', 1,
+);
+
+while (@compare) {
+ my ($left, $right, $exp) = splice @compare, 0, 3;
+
+ my $desc = sanitize($left) . ' <=> ' . sanitize($right);
+
+ $left = tvv_s($left);
+ $right = tvv_s($right);
+
+ my ($err, $res) = '';
+ if (defined $left and defined $right) {
+ local $@;
+ $res = eval { $left <=> $right };
+ $err = $@;
+ } elsif (defined $right) {
+ $res = -2;
+ } elsif (defined $left) {
+ $res = 2;
+ }
+
+ is $err, '', "\"$desc\" compared without croaking";
+ is $res, $exp, "\"$desc\" compared correctly";
+}
+
+my @stringify = (
+ '1', '1.0.0',
+ '1.0', '1.0.0',
+ '1.0.0', '1.0.0',
+ '1.0.0.0', '1.0.0',
+ '1.2', '1.2.0',
+ '1.2.0', '1.2.0',
+ '1.2.0.0', '1.2.0',
+ '1.2.3', '1.2.3',
+ '1.2.3.0', '1.2.3',
+ '1.2.3.4', '1.2.3.4',
+ '1.2.3.4.0', '1.2.3.4',
+ '1.0.3', '1.0.3',
+ '1.0.0.4', '1.0.0.4',
+ '1.2.0.4', '1.2.0.4',
+);
+
+while (@stringify) {
+ my ($str, $exp) = splice @stringify, 0, 2;
+ my $desc = sanitize($str);
+ local $@;
+ my $res = eval { my $v = TVV->new(string => $str); "$v" };
+ is $@, '', "\"$desc\" stringification did not croak";
+ is $res, $exp, "\"$desc\" stringified correctly";
+}
projects / perl / modules / Test-Valgrind.git / commitdiff