home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / comp / proto.t < prev    next >
Text File  |  2000-03-05  |  10KB  |  469 lines
  1. #!./perl
  2. #
  3. # Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
  4. #
  5. # So far there are tests for the following prototypes.
  6. # none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@)
  7. #
  8. # It is impossible to test every prototype that can be specified, but
  9. # we should test as many as we can.
  10. #
  11.  
  12. BEGIN {
  13.     chdir 't' if -d 't';
  14.     unshift @INC, '../lib';
  15. }
  16.  
  17. use strict;
  18.  
  19. print "1..107\n";
  20.  
  21. my $i = 1;
  22.  
  23. sub testing (&$) {
  24.     my $p = prototype(shift);
  25.     my $c = shift;
  26.     my $what = defined $c ? '(' . $p . ')' : 'no prototype';   
  27.     print '#' x 25,"\n";
  28.     print '# Testing ',$what,"\n";
  29.     print '#' x 25,"\n";
  30.     print "not "
  31.     if((defined($p) && defined($c) && $p ne $c)
  32.        || (defined($p) != defined($c)));
  33.     printf "ok %d\n",$i++;
  34. }
  35.  
  36. @_ = qw(a b c d);
  37. my @array;
  38. my %hash;
  39.  
  40. ##
  41. ##
  42. ##
  43.  
  44. testing \&no_proto, undef;
  45.  
  46. sub no_proto {
  47.     print "# \@_ = (",join(",",@_),")\n";
  48.     scalar(@_)
  49. }
  50.  
  51. print "not " unless 0 == no_proto();
  52. printf "ok %d\n",$i++;
  53.  
  54. print "not " unless 1 == no_proto(5);
  55. printf "ok %d\n",$i++;
  56.  
  57. print "not " unless 4 == &no_proto;
  58. printf "ok %d\n",$i++;
  59.  
  60. print "not " unless 1 == no_proto +6;
  61. printf "ok %d\n",$i++;
  62.  
  63. print "not " unless 4 == no_proto(@_);
  64. printf "ok %d\n",$i++;
  65.  
  66. ##
  67. ##
  68. ##
  69.  
  70.  
  71. testing \&no_args, '';
  72.  
  73. sub no_args () {
  74.     print "# \@_ = (",join(",",@_),")\n";
  75.     scalar(@_)
  76. }
  77.  
  78. print "not " unless 0 == no_args();
  79. printf "ok %d\n",$i++;
  80.  
  81. print "not " unless 0 == no_args;
  82. printf "ok %d\n",$i++;
  83.  
  84. print "not " unless 5 == no_args +5;
  85. printf "ok %d\n",$i++;
  86.  
  87. print "not " unless 4 == &no_args;
  88. printf "ok %d\n",$i++;
  89.  
  90. print "not " unless 2 == &no_args(1,2);
  91. printf "ok %d\n",$i++;
  92.  
  93. eval "no_args(1)";
  94. print "not " unless $@;
  95. printf "ok %d\n",$i++;
  96.  
  97. ##
  98. ##
  99. ##
  100.  
  101. testing \&one_args, '$';
  102.  
  103. sub one_args ($) {
  104.     print "# \@_ = (",join(",",@_),")\n";
  105.     scalar(@_)
  106. }
  107.  
  108. print "not " unless 1 == one_args(1);
  109. printf "ok %d\n",$i++;
  110.  
  111. print "not " unless 1 == one_args +5;
  112. printf "ok %d\n",$i++;
  113.  
  114. print "not " unless 4 == &one_args;
  115. printf "ok %d\n",$i++;
  116.  
  117. print "not " unless 2 == &one_args(1,2);
  118. printf "ok %d\n",$i++;
  119.  
  120. eval "one_args(1,2)";
  121. print "not " unless $@;
  122. printf "ok %d\n",$i++;
  123.  
  124. eval "one_args()";
  125. print "not " unless $@;
  126. printf "ok %d\n",$i++;
  127.  
  128. sub one_a_args ($) {
  129.     print "# \@_ = (",join(",",@_),")\n";
  130.     print "not " unless @_ == 1 && $_[0] == 4;
  131.     printf "ok %d\n",$i++;
  132. }
  133.  
  134. one_a_args(@_);
  135.  
  136. ##
  137. ##
  138. ##
  139.  
  140. testing \&over_one_args, '$@';
  141.  
  142. sub over_one_args ($@) {
  143.     print "# \@_ = (",join(",",@_),")\n";
  144.     scalar(@_)
  145. }
  146.  
  147. print "not " unless 1 == over_one_args(1);
  148. printf "ok %d\n",$i++;
  149.  
  150. print "not " unless 2 == over_one_args(1,2);
  151. printf "ok %d\n",$i++;
  152.  
  153. print "not " unless 1 == over_one_args +5;
  154. printf "ok %d\n",$i++;
  155.  
  156. print "not " unless 4 == &over_one_args;
  157. printf "ok %d\n",$i++;
  158.  
  159. print "not " unless 2 == &over_one_args(1,2);
  160. printf "ok %d\n",$i++;
  161.  
  162. print "not " unless 5 == &over_one_args(1,@_);
  163. printf "ok %d\n",$i++;
  164.  
  165. eval "over_one_args()";
  166. print "not " unless $@;
  167. printf "ok %d\n",$i++;
  168.  
  169. sub over_one_a_args ($@) {
  170.     print "# \@_ = (",join(",",@_),")\n";
  171.     print "not " unless @_ >= 1 && $_[0] == 4;
  172.     printf "ok %d\n",$i++;
  173. }
  174.  
  175. over_one_a_args(@_);
  176. over_one_a_args(@_,1);
  177. over_one_a_args(@_,1,2);
  178. over_one_a_args(@_,@_);
  179.  
  180. ##
  181. ##
  182. ##
  183.  
  184. testing \&scalar_and_hash, '$%';
  185.  
  186. sub scalar_and_hash ($%) {
  187.     print "# \@_ = (",join(",",@_),")\n";
  188.     scalar(@_)
  189. }
  190.  
  191. print "not " unless 1 == scalar_and_hash(1);
  192. printf "ok %d\n",$i++;
  193.  
  194. print "not " unless 3 == scalar_and_hash(1,2,3);
  195. printf "ok %d\n",$i++;
  196.  
  197. print "not " unless 1 == scalar_and_hash +5;
  198. printf "ok %d\n",$i++;
  199.  
  200. print "not " unless 4 == &scalar_and_hash;
  201. printf "ok %d\n",$i++;
  202.  
  203. print "not " unless 2 == &scalar_and_hash(1,2);
  204. printf "ok %d\n",$i++;
  205.  
  206. print "not " unless 5 == &scalar_and_hash(1,@_);
  207. printf "ok %d\n",$i++;
  208.  
  209. eval "scalar_and_hash()";
  210. print "not " unless $@;
  211. printf "ok %d\n",$i++;
  212.  
  213. sub scalar_and_hash_a ($@) {
  214.     print "# \@_ = (",join(",",@_),")\n";
  215.     print "not " unless @_ >= 1 && $_[0] == 4;
  216.     printf "ok %d\n",$i++;
  217. }
  218.  
  219. scalar_and_hash_a(@_);
  220. scalar_and_hash_a(@_,1);
  221. scalar_and_hash_a(@_,1,2);
  222. scalar_and_hash_a(@_,@_);
  223.  
  224. ##
  225. ##
  226. ##
  227.  
  228. testing \&one_or_two, '$;$';
  229.  
  230. sub one_or_two ($;$) {
  231.     print "# \@_ = (",join(",",@_),")\n";
  232.     scalar(@_)
  233. }
  234.  
  235. print "not " unless 1 == one_or_two(1);
  236. printf "ok %d\n",$i++;
  237.  
  238. print "not " unless 2 == one_or_two(1,3);
  239. printf "ok %d\n",$i++;
  240.  
  241. print "not " unless 1 == one_or_two +5;
  242. printf "ok %d\n",$i++;
  243.  
  244. print "not " unless 4 == &one_or_two;
  245. printf "ok %d\n",$i++;
  246.  
  247. print "not " unless 3 == &one_or_two(1,2,3);
  248. printf "ok %d\n",$i++;
  249.  
  250. print "not " unless 5 == &one_or_two(1,@_);
  251. printf "ok %d\n",$i++;
  252.  
  253. eval "one_or_two()";
  254. print "not " unless $@;
  255. printf "ok %d\n",$i++;
  256.  
  257. eval "one_or_two(1,2,3)";
  258. print "not " unless $@;
  259. printf "ok %d\n",$i++;
  260.  
  261. sub one_or_two_a ($;$) {
  262.     print "# \@_ = (",join(",",@_),")\n";
  263.     print "not " unless @_ >= 1 && $_[0] == 4;
  264.     printf "ok %d\n",$i++;
  265. }
  266.  
  267. one_or_two_a(@_);
  268. one_or_two_a(@_,1);
  269. one_or_two_a(@_,@_);
  270.  
  271. ##
  272. ##
  273. ##
  274.  
  275. testing \&a_sub, '&';
  276.  
  277. sub a_sub (&) {
  278.     print "# \@_ = (",join(",",@_),")\n";
  279.     &{$_[0]};
  280. }
  281.  
  282. sub tmp_sub_1 { printf "ok %d\n",$i++ }
  283.  
  284. a_sub { printf "ok %d\n",$i++ };
  285. a_sub \&tmp_sub_1;
  286.  
  287. @array = ( \&tmp_sub_1 );
  288. eval 'a_sub @array';
  289. print "not " unless $@;
  290. printf "ok %d\n",$i++;
  291.  
  292. ##
  293. ##
  294. ##
  295.  
  296. testing \&sub_aref, '&\@';
  297.  
  298. sub sub_aref (&\@) {
  299.     print "# \@_ = (",join(",",@_),")\n";
  300.     my($sub,$array) = @_;
  301.     print "not " unless @_ == 2 && @{$array} == 4;
  302.     print map { &{$sub}($_) } @{$array}
  303. }
  304.  
  305. @array = (qw(O K)," ", $i++);
  306. sub_aref { lc shift } @array;
  307. print "\n";
  308.  
  309. ##
  310. ##
  311. ##
  312.  
  313. testing \&sub_array, '&@';
  314.  
  315. sub sub_array (&@) {
  316.     print "# \@_ = (",join(",",@_),")\n";
  317.     print "not " unless @_ == 5;
  318.     my $sub = shift;
  319.     print map { &{$sub}($_) } @_
  320. }
  321.  
  322. @array = (qw(O K)," ", $i++);
  323. sub_array { lc shift } @array;
  324. print "\n";
  325.  
  326. ##
  327. ##
  328. ##
  329.  
  330. testing \&a_hash, '%';
  331.  
  332. sub a_hash (%) {
  333.     print "# \@_ = (",join(",",@_),")\n";
  334.     scalar(@_);
  335. }
  336.  
  337. print "not " unless 1 == a_hash 'a';
  338. printf "ok %d\n",$i++;
  339.  
  340. print "not " unless 2 == a_hash 'a','b';
  341. printf "ok %d\n",$i++;
  342.  
  343. ##
  344. ##
  345. ##
  346.  
  347. testing \&a_hash_ref, '\%';
  348.  
  349. sub a_hash_ref (\%) {
  350.     print "# \@_ = (",join(",",@_),")\n";
  351.     print "not " unless ref($_[0]) && $_[0]->{'a'};
  352.     printf "ok %d\n",$i++;
  353.     $_[0]->{'b'} = 2;
  354. }
  355.  
  356. %hash = ( a => 1);
  357. a_hash_ref %hash;
  358. print "not " unless $hash{'b'} == 2;
  359. printf "ok %d\n",$i++;
  360.  
  361. ##
  362. ##
  363. ##
  364.  
  365. testing \&array_ref_plus, '\@@';
  366.  
  367. sub array_ref_plus (\@@) {
  368.     print "# \@_ = (",join(",",@_),")\n";
  369.     print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
  370.     printf "ok %d\n",$i++;
  371.     @{$_[0]} = (qw(ok)," ",$i++,"\n");
  372. }
  373.  
  374. @array = ('a');
  375. { my @more = ('x');
  376.   array_ref_plus @array, @more; }
  377. print "not " unless @array == 4;
  378. print @array;
  379.  
  380. my $p;
  381. print "not " if defined prototype('CORE::print');
  382. print "ok ", $i++, "\n";
  383.  
  384. print "not " if defined prototype('CORE::system');
  385. print "ok ", $i++, "\n";
  386.  
  387. print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@';
  388. print "ok ", $i++, "\n";
  389.  
  390. print "# CORE:Foo => ($p), \$@ => `$@'\nnot " 
  391.     if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/;
  392. print "ok ", $i++, "\n";
  393.  
  394. # correctly note too-short parameter lists that don't end with '$',
  395. #  a possible regression.
  396.  
  397. sub foo1 ($\@);
  398. eval q{ foo1 "s" };
  399. print "not " unless $@ =~ /^Not enough/;
  400. print "ok ", $i++, "\n";
  401.  
  402. sub foo2 ($\%);
  403. eval q{ foo2 "s" };
  404. print "not " unless $@ =~ /^Not enough/;
  405. print "ok ", $i++, "\n";
  406.  
  407. sub X::foo3;
  408. *X::foo3 = sub {'ok'};
  409. print "# $@not " unless eval {X->foo3} eq 'ok';
  410. print "ok ", $i++, "\n";
  411.  
  412. sub X::foo4 ($);
  413. *X::foo4 = sub ($) {'ok'};
  414. print "not " unless X->foo4 eq 'ok';
  415. print "ok ", $i++, "\n";
  416.  
  417. # test if the (*) prototype allows barewords, constants, scalar expressions,
  418. # globs and globrefs (just as CORE::open() does), all under stricture
  419. sub star (*&) { &{$_[1]} }
  420. sub star2 (**&) { &{$_[2]} }
  421. sub BAR { "quux" }
  422. sub Bar::BAZ { "quuz" }
  423. my $star = 'FOO';
  424. star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
  425. star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
  426. star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
  427. star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
  428. star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
  429. star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++;
  430. star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
  431. star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
  432. star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
  433. star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++;
  434. star2 FOO, BAR, sub { print "ok $i\n"
  435.             if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
  436. star2(Bar::BAZ, FOO, sub { print "ok $i\n"
  437.             if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++;
  438. star2 BAR(), FOO, sub { print "ok $i\n"
  439.             if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++;
  440. star2(FOO, BAR(), sub { print "ok $i\n"
  441.             if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++;
  442. star2 "FOO", "BAR", sub { print "ok $i\n"
  443.             if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++;
  444. star2("FOO", "BAR", sub { print "ok $i\n"
  445.             if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++;
  446. star2 $star, $star, sub { print "ok $i\n"
  447.             if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++;
  448. star2($star, $star, sub { print "ok $i\n"
  449.             if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++;
  450. star2 *FOO, *BAR, sub { print "ok $i\n"
  451.             if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++;
  452. star2(*FOO, *BAR, sub { print "ok $i\n"
  453.             if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++;
  454. star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
  455.             if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++;
  456. star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n"
  457.             if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++;
  458.  
  459. # test scalarref prototype
  460. sub sreftest (\$$) {
  461.     print "ok $_[1]\n" if ref $_[0];
  462. }
  463. {
  464.     no strict 'vars';
  465.     sreftest my $sref, $i++;
  466.     sreftest($helem{$i}, $i++);
  467.     sreftest $aelem[0], $i++;
  468. }
  469.