t/op/do.t

   1 #!./perl
   2
   3 # $RCSfile: do.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:45 $
   4
   5 sub foo1
   6 {
   7     ok($_[0]);
   8     'value';
   9 }
  10
  11 sub foo2
  12 {
  13     shift;
  14     ok($_[0]);
  15     $x = 'value';
  16     $x;
  17 }
  18
  19 my $test = 1;
  20 sub ok {
  21     my($ok, $name) = @_;
  22
  23     # You have to do it this way or VMS will get confused.
  24     printf "%s %d%s\n", $ok ? "ok" : "not ok",
  25                         $test,
  26                         defined $name ? " - $name" : '';
  27
  28     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  29
  30     $test++;
  31     return $ok;
  32 }
  33
  34 print "1..20\n";
  35
  36 # Test do &sub and proper @_ handling.
  37 $_[0] = 0;
  38 $result = do foo1(1);
  39
  40 ok( $result eq 'value',  ":$result: eq :value:" );
  41 ok( $_[0] == 0 );
  42
  43 $_[0] = 0;
  44 $result = do foo2(0,1,0);
  45 ok( $result eq 'value', ":$result: eq :value:" );
  46 ok( $_[0] == 0 );
  47
  48 $result = do{ ok 1; 'value';};
  49 ok( $result eq 'value',  ":$result: eq :value:" );
  50
  51 sub blather {
  52     ok 1 foreach @_;
  53 }
  54
  55 do blather("ayep","sho nuff");
  56 @x = ("jeepers", "okydoke");
  57 @y = ("uhhuh", "yeppers");
  58 do blather(@x,"noofie",@y);
  59
  60 unshift @INC, '.';
  61
  62 if (open(DO, ">$$.16")) {
  63     print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n";
  64     close DO or die "Could not close: $!";
  65 }
  66
  67 my $a = do "$$.16";
  68
  69 if (open(DO, ">$$.17")) {
  70     print DO "ok(1, 'do in list context') if defined wantarray &&     wantarray\n";
  71     close DO or die "Could not close: $!";
  72 }
  73
  74 my @a = do "$$.17";
  75
  76 if (open(DO, ">$$.18")) {
  77     print DO "ok(1, 'do in void context') if not defined wantarray\n";
  78     close DO or die "Could not close: $!";
  79 }
  80
  81 do "$$.18";
  82
  83 # bug ID 20010920.007
  84 eval qq{ do qq(a file that does not exist); };
  85 ok( !$@, "do on a non-existing file, first try" );
  86
  87 eval qq{ do uc qq(a file that does not exist); };
  88 ok( !$@, "do on a non-existing file, second try"  );
  89
  90 END {
  91     1 while unlink("$$.16", "$$.17", "$$.18");
  92 }