vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libio-stringy-perl/io-stringy-2.110/t/Common.pm

   1 package Common;
   2
   3 #--------------------
   4 #
   5 # GLOBALS...
   6 #
   7 #--------------------
   8
   9 use vars qw(@DATA_SA
  10             @DATA_LA
  11             $DATA_S
  12
  13             @ADATA_SA
  14             $ADATA_S
  15
  16             $FDATA_S
  17             @FDATA_LA
  18             );
  19
  20 #------------------------------
  21
  22 # Data...
  23 #    ...as a scalar-array:
  24 @DATA_SA = (
  25 "A diner while ",
  26 "dining at Crewe\n",
  27 "Found a rather large ",
  28 "mouse in his stew\n   Said the waiter, \"Don't shout,\n",
  29 "   And ",
  30 "wave it about..."
  31 );
  32 #    ...as a string:
  33 $DATA_S = join '', @DATA_SA;
  34 #    ...as a line-array:
  35 @DATA_LA = lines($DATA_S);
  36
  37 # Additional data...
  38 #    ...as a scalar-array:
  39 @ADATA_SA = (
  40 "\nor the rest",
  41 " will be wanting one ",
  42 "too.\"\n",
  43 );
  44 #    ...as a string:
  45 $ADATA_S = join '', @ADATA_SA;
  46
  47
  48 # Full data...
  49 #    ...as a string:
  50 $FDATA_S = $DATA_S . $ADATA_S;
  51 #    ...as a line-array:
  52 @FDATA_LA = lines($FDATA_S);
  53
  54
  55
  56
  57 # Tester:
  58 my $T;
  59
  60 # Scratch...
  61 my $BUF = '';      # buffer
  62 my $M;             # message
  63
  64
  65 #------------------------------
  66 # lines STR
  67 #------------------------------
  68 sub lines {
  69     my $s = shift;
  70     split /^/, $s;
  71 }
  72
  73 #------------------------------
  74 # test_init PARAMHASH
  75 #------------------------------
  76 # Init common tests.
  77 #
  78 sub test_init {
  79     my ($self, %p) = @_;
  80     $T = $p{TBone};
  81 }
  82
  83 #------------------------------
  84 # test_print HANDLE, TEST
  85 #------------------------------
  86 # Test printing to handle.
  87 # 1
  88 #
  89 sub test_print {
  90     my ($self, $GH, $all) = @_;
  91     local($_);
  92
  93     # Append with print:
  94     $M = "PRINT: able to print to $GH";
  95     $GH->print($ADATA_SA[0]);
  96     $GH->print(@ADATA_SA[1..2]);
  97     $T->ok(1, $M);
  98 }
  99
 100 #------------------------------
 101 # test_getc HANDLE
 102 #------------------------------
 103 # Test getc().
 104 # 1
 105 #
 106 sub test_getc {
 107     my ($self, $GH) = @_;
 108     local($_);
 109     my @c;
 110
 111     $M = "GETC: seek(0,0) and getc()";
 112     $GH->seek(0,0);
 113     for (0..2) { $c[$_] = $GH->getc };
 114     $T->ok((($c[0] eq 'A') &&
 115             ($c[1] eq ' ') &&
 116             ($c[2] eq 'd')), $M);
 117 }
 118
 119 #------------------------------
 120 # test_getline HANDLE
 121 #------------------------------
 122 # Test getline() and getlines().
 123 # 4
 124 #
 125 sub test_getline {
 126     my ($self, $GH) = @_;
 127     local($_);
 128
 129     $M = "GETLINE/SEEK3: seek(3,START) and getline() gets part of 1st line";
 130     $GH->seek(3,0);
 131     my $got  = $GH->getline;
 132     my $want = "iner while dining at Crewe\n";
 133     $T->ok(($got eq $want), $M,
 134            GH   => $GH,
 135            Got  => $got,
 136            Want => $want);
 137
 138     $M = "GETLINE/NEXT: next getline() gets subsequent line";
 139     $_ = $GH->getline;
 140     $T->ok(($_ eq "Found a rather large mouse in his stew\n"), $M,
 141            Got => $_);
 142
 143     $M = "GETLINE/EOF: repeated getline() finds end of stream";
 144     my $last;
 145     for (1..6) { $last = $GH->getline }
 146     $T->ok(!$last, $M,
 147            Last => (defined($last) ? $last : 'undef'));
 148
 149     $M = "GETLINE/GETLINES: seek(0,0) and getlines() slurps in string";
 150     $GH->seek(0,0);
 151     my @got  = $GH->getlines;
 152     my $gots = join '', @got;
 153     $T->ok(($gots eq $FDATA_S), $M,
 154            GotAll  => $gots,
 155            WantAll => $FDATA_S,
 156            Got     => \@got);
 157 }
 158
 159 #------------------------------
 160 # test_read HANDLE
 161 #------------------------------
 162 # Test read().
 163 # 4
 164 #
 165 sub test_read {
 166     my ($self, $GH) = @_;
 167     local($_);
 168
 169     $M = "READ/FIRST10: reading first 10 bytes with seek(0,START) + read(10)";
 170     $GH->seek(0,0);
 171     $GH->read($BUF,10);
 172     $T->ok(($BUF eq "A diner wh"), $M);
 173
 174     $M = "READ/NEXT10: reading next 10 bytes with read(10)";
 175     $GH->read($BUF,10);
 176     $T->ok(($BUF eq "ile dining"), $M);
 177
 178     $M = "READ/TELL20: tell() the current location as 20";
 179     $T->ok(($GH->tell == 20), $M);
 180
 181     $M = "READ/SLURP: seek(0,START) + read(1000) reads in whole handle";
 182     $GH->seek(0,0);
 183     $GH->read($BUF,1000);
 184     $T->ok(($BUF eq $FDATA_S), $M);
 185 }
 186
 187 #------------------------------
 188 # test_seek HANDLE
 189 #------------------------------
 190 # Test seeks other than (0,0).
 191 # 2
 192 #
 193 sub test_seek {
 194     my ($self, $GH) = @_;
 195     local($_);
 196
 197     $M = "SEEK/SET: seek(2,SET) + read(5) returns 'diner'";
 198     $GH->seek(2,0);
 199     $GH->read($BUF,5);
 200     $T->ok_eq($BUF, 'diner',
 201               $M);
 202
 203     $M = "SEEK/END: seek(-6,END) + read(3) returns 'too'";
 204     $GH->seek(-6,2);
 205     $GH->read($BUF,3);
 206     $T->ok_eq($BUF, 'too',
 207               $M);
 208
 209     $M = "SEEK/CUR: seek(-7,CUR) + read(7) returns 'one too'";
 210     $GH->seek(-7,1);
 211     $GH->read($BUF,7);
 212     $T->ok_eq($BUF, 'one too',
 213               $M);
 214 }
 215
 216 #------------------------------
 217 # test_tie PARAMHASH
 218 #------------------------------
 219 # Test tiehandle getline() interface.
 220 # 4
 221 #
 222 sub test_tie {
 223     my ($self, %p) = @_;
 224     my ($tieclass, @tieargs) = @{$p{TieArgs}};
 225     local($_);
 226     my @lines;
 227     my $i;
 228     my $nmatched;
 229
 230     $M = "TIE/TIE: able to tie";
 231     tie(*OUT, $tieclass, @tieargs);
 232     $T->ok(1, $M,
 233            TieClass => $tieclass,
 234            TieArgs => \@tieargs);
 235
 236     $M = "TIE/PRINT: printing data";
 237     print OUT @DATA_SA;
 238     print OUT $ADATA_SA[0];
 239     print OUT @ADATA_SA[1..2];
 240     $T->ok(1, $M);
 241
 242     $M = "TIE/GETLINE: seek(0,0) and scalar <> get expected lines";
 243     tied(*OUT)->seek(0,0);                       # rewind
 244     @lines = (); push @lines, $_ while <OUT>;    # get lines one at a time
 245     $nmatched = 0;                               # total up matches...
 246     for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) };
 247     $T->ok(($nmatched == int(@FDATA_LA)), $M,
 248            Want => \@FDATA_LA,
 249            Gotl => \@lines,
 250            Lines=> "0..$#lines",
 251            Match=> $nmatched,
 252            FDatl=> int(@FDATA_LA),
 253            FData=> \@FDATA_LA);
 254
 255     $M = "TIE/GETLINES: seek(0,0) and array <> slurps in lines";
 256     tied(*OUT)->seek(0,0);                       # rewind
 257     @lines = <OUT>;                              # get lines all at once
 258     $nmatched = 0;                               # total up matches...
 259     for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) };
 260     $T->ok(($nmatched == int(@FDATA_LA)), $M,
 261            Want => \@FDATA_LA,
 262            Gotl => \@lines,
 263            Lines=> "0..$#lines",
 264            Match=> $nmatched);
 265
 266 #    $M = "TIE/TELL: telling data";
 267 #    my $tell_oo  = tied(*OUT)->tell;
 268 #    my $tell_tie = tell OUT;
 269 #    $T->ok(($tell_oo == $tell_tie), $M,
 270 #          Want => $tell_oo,
 271 #          Gotl => $tell_tie);
 272
 273 }
 274
 275 #------------------------------
 276 # test_recordsep
 277 #------------------------------
 278 # Try $/ tests.
 279 #
 280 #    3 x undef
 281 #    3 x empty
 282 #    2 x custom
 283 #   11 x newline
 284 #
 285 sub test_recordsep_count {
 286     my ($self, $seps) = @_;
 287     my $count = 0;
 288     $count += 3 if ($seps =~ /undef/) ;
 289     $count += 3 if ($seps =~ /empty/) ;
 290     $count += 2 if ($seps =~ /custom/) ;
 291     $count += 11 if ($seps =~ /newline/);
 292     $count;
 293 }
 294 sub test_recordsep {
 295     my ($self, $seps, $opener) = @_;
 296     my $GH;
 297     my @lines = ("par 1, line 1\n",
 298                  "par 1, line 2\n",
 299                  "\n",
 300                  "\n",
 301                  "\n",
 302                  "\n",
 303                  "par 2, line 1\n",
 304                  "\n",
 305                  "par 3, line 1\n",
 306                  "par 3, line 2\n",
 307                  "par 3, line 3");
 308     my $all = join('', @lines);
 309
 310     ### Slurp everything:
 311     if ($seps =~ /undef/) {
 312         $GH = &$opener(\@lines);
 313         local $/ = undef;
 314         $T->ok_eq($GH->getline, $all,
 315                   "RECORDSEP undef: getline slurps everything");
 316     }
 317
 318     ### Read a little, slurp the rest:
 319     if ($seps =~ /undef/) {
 320         $GH = &$opener(\@lines);
 321         $T->ok_eq($GH->getline, $lines[0],
 322                   "RECORDSEP undef: get first line");
 323         local $/ = undef;
 324         $T->ok_eq($GH->getline, join('', @lines[1..$#lines]),
 325                   "RECORDSEP undef: slurp the rest");
 326     }
 327
 328     ### Read paragraph by paragraph:
 329     if ($seps =~ /empty/) {
 330         $GH = &$opener(\@lines);
 331         local $/ = "";
 332         $T->ok_eq($GH->getline, join('', @lines[0..2]),
 333                   "RECORDSEP empty: first par");
 334         $T->ok_eq($GH->getline, join('', @lines[6..7]),
 335                   "RECORDSEP empty: second par");
 336         $T->ok_eq($GH->getline, join('', @lines[8..10]),
 337                   "RECORDSEP empty: third par");
 338     }
 339
 340     ### Read record by record:
 341     if ($seps =~ /custom/) {
 342         $GH = &$opener(\@lines);
 343         local $/ = "1,";
 344         $T->ok_eq($GH->getline, "par 1,",
 345                   "RECORDSEP custom: first rec");
 346         $T->ok_eq($GH->getline, " line 1\npar 1,",
 347                   "RECORDSEP custom: second rec");
 348     }
 349
 350     ### Read line by line:
 351     if ($seps =~ /newline/) {
 352         $GH = &$opener(\@lines);
 353         local $/ = "\n";
 354         for my $i (0..10) {
 355             $T->ok_eq($GH->getline, $lines[$i],
 356                       "RECORDSEP newline: rec $i");
 357         }
 358     }
 359
 360 }
 361
 362 #------------------------------
 363 1;
 364
 365