1package ExtUtils::TBone; 2 3 4=head1 NAME 5 6ExtUtils::TBone - a "skeleton" for writing "t/*.t" test files. 7 8 9=head1 SYNOPSIS 10 11Include a copy of this module in your t directory (as t/ExtUtils/TBone.pm), 12and then write your t/*.t files like this: 13 14 use lib "./t"; # to pick up a ExtUtils::TBone 15 use ExtUtils::TBone; 16 17 # Make a tester... here are 3 different alternatives: 18 my $T = typical ExtUtils::TBone; # standard log 19 my $T = new ExtUtils::TBone; # no log 20 my $T = new ExtUtils::TBone "testout/Foo.tlog"; # explicit log 21 22 # Begin testing, and expect 3 tests in all: 23 $T->begin(3); # expect 3 tests 24 $T->msg("Something for the log file"); # message for the log 25 26 # Run some tests: 27 $T->ok($this); # test 1: no real info logged 28 $T->ok($that, # test 2: logs a comment 29 "Is that ok, or isn't it?"); 30 $T->ok(($this eq $that), # test 3: logs comment + vars 31 "Do they match?", 32 This => $this, 33 That => $that); 34 35 # That last one could have also been written... 36 $T->ok_eq($this, $that); # does 'eq' and logs operands 37 $T->ok_eqnum($this, $that); # does '==' and logs operands 38 39 # End testing: 40 $T->end; 41 42 43=head1 DESCRIPTION 44 45This module is intended for folks who release CPAN modules with 46"t/*.t" tests. It makes it easy for you to output syntactically 47correct test-output while at the same time logging all test 48activity to a log file. Hopefully, bug reports which include 49the contents of this file will be easier for you to investigate. 50 51 52=head1 LOG FILE 53 54A typical log file output by this module looks like this: 55 56 1..3 57 58 ** A message logged with msg(). 59 ** Another one. 60 1: My first test, using test(): how'd I do? 61 1: ok 1 62 63 ** Yet another message. 64 2: My second test, using test_eq()... 65 2: A: The first string 66 2: B: The second string 67 2: not ok 2 68 69 3: My third test. 70 3: ok 3 71 72 END 73 74Each test() is logged with the test name and results, and 75the test-number prefixes each line. 76This allows you to scan a large file easily with "grep" (or, ahem, "perl"). 77A blank line follows each test's record, for clarity. 78 79 80=head1 PUBLIC INTERFACE 81 82=cut 83 84# Globals: 85use strict; 86use vars qw($VERSION); 87use FileHandle; 88use File::Basename; 89 90# The package version, both in 1.23 style *and* usable by MakeMaker: 91$VERSION = substr q$Revision: 1.1.1.1 $, 10; 92 93 94 95#------------------------------ 96 97=head2 Construction 98 99=over 4 100 101=cut 102 103#------------------------------ 104 105=item new [ARGS...] 106 107I<Class method, constructor.> 108Create a new tester. Any arguments are sent to log_open(). 109 110=cut 111 112sub new { 113 my $self = bless { 114 OUT =>\*STDOUT, 115 Begin=>0, 116 End =>0, 117 Count=>0, 118 }, shift; 119 $self->log_open(@_) if @_; 120 $self; 121} 122 123#------------------------------ 124 125=item typical 126 127I<Class method, constructor.> 128Create a typical tester. Use this instead of new() for most applicaitons. 129The directory "testout" is created for you automatically, to hold 130the output log file. 131 132=cut 133 134sub typical { 135 my $class = shift; 136 my ($tfile) = basename $0; 137 unless (-d "testout") { 138 mkdir "testout", 0755 139 or die "Couldn't create a 'testout' subdirectory: $!\n"; 140 ### warn "$class: created 'testout' directory\n"; 141 } 142 $class->new($class->catfile('.', 'testout', "${tfile}log")); 143} 144 145#------------------------------ 146# DESTROY 147#------------------------------ 148# Class method, destructor. 149# Automatically closes the log. 150# 151sub DESTROY { 152 $_[0]->log_close; 153} 154 155 156#------------------------------ 157 158=back 159 160=head2 Doing tests 161 162=over 4 163 164=cut 165 166#------------------------------ 167 168=item begin NUMTESTS 169 170I<Instance method.> 171Start testing. 172 173=cut 174 175sub begin { 176 my ($self, $n) = @_; 177 return if $self->{Begin}++; 178 $self->l_print("1..$n\n\n"); 179 print {$self->{OUT}} "1..$n\n"; 180} 181 182#------------------------------ 183 184=item end 185 186I<Instance method.> 187End testing. 188 189=cut 190 191sub end { 192 my ($self) = @_; 193 return if $self->{End}++; 194 $self->l_print("END\n"); 195 print {$self->{OUT}} "END\n"; 196} 197 198#------------------------------ 199 200=item ok BOOL, [TESTNAME], [PARAMHASH...] 201 202I<Instance method.> 203Do a test, and log some information connected with it. 204Use it like this: 205 206 $T->ok(-e $dotforward); 207 208Or better yet, like this: 209 210 $T->ok((-e $dotforward), 211 "Does the user have a .forward file?"); 212 213Or even better, like this: 214 215 $T->ok((-e $dotforward), 216 "Does the user have a .forward file?", 217 User => $ENV{USER}, 218 Path => $dotforward, 219 Fwd => $ENV{FWD}); 220 221That last one, if it were test #3, would be logged as: 222 223 3: Does the user have a .forward file? 224 3: User: "alice" 225 3: Path: "/home/alice/.forward" 226 3: Fwd: undef 227 3: ok 228 229You get the idea. Note that defined quantities are logged with delimiters 230and with all nongraphical characters suitably escaped, so you can see 231evidence of unexpected whitespace and other badnasties. 232Had "Fwd" been the string "this\nand\nthat", you'd have seen: 233 234 3: Fwd: "this\nand\nthat" 235 236And unblessed array refs like ["this", "and", "that"] are 237treated as multiple values: 238 239 3: Fwd: "this" 240 3: Fwd: "and" 241 3: Fwd: "that" 242 243=cut 244 245sub ok { 246 my ($self, $ok, $test, @ps) = @_; 247 ++($self->{Count}); # next test 248 249 # Report to harness: 250 my $status = ($ok ? "ok " : "not ok ") . $self->{Count}; 251 print {$self->{OUT}} $status, "\n"; 252 253 # Log: 254 $self->ln_print($test, "\n") if $test; 255 while (@ps) { 256 my ($k, $v) = (shift @ps, shift @ps); 257 my @vs = ((ref($v) and (ref($v) eq 'ARRAY'))? @$v : ($v)); 258 foreach (@vs) { 259 if (!defined($_)) { # value not defined: output keyword 260 $self->ln_print(qq{ $k: undef\n}); 261 } 262 else { # value defined: output quoted, encoded form 263 s{([\n\t\x00-\x1F\x7F-\xFF\\\"])} 264 {'\\'.sprintf("%02X",ord($1)) }exg; 265 s{\\0A}{\\n}g; 266 $self->ln_print(qq{ $k: "$_"\n}); 267 } 268 } 269 } 270 $self->ln_print($status, "\n"); 271 $self->l_print("\n"); 272 1; 273} 274 275 276#------------------------------ 277 278=item ok_eq ASTRING, BSTRING, [TESTNAME], [PARAMHASH...] 279 280I<Instance method.> 281Convenience front end to ok(): test whether C<ASTRING eq BSTRING>, and 282logs the operands as 'A' and 'B'. 283 284=cut 285 286sub ok_eq { 287 my ($self, $this, $that, $test, @ps) = @_; 288 $self->ok(($this eq $that), 289 ($test || "(Is 'A' string-equal to 'B'?)"), 290 A => $this, 291 B => $that, 292 @ps); 293} 294 295 296#------------------------------ 297 298=item ok_eqnum ANUM, BNUM, [TESTNAME], [PARAMHASH...] 299 300I<Instance method.> 301Convenience front end to ok(): test whether C<ANUM == BNUM>, and 302logs the operands as 'A' and 'B'. 303 304=cut 305 306sub ok_eqnum { 307 my ($self, $this, $that, $test, @ps) = @_; 308 $self->ok(($this == $that), 309 ($test || "(Is 'A' numerically-equal to 'B'?)"), 310 A => $this, 311 B => $that, 312 @ps); 313} 314 315#------------------------------ 316 317=back 318 319=head2 Logging messages 320 321=over 4 322 323=cut 324 325#------------------------------ 326 327=item log_open PATH 328 329I<Instance method.> 330Open a log file for messages to be output to. This is invoked 331for you automatically by C<new(PATH)> and C<typical()>. 332 333=cut 334 335sub log_open { 336 my ($self, $path) = @_; 337 $self->{LogPath} = $path; 338 $self->{LOG} = FileHandle->new(">$path") || die "open $path: $!"; 339 $self; 340} 341 342#------------------------------ 343 344=item log_close 345 346I<Instance method.> 347Close the log file and stop logging. 348You shouldn't need to invoke this directly; the destructor does it. 349 350=cut 351 352sub log_close { 353 my $self = shift; 354 close(delete $self->{LOG}) if $self->{LOG}; 355} 356 357#------------------------------ 358 359=item log MESSAGE... 360 361I<Instance method.> 362Log a message to the log file. No alterations are made on the 363text of the message. See msg() for an alternative. 364 365=cut 366 367sub log { 368 my $self = shift; 369 print {$self->{LOG}} @_ if $self->{LOG}; 370} 371 372#------------------------------ 373 374=item msg MESSAGE... 375 376I<Instance method.> 377Log a message to the log file. Lines are prefixed with "** " for clarity, 378and a terminating newline is forced. 379 380=cut 381 382sub msg { 383 my $self = shift; 384 my $text = join '', @_; 385 chomp $text; 386 $text =~ s{^}{** }gm; 387 $self->l_print($text, "\n"); 388} 389 390#------------------------------ 391# 392# l_print MESSAGE... 393# 394# Instance method, private. 395# Print to the log file if there is one. 396# 397sub l_print { 398 my $self = shift; 399 print { $self->{LOG} } @_ if $self->{LOG}; 400} 401 402#------------------------------ 403# 404# ln_print MESSAGE... 405# 406# Instance method, private. 407# Print to the log file, prefixed by message number. 408# 409sub ln_print { 410 my $self = shift; 411 foreach (split /\n/, join('', @_)) { 412 $self->l_print("$self->{Count}: $_\n"); 413 } 414} 415 416#------------------------------ 417 418=back 419 420=head2 Utilities 421 422=over 4 423 424=cut 425 426#------------------------------ 427 428=item catdir DIR, ..., DIR 429 430I<Class/instance method.> 431Concatenate several directories into a path ending in a directory. 432Lightweight version of the one in the (very new) File::Spec. 433 434Paths are assumed to be absolute. 435To signify a relative path, the first DIR must be ".", 436which is processed specially. 437 438On Mac, the path I<does> end in a ':'. 439On Unix, the path I<does not> end in a '/'. 440 441=cut 442 443sub catdir { 444 my $self = shift; 445 my $relative = shift @_ if ($_[0] eq '.'); 446 if ($^O eq 'Mac') { 447 return ($relative ? ':' : '') . (join ':', @_) . ':'; 448 } 449 else { 450 return ($relative ? './' : '/') . join '/', @_; 451 } 452} 453 454#------------------------------ 455 456=item catfile DIR, ..., DIR, FILE 457 458I<Class/instance method.> 459Like catdir(), but last element is assumed to be a file. 460Note that, at a minimum, you must supply at least a single DIR. 461 462=cut 463 464sub catfile { 465 my $self = shift; 466 my $file = pop; 467 if ($^O eq 'Mac') { 468 return $self->catdir(@_) . $file; 469 } 470 else { 471 return $self->catdir(@_) . "/$file"; 472 } 473} 474 475#------------------------------ 476 477=back 478 479 480=head1 CHANGE LOG 481 482B<Current version:> 483$Id: TBone.pm,v 1.1.1.1 2000/11/14 11:28:38 manuel Exp $ 484 485=over 4 486 487=item Version 1.116 488 489Cosmetic improvements only. 490 491 492=item Version 1.112 493 494Added lightweight catdir() and catfile() (a la File::Spec) 495to enhance portability to Mac environment. 496 497 498=item Version 1.111 499 500Now uses File::Basename to create "typical" logfile name, 501for portability. 502 503 504=item Version 1.110 505 506Fixed bug in constructor that surfaced if no log was being used. 507 508=back 509 510Created: Friday-the-13th of February, 1998. 511 512 513=head1 AUTHOR 514 515Eryq (F<eryq@zeegee.com>). 516President, ZeeGee Software Inc. (F<http://www.zeegee.com>) 517 518=cut 519 520#------------------------------ 521 5221; 523__END__ 524 525my $T = new ExtUtils::TBone "testout/foo.tlog"; 526$T->begin(3); 527$T->msg("before 1\nor 2"); 528$T->ok(1, "one"); 529$T->ok(2, "Two"); 530$T->ok(3, "Three", Roman=>'III', Arabic=>[3, '03'], Misc=>"3\nor 3"); 531$T->end; 532 5331; 534 535