From: Vincent Pit Date: Sun, 15 Nov 2015 20:04:38 +0000 (-0200) Subject: Represent valgrind version numbers by their own class X-Git-Tag: v1.18~5 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Valgrind.git;a=commitdiff_plain;h=5dd4ffc1370138eb1e9501f82a69f98208e4c0ff Represent valgrind version numbers by their own class Instead of relying on version.pm for that. --- diff --git a/MANIFEST b/MANIFEST index d1c5366..595f4de 100644 --- a/MANIFEST +++ b/MANIFEST @@ -28,6 +28,7 @@ lib/Test/Valgrind/Suppressions.pm 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 @@ -36,6 +37,7 @@ t/10-good.t 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 diff --git a/Makefile.PL b/Makefile.PL index cd4b762..35627d2 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -139,7 +139,7 @@ my %PREREQ_PM = ( 'Test::More' => 0, 'XML::Twig' => 0, 'base' => 0, - 'version' => 0, + 'overload' => 0, ); my %CONFIGURE_REQUIRES = ( diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm index 42b6ce6..c166f6e 100644 --- a/lib/Test/Valgrind.pm +++ b/lib/Test/Valgrind.pm @@ -436,7 +436,7 @@ What your tests output to C and C is eaten unless you pass the C =head1 DEPENDENCIES -L, L, L, L, L. +L, L, L, L. =head1 SEE ALSO diff --git a/lib/Test/Valgrind/Parser/XML.pm b/lib/Test/Valgrind/Parser/XML.pm index 41a0990..d69b8fb 100644 --- a/lib/Test/Valgrind/Parser/XML.pm +++ b/lib/Test/Valgrind/Parser/XML.pm @@ -37,7 +37,7 @@ sub args { 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(@_), diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index ca586ea..ba00ee2 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -29,10 +29,10 @@ use Fcntl (); # F_SETFD use IO::Select; use POSIX (); # SIGKILL, _exit() -use version (); - use base qw; +use Test::Valgrind::Version; + =head1 METHODS =head2 C @@ -120,19 +120,20 @@ sub 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; } @@ -164,18 +165,7 @@ The path to the selected C executable. my $valgrind_version = $tvs->version; -The L object associated to the selected C. - -=cut - -sub version { - my ($self) = @_; - - my $version = $self->{version}; - $self->{version} = $version = version->new($version) unless ref $version; - - return $version; -} +The L object associated to the selected C. =head2 C @@ -201,6 +191,7 @@ Read-only accessor for the C option. eval "sub $_ { \$_[0]->{$_} }" for qw< valgrind + version regen_def_supp no_def_supp allow_no_supp @@ -625,7 +616,7 @@ sub status { $_[0]->{last_status} } L, L, L, L, L. -L, L. +L. =head1 AUTHOR diff --git a/lib/Test/Valgrind/Suppressions.pm b/lib/Test/Valgrind/Suppressions.pm index 1226aab..84526fd 100644 --- a/lib/Test/Valgrind/Suppressions.pm +++ b/lib/Test/Valgrind/Suppressions.pm @@ -115,7 +115,7 @@ sub maybe_generalize { 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; } diff --git a/lib/Test/Valgrind/Tool/memcheck.pm b/lib/Test/Valgrind/Tool/memcheck.pm index 542ff9d..0857a3d 100644 --- a/lib/Test/Valgrind/Tool/memcheck.pm +++ b/lib/Test/Valgrind/Tool/memcheck.pm @@ -137,7 +137,7 @@ sub args { '--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(@_); diff --git a/lib/Test/Valgrind/Version.pm b/lib/Test/Valgrind/Version.pm new file mode 100644 index 0000000..749b1d6 --- /dev/null +++ b/lib/Test/Valgrind/Version.pm @@ -0,0 +1,169 @@ +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 versions. + +=cut + +use base 'Test::Valgrind::Carp'; + +use Scalar::Util (); + +my $instanceof = sub { + Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]); +}; + +=head1 METHODS + +=head2 C + + 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 object representing a C version from one of these two sources : + +=over 4 + +=item * + +if the C option is specified, then C will try to parse it as the output of C. + +=item * + +otherwise the C 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. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +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 diff --git a/t/60-version.t b/t/60-version.t new file mode 100644 index 0000000..4b6b2a9 --- /dev/null +++ b/t/60-version.t @@ -0,0 +1,162 @@ +#!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"; +}