tests/test/test.pl - master - niceSOFT/coreutils

tests/test/test.pl
232 строки6 KB
Collin Funk
test: handle adjacent binary operators
26 июл 2026, 22:44
26 июл 2026, 22:44c2a2508
#!/usr/bin/perl

# Copyright (C) 2008-2026 Free Software Foundation, Inc.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

use strict;

my $limits = getlimits ();

my $prog = 'test';

# Turn off localization of executable's output.
@ENV{qw(LANGUAGE LANG LC_ALL)} = ('C') x 3;

sub digest_test ($)
{
  my ($t) = @_;
  my @args;
  my $ret = 0;
  my @list_of_hashref;
  foreach my $e (@$t)
    {
      !ref $e
        and push (@args, $e), next;
      ref $e eq 'HASH'
        or (warn "$0: $t->[0]: unexpected entry type\n"), next;

      exists $e->{EXIT}
        and $ret = $e->{EXIT}, next;

      push @list_of_hashref, $e;
    }
  shift @args; # discard test name
  my $flags = join ' ', @args;

  return ($flags, $ret, \@list_of_hashref);
}

sub add_inverse_op_tests($)
{
  my ($tests) = @_;
  my @new;

  my %inverse_op =
    (
     eq => 'ne',
     lt => 'ge',
     gt => 'le',
    );

  foreach my $t (@$tests)
    {
      push @new, $t;

      my $test_name = $t->[0];
      my ($flags, $ret, $LoH) = digest_test $t;

      # Generate corresponding tests of inverse ops.
      # E.g. generate tests of '-ge' from those of '-lt'.
      foreach my $op (qw(gt lt eq))
        {
          if ($test_name =~ /$op-/ && $flags =~ / -$op /)
            {
              my $inv = $inverse_op{$op};
              $test_name =~ s/$op/$inv/;
              $flags =~ s/-$op/-$inv/;
              $ret = 1 - $ret;
              push (@new, [$test_name, $flags, {EXIT=>$ret}, @$LoH]);
            }
        }
    }
  return @new;
}

sub add_pn_tests($)
{
  my ($tests) = @_;
  my @new;

  # Generate parenthesized and negated versions of each test.
  # There are a few exceptions.
  my %not_N   = map {$_ => 1} qw (1a);
  my %not_P   = map {$_ => 1} qw (1a
                                  streq-6 strne-6
                                  paren-1 paren-2 paren-3 paren-4 paren-5);
  foreach my $t (@$tests)
    {
      push @new, $t;

      my $test_name = $t->[0];
      my ($flags, $ret, $LoH) = digest_test $t;
      next if $ret == 2;

      push (@new, ["N-$test_name", "! $flags", {EXIT=>1-$ret}, @$LoH])
        unless $not_N{$test_name};
      push (@new, ["P-$test_name", "'(' $flags ')'", {EXIT=>$ret}, @$LoH])
        unless $not_P{$test_name};
      push (@new, ["NP-$test_name", "! '(' $flags ')'", {EXIT=>1-$ret}, @$LoH])
        unless $not_P{$test_name};
      push (@new, ["NNP-$test_name", "! ! '(' $flags ')'", {EXIT=>$ret, @$LoH}])
        unless $not_P{$test_name};
    }

  return @new;
}

my @Tests =
(
  ['1a', {EXIT=>1}],
  ['1b', qw(-z '')],
  ['1c', 'any-string'],
  ['1d', qw(-n any-string)],
  ['1e', "''", {EXIT=>1}],
  ['1f', '-'],
  ['1g', '--'],
  ['1h', '-0'],
  ['1i', '-f'],
  ['1j', '--help'],
  ['1k', '--version'],

  ['streq-1', qw(t = t)],
  ['streq-2', qw(t = f), {EXIT=>1}],
  ['streqeq-1', qw(t == t)],
  ['streqeq-2', qw(t == f), {EXIT=>1}],
  ['streq-3', qw(! = !)],
  ['streq-4', qw(= = =)],
  ['streq-5', "'(' = '('"],
  ['streq-6', "'(' = ')'", {EXIT=>1}],
  ['strne-1', qw(t != t), {EXIT=>1}],
  ['strne-2', qw(t != f)],
  ['strne-3', qw(! != !), {EXIT=>1}],
  ['strne-4', qw(= != =), {EXIT=>1}],
  ['strne-5', "'(' != '('", {EXIT=>1}],
  ['strne-6', "'(' != ')'"],

  ['and-1', qw(t -a t)],
  ['and-2', qw('' -a t), {EXIT=>1}],
  ['and-3', qw(t -a ''), {EXIT=>1}],
  ['and-4', qw('' -a ''), {EXIT=>1}],

  ['or-1', qw(t -o t)],
  ['or-2', qw('' -o t)],
  ['or-3', qw(t -o '')],
  ['or-4', qw('' -o ''), {EXIT=>1}],

  ['eq-1', qw(9 -eq 9)],
  ['eq-2', qw(0 -eq 0)],
  ['eq-3', qw(0 -eq 00)],
  ['eq-4', qw(8 -eq 9), {EXIT=>1}],
  ['eq-5', qw(1 -eq 0), {EXIT=>1}],
  ['eq-6', "$limits->{UINTMAX_OFLOW} -eq 0", {EXIT=>1}],
  ['eq-7', qw(0 -eq ' 0 ')],
  ['eq-8', qw(-l abc -eq 3)],
  ['eq-9', qw(-l abc -eq 2), {EXIT=>1}],

  ['gt-1', qw(5 -gt 5), {EXIT=>1}],
  ['gt-2', qw(5 -gt 4)],
  ['gt-3', qw(4 -gt 5), {EXIT=>1}],
  ['gt-4', qw(-1 -gt -2)],
  ['gt-5', "$limits->{UINTMAX_OFLOW} -gt $limits->{INTMAX_UFLOW}"],
  ['gt-6', qw(-l abc -gt 3), {EXIT=>1}],
  ['gt-7', qw(-l abc -gt 2)],
  ['gt-8', qw(2 -gt -l abc), {EXIT=>1}],

  ['lt-1', qw(5 -lt 5), {EXIT=>1}],
  ['lt-2', qw(5 -lt 4), {EXIT=>1}],
  ['lt-3', qw(4 -lt 5)],
  ['lt-4', qw(-1 -lt -2), {EXIT=>1}],
  ['lt-5', "$limits->{INTMAX_UFLOW} -lt $limits->{UINTMAX_OFLOW}"],
  ['lt-6', qw(-l abc -lt 3), {EXIT=>1}],
  ['lt-7', qw(-l abc -lt 2), {EXIT=>1}],
  ['lt-8', qw(2 -lt -l abc)],

  ['inv-1', qw(0x0 -eq 00), {EXIT=>2},
   {ERR=>"$prog: invalid integer '0x0'\n"}],

  ['t1', "-t"],
  ['t2', qw(-t 1), {EXIT=>1}],

  ['paren-1', "'(' '' ')'", {EXIT=>1}],
  ['paren-2', "'(' '(' ')'"],
  ['paren-3', "'(' ')' ')'"],
  ['paren-4', "'(' ! ')'"],
  ['paren-5', "'(' -a ')'"],

  ['less-collate-1', "'a' '<' 'b'"],
  ['less-collate-2', "'a' '<' 'a'", {EXIT=>1}],
  ['less-collate-3', "'b' '<' 'a'", {EXIT=>1}],

  ['greater-collate-1', "'b' '>' 'a'"],
  ['greater-collate-2', "'a' '>' 'a'", {EXIT=>1}],
  ['greater-collate-3', "'a' '>' 'b'", {EXIT=>1}],
);

# Test the behavior of multiple adjacent binary operators.
# These would not behave correctly in coreutils-9.11 and earlier.
my $i = 1;
my @operands = ('-a', '-o', "''");
for my $b ('-a', '-o')
  {
    for my $a (@operands)
      {
        for my $c (@operands)
          {
            push @Tests, ["multiple-binary-" . ++$i, "$a $b $c",
                          {EXIT=>0 + (($b eq '-o')
                                      ? ($a eq "''" && $c eq "''")
                                      : ($a eq "''" || $c eq "''"))}];
          }
      }
  }

@Tests = add_inverse_op_tests \@Tests;
@Tests = add_pn_tests \@Tests;

my $save_temps = $ENV{DEBUG};
my $verbose = $ENV{VERBOSE};

my $fail = run_tests ($prog, \$prog, \@Tests, $save_temps, $verbose);
exit $fail;