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