t/comp/uproto.t

   1 #!perl
   2
   3 print "1..43\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 {
  75     my $_ = "quarante-deux";
  76     $foo = "FOO";
  77     $bar = "BAR";
  78     f("FOO quarante-deux", $foo);
  79     f("BAR quarante-deux", $bar);
  80     f("y quarante-deux", substr("xy",1,1));
  81     f("1 quarante-deux", ("abcdef" =~ /abc/));
  82     f("not undef quarante-deux", $undef || "not undef");
  83     f(" quarante-deux", -f "no_such_file");
  84     f("FOOBAR quarante-deux", ($foo . $bar));
  85     f("FOOBAR quarante-deux", ($foo .= $bar));
  86     f("FOOBAR quarante-deux", $foo);
  87 }
  88
  89 &f(""); # no error
  90
  91 sub g(_) { is(shift, $expected) }
  92
  93 $expected = "foo";
  94 g("foo");
  95 g($expected);
  96 $_ = $expected;
  97 g();
  98 g;
  99 undef $expected; &g; # $_ not passed
 100 { $expected = my $_ = "bar"; g() }
 101
 102 eval q{ sub wrong1 (_$); wrong1(1,2) };
 103 like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
 104
 105 eval q{ sub wrong2 ($__); wrong2(1,2) };
 106 like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' );
 107
 108 sub opt ($;_) {
 109     is($_[0], "seen");
 110     is($_[1], undef, "; has precedence over _");
 111 }
 112
 113 opt("seen");
 114
 115 sub unop (_) { is($_[0], 11, "unary op") }
 116 unop 11, 22; # takes only the first parameter into account
 117
 118 sub mymkdir (_;$) { is("@_", $expected, "mymkdir") }
 119 $expected = $_ = "mydir"; mymkdir();
 120 mymkdir($expected = "foo");
 121 $expected = "foo 493"; mymkdir foo => 0755;
 122
 123 sub mylist (_@) { is("@_", $expected, "mylist") }
 124 $expected = "foo";
 125 $_ = "foo";
 126 mylist();
 127 $expected = "10 11 12 13";
 128 mylist(10, 11 .. 13);
 129
 130 sub mylist2 (_%) { is("@_", $expected, "mylist2") }
 131 $expected = "foo";
 132 $_ = "foo";
 133 mylist2();
 134 $expected = "10 a 1";
 135 my %hash = (a => 1);
 136 mylist2(10, %hash);
 137
 138 # $_ says modifiable, it's not passed by copy
 139
 140 sub double(_) { $_[0] *= 2 }
 141 $_ = 21;
 142 double();
 143 is( $_, 42, '$_ is modifiable' );
 144 {
 145     my $_ = 22;
 146     double();
 147     is( $_, 44, 'my $_ is modifiable' );
 148 }