t/comp/uproto.t

   1 #!perl
   2
   3 print "1..32\n";
   4 my $test = 0;
   5
   6 sub failed {
   7     my ($got, $expected, $name) = @_;
   8
   9     print "not ok $test - $name\n";
  10     my @caller = caller(1);
  11     print "# Failed test at $caller[1] line $caller[2]\n";
  12     if (defined $got) {
  13         print "# Got '$got'\n";
  14     } else {
  15         print "# Got undef\n";
  16     }
  17     print "# Expected $expected\n";
  18     return;
  19 }
  20
  21 sub like {
  22     my ($got, $pattern, $name) = @_;
  23     $test = $test + 1;
  24     if (defined $got && $got =~ $pattern) {
  25         print "ok $test - $name\n";
  26         # Principle of least surprise - maintain the expected interface, even
  27         # though we aren't using it here (yet).
  28         return 1;
  29     }
  30     failed($got, $pattern, $name);
  31 }
  32
  33 sub is {
  34     my ($got, $expect, $name) = @_;
  35     $test = $test + 1;
  36     if (defined $expect) {
  37         if (defined $got && $got eq $expect) {
  38             print "ok $test - $name\n";
  39             return 1;
  40         }
  41         failed($got, "'$expect'", $name);
  42     } else {
  43         if (!defined $got) {
  44             print "ok $test - $name\n";
  45             return 1;
  46         }
  47         failed($got, 'undef', $name);
  48     }
  49 }
  50
  51 sub f($$_) { my $x = shift; is("@_", $x) }
  52
  53 $foo = "FOO";
  54 my $bar = "BAR";
  55 $_ = 42;
  56
  57 f("FOO xy", $foo, "xy");
  58 f("BAR zt", $bar, "zt");
  59 f("FOO 42", $foo);
  60 f("BAR 42", $bar);
  61 f("y 42", substr("xy",1,1));
  62 f("1 42", ("abcdef" =~ /abc/));
  63 f("not undef 42", $undef || "not undef");
  64 f(" 42", -f "no_such_file");
  65 f("FOOBAR 42", ($foo . $bar));
  66 f("FOOBAR 42", ($foo .= $bar));
  67 f("FOOBAR 42", $foo);
  68
  69 eval q{ f("foo") };
  70 like( $@, qr/Not enough arguments for main::f at/ );
  71 eval q{ f(1,2,3,4) };
  72 like( $@, qr/Too many arguments for main::f at/ );
  73
  74 &f(""); # no error
  75
  76 sub g(_) { is(shift, $expected) }
  77
  78 $expected = "foo";
  79 g("foo");
  80 g($expected);
  81 $_ = $expected;
  82 g();
  83 g;
  84 undef $expected; &g; # $_ not passed
  85
  86 eval q{ sub wrong1 (_$); wrong1(1,2) };
  87 like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
  88
  89 eval q{ sub wrong2 ($__); wrong2(1,2) };
  90 like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' );
  91
  92 sub opt ($;_) {
  93     is($_[0], "seen");
  94     is($_[1], undef, "; has precedence over _");
  95 }
  96
  97 opt("seen");
  98
  99 sub unop (_) { is($_[0], 11, "unary op") }
 100 unop 11, 22; # takes only the first parameter into account
 101
 102 sub mymkdir (_;$) { is("@_", $expected, "mymkdir") }
 103 $expected = $_ = "mydir"; mymkdir();
 104 mymkdir($expected = "foo");
 105 $expected = "foo 493"; mymkdir foo => 0755;
 106
 107 sub mylist (_@) { is("@_", $expected, "mylist") }
 108 $expected = "foo";
 109 $_ = "foo";
 110 mylist();
 111 $expected = "10 11 12 13";
 112 mylist(10, 11 .. 13);
 113
 114 sub mylist2 (_%) { is("@_", $expected, "mylist2") }
 115 $expected = "foo";
 116 $_ = "foo";
 117 mylist2();
 118 $expected = "10 a 1";
 119 my %hash = (a => 1);
 120 mylist2(10, %hash);
 121
 122 # $_ says modifiable, it's not passed by copy
 123
 124 sub double(_) { $_[0] *= 2 }
 125 $_ = 21;
 126 double();
 127 is( $_, 42, '$_ is modifiable' );