1=head1 NAME 2 3Test::Parser - Base class for parsing log files from test runs, and 4displays in an XML syntax. 5 6=head1 SYNOPSIS 7 8 use Test::Parser::MyTest; 9 10 my $parser = new Test::Parser::MyTest; 11 $parser->parse($text) 12 or die $parser->error(), "\n"; 13 printf("Num Errors: %8d\n", $parser->num_errors()); 14 printf("Num Warnings: %8d\n", $parser->num_warnings()); 15 printf("Num Executed: %8d\n", $parser->num_executed()); 16 printf("Num Passed: %8d\n", $parser->num_passed()); 17 printf("Num Failed: %8d\n", $parser->num_failed()); 18 printf("Num Skipped: %8d\n", $parser->num_skipped()); 19 20 printf("\nErrors:\n"); 21 foreach my $err ($parser->errors()) { 22 print $err; 23 } 24 25 printf("\nWarnings:\n"); 26 foreach my $warn ($parser->warnings()) { 27 print $warn; 28 } 29 30 print $parser->to_xml(); 31 32=head1 DESCRIPTION 33 34This module serves as a common base class for test log parsers. These 35tools are intended to be able to parse output from a wide variety of 36tests - including non-Perl tests. 37 38The parsers also write the test data into the 'Test Result Publication 39Interface' (TRPI) XML schema, developed by SpikeSource. See 40http://www.spikesource.com/testresults/index.jsp?show=trpi-schema 41 42=head1 FUNCTIONS 43 44=cut 45 46package Test::Parser; 47 48use strict; 49use warnings; 50use File::Basename; 51 52use fields qw( 53 code-convention-report 54 coverage-report 55 test 56 num-datum 57 num-column 58 build 59 root 60 url 61 release 62 vendor 63 license 64 summary 65 description 66 platform 67 kernel 68 version 69 testname 70 type 71 path 72 name 73 units 74 warnings 75 errors 76 testcases 77 num_passed 78 num_failed 79 num_skipped 80 outdir 81 format 82 _debug 83 ); 84 85use vars qw( %FIELDS $VERSION ); 86our $VERSION = '1.7'; 87use constant END_OF_RECORD => 100; 88 89=head2 new() 90 91Creates a new Test::Parser object. 92 93=cut 94 95sub new { 96 my $this = shift; 97 my $class = ref($this) || $this; 98 my $self = bless {%FIELDS}, $class; 99 100 $self->{path} = 0; 101 $self->{units} = $class; 102 $self->{version} = $class; 103 $self->{type} = 'unit'; 104 $self->{warnings} = []; 105 $self->{errors} = []; 106 $self->{testcases} = []; 107 $self->{num_passed} = 0; 108 $self->{num_failed} = 0; 109 $self->{num_skipped} = 0; 110 $self->{outdir} = '.'; 111 $self->{format} = 'png'; 112 $self->{_debug} = 0; 113 $self->{name} = ""; 114 $class=~s/^Test::Parser:://; 115 $self->{'testname'} = $class; 116 $self->{'num-column'} = 0; 117 $self->{'num-datum'} = 0; 118 $self->{build} = 0; 119 $self->{root} = 0; 120 $self->{release} = 0; 121 $self->{url} = 0; 122 $self->{vendor} = 0; 123 $self->{license} = 0; 124 $self->{summary} = 0; 125 $self->{description} = 0; 126 $self->{platform} = 0; 127 $self->{kernel} = 0; 128 $self->{'coverage-report'}=0; 129 $self->{'code-convention-report'}=0; 130 131 return $self; 132} 133 134=head2 name() 135 136Gets/sets name parameter. user-customizable identification tag 137 138=cut 139 140sub name { 141 my $self = shift; 142 my $my_name = shift; 143 144 if ($my_name) { 145 $self->{name} = $my_name; 146 } 147 148 return $self->{name}; 149} 150 151=head2 testname() 152 153Gets/sets testname parameter. 154 155=cut 156 157sub testname { 158 my $self = shift; 159 my $testname = shift; 160 161 if ($testname) { 162 $self->{testname} = $testname; 163 } 164 165 return $self->{testname}; 166} 167 168sub version { 169 my $self = shift; 170 my $version = shift; 171 172 if ( $version ) { 173 $self->{version} = $version; 174 } 175 176 return $self->{version}; 177} 178 179sub units { 180 my $self = shift; 181 my $units = shift; 182 183 if ( $units ) { 184 $self->{units} = $units; 185 } 186 187 return $self->{units}; 188} 189 190=head2 to_xml 191 192Method to print test result data from the Test::Parser object in xml format following the trpi schema. Find the trpi schema here: http://developer.osdl.org/~jdaiker/trpi_extended_proposal.xsd 193 194=cut 195 196sub to_xml { 197 my $self = shift; 198 my $xml = ""; 199 my $data = $self->data(); 200 my @required = qw(testname version description summary license vendor release url platform); 201 my @fields = qw(testname version description summary license vendor release url platform kernel root build coverage-report code-convention-report); 202 203 foreach my $field (@required) { 204 if( !$self->{$field} ) { 205 print "Missing required field: $field\n"; 206 return undef; 207 } 208 } 209 $xml .= qq|<component name='$self->{testname}' version='$self->{version}'>\n|; 210 foreach my $field (@fields) { 211 if ($self->{$field}) { 212 #Special case for build / status 213 if ($field eq 'build' && $self->{build_status}) { 214 $xml .= qq| <build status='$self->{build_status}'>$self->{build}</build>\n|; 215 } 216 else { 217 $xml .= qq| <$field>$self->{$field}</$field>\n|; 218 } 219 } 220 } 221 if( $self->{test} ){ 222 $xml .= qq| <test|; 223 if( $self->{test}->{'log-filename'} ){ 224 $xml .= qq| log-filename=$self->{test}->{'log-filename'}|; 225 } 226 if( $self->{test}->{path} ){ 227 $xml .= qq| path=$self->{test}->{path}|; 228 } 229 if( $self->{test}->{'suite-type'} ){ 230 $xml .= qq| suite-type=$self->{test}->{'suite-type'}>\n|; 231 } 232 else { 233 $xml .= qq|>\n|; 234 } 235 if( $self->{test}->{data} ){ 236 $xml .= qq| <data>\n|; 237 if( $self->{test}->{data}->{columns} ){ 238 $xml .= qq| <columns>\n|; 239 240 my %column_hash=%{$self->{test}->{data}->{columns}}; 241 foreach my $column_key(sort {$a <=> $b} keys %column_hash){ 242 if( $column_hash{$column_key}->{'name'} ){ 243 $xml .= qq| <c id="$column_key" name="$column_hash{$column_key}->{'name'}"|; 244 } 245 if( $column_hash{$column_key}->{units} ){ 246 $xml .= qq| units="$column_hash{$column_key}->{units}"|; 247 } 248 $xml .= qq|/>\n|; 249 } 250 $xml .= qq| </columns>\n|; 251 } 252 if( $self->{test}->{data}->{datum} ){ 253 my %datum_hash=%{ $self->{test}->{data}->{datum} }; 254 foreach my $datum_key( sort {$a <=> $b} keys %datum_hash ){ 255 $xml .= qq| <datum id="$datum_key">\n|; 256 foreach my $key_val( sort {$a <=> $b} keys %{ $datum_hash{$datum_key} }){ 257 if( $key_val ){ 258 $xml .= qq| <d id="$key_val">|; 259 if( $self->{test}->{data}->{datum}->{$datum_key}->{$key_val} ){ 260 $xml .= qq|$self->{test}->{data}->{datum}->{$datum_key}->{$key_val}|; 261 } 262 $xml .= qq|</d>\n|; 263 } 264 } 265 $xml .= qq| </datum>\n|; 266 } 267 } 268 $xml .= qq| </data>\n|; 269 } 270 $xml .= qq| </test>\n|; 271 } 272 $xml .= qq|</component>\n|; 273 return $xml; 274} 275 276 277=head2 add_column 278 279A method that adds test column information into the data structure of the Test::Parser object appropriately. This is a helper method to be used from the parse_line method. 280 281=cut 282sub add_column { 283 my $self=shift; 284 my $name=shift; 285 my $units=shift; 286 $self->{'num-column'}+=1; 287 my $columnId = $self->{'num-column'}; 288 $self->{test}->{data}->{columns}->{$columnId}->{name}=$name; 289 $self->{test}->{data}->{columns}->{$columnId}->{units}=$units; 290 return $columnId; 291} 292 293 294=head2 add_data 295 296A method that adds data values corresponding to a given column 297 298=cut 299sub add_data { 300 my $self = shift; 301 my $val = shift; 302 my $col = shift; 303 my $temp = 1; 304 305 if ( defined($self->{'num-datum'}) ) { 306 $temp += $self->{'num-datum'}; 307 } 308 309 for(my $dumy=1; $dumy<($self->{'num-column'}+1); $dumy+=1){ 310 $self->{test}->{data}->{datum}->{$temp}->{$col}= $val; 311 } 312 return; 313} 314 315 316=head2 inc_datum 317 318A method that increments the num-datum variable 319 320=cut 321sub inc_datum { 322 my $self = shift; 323 if ( defined($self->{'num-datum'}) ) { 324 $self->{'num-datum'} += 1; 325 } 326 else { 327 $self->{'num-datum'} = 1; 328 } 329 return $self->{'num-datum'}; 330} 331 332 333=head2 to_dump() 334 335Function to output all data, good for debuging 336 337=cut 338sub to_dump { 339 my $self = shift; 340 341 require Data::Dumper; 342 print Data::Dumper->Dumper($self->{test}); 343} 344 345 346=head2 set_debug($debug) 347 348Turns on debug level. Set to 0 or undef to turn off. 349 350=cut 351sub num_data { 352 my $self =shift; 353 if (@_) { 354 $self->{num_columns} = @_; 355 } 356 return $self->{num_columns}; 357} 358 359sub build { 360 my $self =shift; 361 if (@_) { 362 $self->{build} = @_; 363 } 364 return $self->{build}; 365} 366 367sub root { 368 my $self =shift; 369 if (@_) { 370 $self->{root} = @_; 371 } 372 return $self->{root}; 373} 374sub url { 375 my $self =shift; 376 if (@_) { 377 $self->{url} = @_; 378 } 379 return $self->{url}; 380} 381 382sub release { 383 my $self =shift; 384 if (@_) { 385 $self->{release} = @_; 386 } 387 return $self->{release}; 388} 389 390sub vendor { 391 my $self =shift; 392 if (@_) { 393 $self->{vendor} = @_; 394 } 395 return $self->{vendor}; 396} 397 398sub license { 399 my $self =shift; 400 if (@_) { 401 $self->{license} = @_; 402 } 403 return $self->{license}; 404} 405 406sub summary { 407 my $self =shift; 408 if (@_) { 409 $self->{summary} = @_; 410 } 411 return $self->{summary}; 412} 413 414sub description { 415 my $self =shift; 416 if (@_) { 417 $self->{description} = @_; 418 } 419 return $self->{description}; 420} 421 422sub platform { 423 my $self =shift; 424 if (@_) { 425 $self->{platform} = @_; 426 } 427 return $self->{platform}; 428} 429 430sub type { 431 my $self =shift; 432 if (@_) { 433 $self->{type} = @_; 434 } 435 return $self->{type}; 436} 437 438sub set_debug { 439 my $self = shift; 440 441 if (@_) { 442 $self->{_debug} = shift; 443 } 444 445 return $self->{_debug}; 446} 447 448=head3 type() 449 450Gets or sets the testsuite type. Valid values include the following: 451unit, regression, load, integration, boundary, negative, stress, demo, standards 452 453=cut 454 455sub type_2 { 456 my $self =shift; 457 if (@_) { 458 $self->{type} = @_; 459 } 460 return $self->{type}; 461} 462 463sub path { 464 my $self =shift; 465 if (@_) { 466 $self->{path} = @_; 467 } 468 return $self->{path}; 469} 470 471sub warnings { 472 my $self = shift; 473 if (@_) { 474 $self->{warnings} = shift; 475 } 476 $self->{warnings} ||= []; 477 return $self->{warnings}; 478} 479 480sub num_warnings { 481 my $self = shift; 482 return 0 + @{$self->warnings()}; 483} 484 485sub errors { 486 my $self = shift; 487 if (@_) { 488 $self->{errors} = shift; 489 } 490 $self->{errors} ||= []; 491 return $self->{errors}; 492} 493 494sub num_errors { 495 my $self = shift; 496 return 0 + @{$self->errors()}; 497} 498 499sub testcases { 500 my $self = shift; 501 if (@_) { 502 $self->{testcases} = shift; 503 } 504 $self->{testcases} ||= []; 505 return $self->{testcases}; 506} 507 508sub num_executed { 509 my $self = shift; 510 return 0 + @{$self->testcases()}; 511} 512 513sub num_passed { 514 my $self = shift; 515 return $self->{num_passed}; 516} 517 518sub num_failed { 519 my $self = shift; 520 return $self->{num_failed}; 521} 522 523sub num_skipped { 524 my $self = shift; 525 return $self->{num_skipped}; 526} 527 528sub format { 529 my $self = shift; 530 if (@_) { 531 $self->{format} = shift; 532 } 533 return $self->{format}; 534} 535 536sub outdir { 537 my $self = shift; 538 if (@_) { 539 $self->{outdir} = shift; 540 } 541 return $self->{outdir}; 542} 543 544 545=head2 get_key 546 547 Purpose: To find individual key values parsed from test results 548 Input: The search key, the 'datum' the key is stored in 549 Output: Data stored under the search key, or the search key if not found 550 551=cut 552sub get_key { 553 my $self = shift; 554 my $key = shift or warn ("No search key specified"); 555 my $datum_id = shift or warn ("No datum id specified"); 556 557 my $col_id = undef; 558 559 foreach my $id ( keys %{ $self->{test}->{data}->{columns} } ) { 560 my $check_key = $self->{test}->{data}->{columns}->{$id}->{name}; 561 562 if( $self->{test}->{data}->{columns}->{$id}->{name} eq $key ) { 563 $col_id = $id; 564 } 565 } 566 567 if (defined($col_id)) { 568 return $self->{test}->{data}->{datum}->{$datum_id}->{$col_id} 569 } 570 else { 571 warn ("Unable to find key: " . $key . "\n"); 572 return $key; 573 } 574} 575 576 577=head2 parse($input, [$name[, $path]]) 578 579Call this routine to perform the parsing process. $input can be any of 580the following: 581 582 * A text string 583 * A filename of an external log file to parse 584 * An open file handle (e.g. \*STDIN) 585 586If you are dealing with a very large file, then using the filename 587approach will be more memory efficient. If you wish to use this program 588in a pipe context, then the file handle style will be more suitable. 589 590This routine simply iterates over each newline-separated line of text, 591calling _parse_line. Note that the default _parse_line() routine does 592nothing particularly interesting, so you will probably wish to subclass 593Test::Parser and provide your own implementation of parse_line() to do 594what you need. 595 596The 'name' argument allows you to specify the log filename or other 597indication of the source of the parsed data. 'path' allows specification 598of the location of this file within the test run directory. By default, 599if $input is a filename, 'name' and 'path' will be taken from that, else 600they'll be left blank. 601 602If the filename contains multiple test records, parse() simply parses 603the first one it finds, and then returns the constant 604Test::Parser::END_OF_RECORD. If your input file contains multiple 605records, you probably want to call parse in the GLOB fashion. E.g., 606 607 my @logs; 608 open (FILE, 'my.log') or die "Couldn't open: $!\n"; 609 while (FILE) { 610 my $parser = new Test::Parser; 611 $parser->parse(\*FILE); 612 push @logs, $parser; 613 } 614 close (FILE) or die "Couldn't close: $!\n"; 615 616=cut 617 618sub parse { 619 my $self = shift; 620 my $input = shift or return undef; 621 my ($name, $path) = @_; 622 623 my $retval = 1; 624 625 # If it's a GLOB, we're probably reading from STDIN 626 if (ref($input) eq 'GLOB') { 627 while (<$input>) { 628 $retval = $self->parse_line($_) || $retval; 629 last if $retval == END_OF_RECORD; 630 } 631 } 632 # If it's a scalar and has newlines, it's probably the full text 633 elsif (!ref($input) && $input =~ /\n/) { 634 my @lines = split /\n/, $input; 635 while (shift @lines) { 636 $retval = $self->parse_line($_) || $retval; 637 last if $retval == END_OF_RECORD; 638 } 639 } 640 641 # If it appears to be a valid filename, assume we're reading an external file 642 elsif (!ref($input) && -f $input) { 643 $name ||= basename($input); 644 $path ||= dirname($input); 645 646 open (FILE, "< $input") 647 or warn "Could not open '$input' for reading: $!\n" 648 and return undef; 649 while (<FILE>) { 650 $retval = $self->parse_line($_) || $retval; 651 last if $retval eq END_OF_RECORD; 652 } 653 close(FILE); 654 } 655 $self->{path} = $path; 656 657 return $retval; 658} 659 660=head2 parse_line($text) 661 662Virtual function for parsing a line of test result data. The base class' 663implementation of this routine does nothing interesting. 664 665You will need to override this routine to customize it to your 666application. The parse() routine will call this iteratively for each 667line of text in the test output file. 668 669Returns undef on error. The error message can be retrieved via error(). 670 671=cut 672 673sub parse_line { 674 my $self = shift; 675 my $text = shift or return undef; 676 677 return undef; 678} 679 680 681=head2 num_warnings() 682 683The number of warnings found 684 685=head2 warnings() 686 687Returns a reference to an array of the warnings encountered. 688 689=head2 num_errors() 690 691The number of errors found 692 693=head2 errors() 694 695Returns a reference to an array of the errors encountered. 696 697=head1 AUTHOR 698 699Bryce Harrington <bryce@osdl.org> 700 701=head1 COPYRIGHT 702 703Copyright (C) 2005 Bryce Harrington. 704All Rights Reserved. 705 706This script is free software; you can redistribute it and/or modify it 707under the same terms as Perl itself. 708 709=head1 SEE ALSO 710 711L<perl>, L<Test::Metadata> 712 713=cut 714 715 7161; 717 718