ext/POSIX/t/is.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require Config; import Config;
   7     if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {
   8         print "1..0\n";
   9         exit 0;
  10     }
  11 }
  12
  13 use POSIX;
  14 use strict ;
  15
  16 # E.g. \t might or might not be isprint() depending on the locale,
  17 # so let's reset to the default.
  18 setlocale(LC_ALL, 'C') if $Config{d_setlocale};
  19
  20 $| = 1;
  21
  22 # List of characters (and strings) to feed to the is<xxx> functions.
  23 #
  24 # The left-hand side (key) is a character or string.
  25 # The right-hand side (value) is a list of character classes to which
  26 # this string belongs.  This is a *complete* list: any classes not
  27 # listed, are expected to return '0' for the given string.
  28 my %classes =
  29   (
  30    'a'    => [ qw(print graph alnum alpha lower xdigit) ],
  31    'A'    => [ qw(print graph alnum alpha upper xdigit) ],
  32    'z'    => [ qw(print graph alnum alpha lower) ],
  33    'Z'    => [ qw(print graph alnum alpha upper) ],
  34    '0'    => [ qw(print graph alnum digit xdigit) ],
  35    '9'    => [ qw(print graph alnum digit xdigit) ],
  36    '.'    => [ qw(print graph punct) ],
  37    '?'    => [ qw(print graph punct) ],
  38    ' '    => [ qw(print space) ],
  39    "\t"   => [ qw(cntrl space) ],
  40    "\001" => [ qw(cntrl) ],
  41
  42    # Multi-character strings.  These are logically ANDed, so the
  43    # presence of different types of chars in one string will
  44    # reduce the list on the right.
  45    'abc'       => [ qw(print graph alnum alpha lower xdigit) ],
  46    'az'        => [ qw(print graph alnum alpha lower) ],
  47    'aZ'        => [ qw(print graph alnum alpha) ],
  48    'abc '      => [ qw(print) ],
  49
  50    '012aF'     => [ qw(print graph alnum xdigit) ],
  51
  52    " \t"       => [ qw(space) ],
  53
  54    "abcde\001" => [],
  55
  56    # An empty string. Always true (al least in old days) [bug #24554]
  57    ''     => [ qw(print graph alnum alpha lower upper digit xdigit
  58                   punct cntrl space) ],
  59   );
  60
  61
  62 # Pass 1: convert the above arrays to hashes.  While doing so, obtain
  63 # a complete list of all the 'is<xxx>' functions.  At least, the ones
  64 # listed above.
  65 my %functions;
  66 foreach my $s (keys %classes) {
  67     $classes{$s} = { map {
  68         $functions{"is$_"}++;   # Keep track of all the 'is<xxx>' functions
  69         "is$_" => 1;            # Our return value: is<xxx>($s) should pass.
  70     } @{$classes{$s}} };
  71 }
  72
  73 # Expected number of tests is one each for every combination of a
  74 # known is<xxx> function and string listed above.
  75 require './test.pl';
  76 plan(tests => keys(%classes) * keys(%functions));
  77
  78
  79 #
  80 # Main test loop: Run all POSIX::is<xxx> tests on each string defined above.
  81 # Only the character classes listed for that string should return 1.  We
  82 # always run all functions on every string, and expect to get 0 for the
  83 # character classes not listed in the given string's hash value.
  84 #
  85 foreach my $s (sort keys %classes) {
  86     foreach my $f (sort keys %functions) {
  87         my $expected = exists $classes{$s}->{$f};
  88         my $actual   = eval "POSIX::$f( \$s )";
  89
  90         ok( $actual == $expected, "$f('$s') == $actual");
  91     }
  92 }