home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / tiehandle.t < prev    next >
Text File  |  1999-07-20  |  2KB  |  152 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6. }
  7.  
  8. my @expect;
  9. my $data = "";
  10. my @data = ();
  11. my $test = 1;
  12.  
  13. sub ok { print "not " unless shift; print "ok ",$test++,"\n"; }
  14.  
  15. package Implement;
  16.  
  17. BEGIN { *ok = \*main::ok }
  18.  
  19. sub compare {
  20.     return unless @expect;
  21.     return ok(0) unless(@_ == @expect);
  22.  
  23.     my $i;
  24.     for($i = 0 ; $i < @_ ; $i++) {
  25.     next if $_[$i] eq $expect[$i];
  26.     return ok(0);
  27.     }
  28.  
  29.     ok(1);
  30. }
  31.  
  32. sub TIEHANDLE {
  33.     compare(TIEHANDLE => @_);
  34.     my ($class,@val) = @_;
  35.     return bless \@val,$class;
  36. }
  37.  
  38. sub PRINT {
  39.     compare(PRINT => @_);
  40.     1;
  41. }
  42.  
  43. sub PRINTF {
  44.     compare(PRINTF => @_);
  45.     2;
  46. }
  47.  
  48. sub READLINE {
  49.     compare(READLINE => @_);
  50.     wantarray ? @data : shift @data;
  51. }
  52.  
  53. sub GETC {
  54.     compare(GETC => @_);
  55.     substr($data,0,1);
  56. }
  57.  
  58. sub READ {
  59.     compare(READ => @_);
  60.     substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
  61.     3;
  62. }
  63.  
  64. sub WRITE {
  65.     compare(WRITE => @_);
  66.     $data = substr($_[1],$_[3] || 0, $_[2]);
  67.     length($data);
  68. }
  69.  
  70. sub CLOSE {
  71.     compare(CLOSE => @_);
  72.     
  73.     5;
  74. }
  75.  
  76. package main;
  77.  
  78. use Symbol;
  79.  
  80. print "1..29\n";
  81.  
  82. my $fh = gensym;
  83.  
  84. @expect = (TIEHANDLE => 'Implement');
  85. my $ob = tie *$fh,'Implement';
  86. ok(ref($ob) eq 'Implement');
  87. ok(tied(*$fh) == $ob);
  88.  
  89. @expect = (PRINT => $ob,"some","text");
  90. $r = print $fh @expect[2,3];
  91. ok($r == 1);
  92.  
  93. @expect = (PRINTF => $ob,"%s","text");
  94. $r = printf $fh @expect[2,3];
  95. ok($r == 2);
  96.  
  97. $text = (@data = ("the line\n"))[0];
  98. @expect = (READLINE => $ob);
  99. $ln = <$fh>;
  100. ok($ln eq $text);
  101.  
  102. @expect = ();
  103. @in = @data = qw(a line at a time);
  104. @line = <$fh>;
  105. @expect = @in;
  106. Implement::compare(@line);
  107.  
  108. @expect = (GETC => $ob);
  109. $data = "abc";
  110. $ch = getc $fh;
  111. ok($ch eq "a");
  112.  
  113. $buf = "xyz";
  114. @expect = (READ => $ob, $buf, 3);
  115. $data = "abc";
  116. $r = read $fh,$buf,3;
  117. ok($r == 3);
  118. ok($buf eq "abc");
  119.  
  120.  
  121. $buf = "xyzasd";
  122. @expect = (READ => $ob, $buf, 3,3);
  123. $data = "abc";
  124. $r = sysread $fh,$buf,3,3;
  125. ok($r == 3);
  126. ok($buf eq "xyzabc");
  127.  
  128. $buf = "qwerty";
  129. @expect = (WRITE => $ob, $buf, 4,1);
  130. $data = "";
  131. $r = syswrite $fh,$buf,4,1;
  132. ok($r == 4);
  133. ok($data eq "wert");
  134.  
  135. $buf = "qwerty";
  136. @expect = (WRITE => $ob, $buf, 4);
  137. $data = "";
  138. $r = syswrite $fh,$buf,4;
  139. ok($r == 4);
  140. ok($data eq "qwer");
  141.  
  142. $buf = "qwerty";
  143. @expect = (WRITE => $ob, $buf, 6);
  144. $data = "";
  145. $r = syswrite $fh,$buf;
  146. ok($r == 6);
  147. ok($data eq "qwerty");
  148.  
  149. @expect = (CLOSE => $ob);
  150. $r = close $fh;
  151. ok($r == 5);
  152.