1#!/usr/bin/perl -w 2 3############################################################################# 4# 5 6# 7# Controls 8# 9# @filesection 10# Expected to contain @nam1rule and perhaps @nam2rule 11# which overwrite all later name rules 12# 13# @datasection 14# subdivides for multiple types in one file e.g. ajstr.c 15# expected to have @nam2rule 16# which overwrites all later name rules 17# 18# @fdata [Datatype] 19# should automatically pick up rules from an @datasection block 20# 21# @nam*rule Name Descriptive text 22# describes a name element and its level 23# if attached always to a lower level name, include both e.g. NewRes 24# (or they could be simply nested if the name can appear anywhere) 25# 26# @suffix Name 27# single letter suffix appended to any function name 28# defined globally in @filesection or @datasection 29# or just for a single section 30# 31# @argrule Name Argname [Argtype] Descriptive text 32# attached to a name from @namrule or @suffix 33# the argument name must appear in the order specified in the rules 34# Name can (should) be * to apply to all functions in a section. 35# 36# @valrule Name [Valtype] Descriptive text 37# The return value for a named set of functions. 38# Name can (should) be * to apply to all functions in a section. 39############################################################################# 40 41use English; 42 43sub nametowords($) { 44 my ($name) = @_; 45 my $fname = $name; 46 $name =~ s/([A-Z])/ $1/go; 47 my @nameparts = split(' ', $name); 48# print LOG "sub function $fname parts $#nameparts\n"; 49 return @nameparts; 50} 51 52sub nametorules($@) { 53 my ($name,$rules) = @_; 54 my $fname = $name; 55 my $ok = 1; 56 if (!($name =~ s/^M//)) {return 0} 57 58 print LOG "nametorules $fname\n"; 59 my $ilevel = 0; 60 my $irule = 0; 61 my $urule = ""; 62 my $nname = $name; 63 my @nametorules = (); 64 65 foreach $rulelevel (@$rules) { 66 $ok = 1; 67 $ilevel++; 68 print LOG "nametorules level $ilevel\n"; 69 $irule = 0; 70 $nname = $name; 71 foreach $currule (@$rulelevel) { 72 $irule++; 73 print LOG "nametorules level $ilevel rule $irule\n"; 74 $currule =~ s/([A-Z])/ $1/gos; 75 @ruleparts = split(' ', $currule); 76 $rule = pop(@ruleparts); 77 $urule = uc($rule); 78 print LOG "nametorules rule '$rule'\n"; 79 if($nname =~ s/^$urule//) { 80 print LOG "nametorules matched name: '...$nname'\n"; 81 $ok = 1; 82 push(@nametorules, $rule); 83 if($nname eq "") {last} 84 next; 85 } 86 else { 87 print LOG "nametorules no match\n"; 88 $ok = 0; 89 } 90 } 91 if($ok) { 92 if ($nname eq "") { 93 print LOG "nametorules success\n"; 94 return @nametorules; 95 } 96 else { 97 print LOG "nametorules matched up to: '...$nname'\n"; 98 $name = $nname; 99 } 100 } 101 else { 102 print LOG "nametorules not found '...$nname'\n"; 103 } 104 } 105 106 print LOG "nametorules failed $fname ok:$ok name: '$nname'\n"; 107 108 return 0; 109} 110 111sub testorder($$@) { 112 my ($lastname, $type, @newparts) = @_; 113 print LOG "testorder '$lastname' '$name'\n"; 114 if($lastname eq "") {return 1} 115 $lastname =~ s/([A-Z])/ $1/go; 116 my @oldparts = split(' ', $lastname); 117 my $o; 118 foreach $o (@oldparts) { 119 if($#newparts < 0) {return 0} 120 $n = shift(@newparts); 121 if($o =~ /^[A-Z]$/) { # last name within suffix list 122 print LOG "testorder suffix '$n' '$o'\n"; 123 if($n =~ /^[A-Z]$/) { 124 if($n lt $o) {return 0} 125 if($n gt $o) {return 1} 126 } 127 else {return 1} # new name level 128 } 129 else { 130 print LOG "testorder name '$n' '$o'\n"; 131 if($n lt $o) {return 0} 132 if($n gt $o) {return 1} 133 } 134 } 135 if($#newparts >= 0) {return 1} 136 # oops - names seem to be the same 137 print LOG "testorder fail: identity\n"; 138 if($type eq "macro") {return 1} # macro can follow function of same name 139 return 0; 140} 141 142sub issuffix($@) { 143 my ($name,@suffixes) = @_; 144 my $s; 145 if($#suffixes < 0) {return 0} 146 147 foreach $s (@suffixes) { 148# print LOG "issuffix '$name' '$s'\n"; 149 if ($name eq $s) {return 1} 150 } 151 152# print LOG "issuffix failed\n"; 153 return 0; 154} 155 156sub isnamrule($\@@) { 157 my ($i, $rules, @nameparts) = @_; 158 my $j = $i-1; 159# print LOG "isnamrule ++ i: $i rules $#{$rules} names $#nameparts '$nameparts[$i]'\n"; 160 if($i > $#nameparts) { 161# print LOG "isnamrule i: $i names $#nameparts\n"; 162 return 0; 163 } 164 my $rule; 165 my $r; 166 my @ruleparts; 167 my $ok; 168 foreach $currule (@$rules) { 169# print LOG "isnamrule: rule '$currule'\n"; 170 $rule = $currule; 171 $rule =~ s/([A-Z])/ $1/gos; 172 @ruleparts = split(' ', $rule); 173 $j = $i - $#ruleparts; 174 if($j < 0) {next} 175 $ok = 1; 176 foreach $r (@ruleparts) { 177# print LOG "isnamrule $j name: '$nameparts[$j]' rule '$r'\n"; 178 if($nameparts[$j] ne $r) {$ok=0;last} 179 $j++; 180 } 181 if(!$ok) {next} 182# print LOG "isnamrule OK\n"; 183 return 1; 184 } 185# print LOG "isnamrule all rules failed\n"; 186 return 0; 187} 188 189sub matchargname($$@) { 190 my ($aname, $anum, @nameparts) = @_; 191 my $j = $#nameparts; 192 my $argname = $aname; 193 $argname =~ s/^[*]//go; 194 $argname =~ s/([A-Z])/ $1/go; 195 my @argparts = split(' ', $argname); 196 my $k = $#argparts; 197 if($j < $k) {return 0} # argname longer than function name! 198 my $curarg; 199 my $ok; 200 my $imax = $j - $k; 201 my $i; 202 my $ii; 203 my $kk; 204 my $n = ""; 205 my $sufcnt = 0; 206 print LOG "matchargname '$aname' <$anum> '$fname' imax:$imax\n"; 207 print LOG "matchargname parts: \n"; 208 foreach $n (@nameparts) { print LOG " '$n'"} 209 print LOG "\n"; 210 for ($i=0;$i<=$imax; $i++) { 211 $ok = 1; 212 $aname = ""; 213 $sufcnt = 0; 214 for ($ii=0; $ii < $i; $ii++) { 215 if($nameparts[$ii] =~ /^[A-Z]$/) { 216 print LOG "i:$i suffix '$nameparts[$ii]'\n"; 217 $sufcnt++; 218 } 219 } 220 print LOG "i:$i sufcnt: $sufcnt\n"; 221 for ($kk=0;$kk<=$k;$kk++) { 222 $ii = $i+$kk; 223 print LOG "matchargname test $nameparts[$ii] $argparts[$kk]\n"; 224 if($nameparts[$ii] =~ /^[A-Z]$/) {$sufcnt++} 225 if($nameparts[$ii] ne $argparts[$kk]) { 226 print LOG "matchargname reject $nameparts[$ii] $argparts[$kk]\n"; 227 $ok = 0; 228 last; 229 } 230 $aname .= $nameparts[$ii]; 231 print LOG "matchargname OK so far: $aname\n"; 232 } 233 if($ok) { 234 print LOG "matchargname: matched i:$i '$aname' $sufcnt/$anum\n"; 235 if($anum && ($sufcnt != $anum)) {next} 236 return 1; 237 } 238 } 239 print LOG "matchargname failed\n"; 240 return 0; 241} 242 243sub srsref { 244 return "<a href=\"http://srs.ebi.ac.uk/srs7bin/cgi-bin/wgetz?-e+[EFUNC-ID:$_[0]]\">$_[0]</a>"; 245} 246sub srsdref { 247 return "<a href=\"http://srs.ebi.ac.uk/srs7bin/cgi-bin/wgetz?-e+[EDATA-ID:$_[0]]\">$_[0]</a>"; 248} 249 250sub secttest($$) { 251 my ($sect, $ctype) = @_; 252 my $stype = ""; 253 if ($sect =~ /Constructors$/i) {$stype = "new"} 254 elsif ($sect =~ /Destructors$/i) {$stype = "delete"} 255 elsif ($sect =~ /Assignments$/i) {$stype = "assign"} 256 elsif ($sect =~ /Iterators$/i) {$stype = "iterate"} 257 elsif ($sect =~ /Modifiers$/i) {$stype = "modify"} 258 elsif ($sect =~ /Casts$/i) {$stype = "cast"} 259 elsif ($sect =~ /Input$/i) {$stype = "input"} 260 elsif ($sect =~ /Output$/i) {$stype = "output"} 261 elsif ($sect =~ /Miscellaneous$/i) {$stype = "misc"} 262 if ($stype eq "") {return $stype} 263 if ($stype ne $ctype) { 264 print "bad category '$ctype' (expected '$stype') in section '$sect'\n"; 265 } 266 return $stype; 267} 268 269sub testvar($) { 270 my ($tvar) = @_; 271 if (defined($cppreserved{$tvar})) { 272 print "bad variable '$tvar' - reserved word in C++, use '$cppreserved{$tvar}'\n"; 273 } 274} 275 276sub testnew($$) { 277 my ($tdata, $ttype) = @_; 278 if ($tdata ne $ttype) { 279 print "bad category new - return type '$ttype' datatype '$tdata'\n"; 280 } 281} 282 283sub testdelete($$\@\@) { 284 my ($tdata, $ttype, $tcast, $tcode) = @_; 285 if ($ttype ne "void") { 286 print "bad category delete - return type '$ttype' non-void\n"; 287 } 288 if ($#{$tcast} < 0) { 289 print "bad category delete - parameter missing\n"; 290 return 0; 291 } 292 $tx = ${$tcode}[0]; 293 if ($#{$tcast} > 0) { 294 print "bad category delete - only one parameter allowed\n"; 295 return 0; 296 } 297 if (${$tcast}[0] !~ /$tdata\*+/) { 298 $tc = ${$tcast}[0]; 299 print "bad category delete - only parameter '$tc' must be '$tdata\*'\n"; 300 } 301 if ($tx !~ /[d]/) { 302 print "bad category delete - code1 '$tx' not 'd'\n"; 303 } 304} 305 306sub testassign($$\@\@) { 307 my ($tdata, $ttype, $tcast, $tcode) = @_; 308 if ($#{$tcast} < 0) { 309 print "bad category assign - no parameters\n"; 310 } 311 $tc = ${$tcast}[0]; 312 $tx = ${$tcode}[0]; 313 if ($tc ne "$tdata\*") { 314 print "bad category assign - parameter1 '$tc' not '$tdata\*'\n"; 315 } 316 if ($tx !~ /[w]/) { 317 print "bad category assign - code1 '$tx' not 'w'\n"; 318 } 319# if ($tx !~ /[D]/) { 320# print "bad category assign - code1 '$tx' not 'D'\n"; 321# } 322} 323 324sub testmodify($$\@\@) { 325 my ($tdata, $ttype, $tcast, $tcode) = @_; 326 if ($#{$tcast} < 0) { 327 print "bad category modify - no parameters\n"; 328 } 329 $tc = ${$tcast}[0]; 330 $tx = ${$tcode}[0]; 331 if(!defined($tc)) { 332 print "testmodify tc undefined for $fname $pubout\n"; 333 } 334 if ($tc ne "$tdata" && $tc ne "$tdata\*") { 335 print "bad category modify - parameter1 '$tc' not '$tdata' or '$tdata\*'\n"; 336 } 337 if ($tx !~ /[wu]/) { 338 print "bad category modify - code1 '$tx' not 'w' or 'u'\n"; 339 } 340} 341 342sub testcast($$\@\@) { 343 my ($tdata, $ttype, $tcast, $tcode) = @_; 344 if ($#{$tcast} < 0) { 345 print "bad category cast - no parameters\n"; 346 return 0; 347 } 348 if ($#{$tcast} == 0 && $ttype eq "void") { 349 print "bad category cast - one parameter and returns void\n"; 350 } 351 $tc = ${$tcast}[0]; 352 $tx = ${$tcode}[0]; 353 if ($tc ne "const $tdata") { 354 print "bad category cast - parameter1 '$tc' not 'const $tdata'\n"; 355 } 356 if ($tx !~ /[r]/) { 357 print "bad category cast - code1 '$tx' not 'r'\n"; 358 } 359} 360 361sub testderive($$\@\@) { 362 my ($tdata, $ttype, $tcast, $tcode) = @_; 363 if ($#{$tcast} < 0) { 364 print "bad category derive - no parameters\n"; 365 return 0; 366 } 367 if ($#{$tcast} == 0 && $ttype eq "void") { 368 print "bad category derive - one parameter and returns void\n"; 369 } 370 $tc = ${$tcast}[0]; 371 $tx = ${$tcode}[0]; 372 if ($tc ne "const $tdata") { 373 print "bad category derive - parameter1 '$tc' not 'const $tdata'\n"; 374 } 375 if ($tx !~ /[r]/) { 376 print "bad category derive - code1 '$tx' not 'r'\n"; 377 } 378} 379 380sub testuse($\@\@) { 381 my ($tdata, $tcast, $tcode) = @_; 382 if ($#{$tcast} < 0) { 383 print "bad category use - no parameters\n"; 384 return 0; 385 } 386 $qpat = qr/^const $tdata[*]*$/; 387 $qpat2 = qr/^$tdata[*]* const[ *]*$/; 388 $tc = ${$tcast}[0]; 389 $tx = ${$tcode}[0]; 390 $tc =~ s/^CONST /const /go; 391 if ($tc !~ $qpat && $tc !~ $qpat2 && $tc ne "const void*") { 392 print "bad category use - parameter1 '$tc' not 'const $tdata'\n"; 393 } 394 if ($tx !~ /[r]/) { 395 print "bad category use - code1 '$tx' not 'r'\n"; 396 } 397} 398 399sub testiterate($$$\@) { 400 my ($tdata, $ttype, $tdesc, $tcast, $tcode) = @_; 401 my ($itertype) = ($tdesc =~ /(^\S+)\s+iterator/); 402 if (!$itertype) { 403 print "bad category iterator - no type in description\n"; 404 } 405 else { 406 $tc = ${$tcast}[0]; 407 if ($ttype ne $itertype && 408 $tc ne "$itertype" && 409 $tc ne "$itertype\*") { 410 print "bad category iterate - type '$itertype' not referenced\n"; 411 } 412 } 413} 414 415sub testinput($\@\@) { 416 my ($tdata, $tcast, $tcode) = @_; 417 my $ok = 0; 418 my $i = 0; 419 if ($#{$tcast} < 0) { 420 print "bad category input - no parameters\n"; 421 return 0; 422 } 423 424 for ($i=0; $i <= $#{$tcast}; $i++) { 425 $tc = ${$tcast}[$i]; 426 $tx = ${$tcode}[$i]; 427 if (($tc eq "$tdata" || $tc eq "$tdata*")&& ($tx =~ /[wu]/)) { 428 $ok = 1; 429 } 430 } 431 if (!$ok) { 432 print "bad category input - no parameter '$tdata' with code 'w' or 'u'\n"; 433 } 434} 435 436sub testoutput($\@\@) { 437 my ($tdata, $tcast, $tcode) = @_; 438 my $ok = 0; 439 my $i = 0; 440 if ($#{$tcast} < 0) { 441 print "bad category output - no parameters\n"; 442 return 0; 443 } 444 for ($i=0; $i <= $#{$tcast}; $i++) { 445 $tc = ${$tcast}[$i]; 446 $tx = ${$tcode}[$i]; 447 if ($tc eq "$tdata" || $tc eq "const $tdata") { 448 if ($tx =~ /[ru]/) { 449 $ok = 1; 450 } 451 } 452 } 453 if (!$ok) { 454 print "bad category output - no parameter (const) '$tdata' and code 'r' or 'u'\n"; 455 } 456} 457 458sub testmisc($\@\@) { 459 my ($tdata, $tcast, $tcode) = @_; 460 my $ok = 0; 461 my $i = 0; 462# if ($#{$tcast} < 0) { 463# print "bad category misc - no parameters\n"; 464# return 0; 465# } 466# for ($i=0; $i <= $#{$tcast}; $i++) { 467# $tc = ${$tcast}[$i]; 468# $tx = ${$tcode}[$i]; 469# if ($tc eq "$tdata" || $tc eq "const $tdata") { 470# if ($tx =~ /[ru]/) { 471# $ok = 1; 472# } 473# } 474# } 475# if (!$ok) { 476# print "bad category misc - no parameter (const) '$tdata' and code 'r' or 'u'\n"; 477# } 478} 479 480sub testinternals($\@\@) { 481 my ($tdata, $tcast, $tcode) = @_; 482 my $ok = 0; 483 my $i = 0; 484# if ($#{$tcast} < 0) { 485# print "bad category misc - no parameters\n"; 486# return 0; 487# } 488# for ($i=0; $i <= $#{$tcast}; $i++) { 489# $tc = ${$tcast}[$i]; 490# $tx = ${$tcode}[$i]; 491# if ($tc eq "$tdata" || $tc eq "const $tdata") { 492# if ($tx =~ /[ru]/) { 493# $ok = 1; 494# } 495# } 496# } 497# if (!$ok) { 498# print "bad category internals - no parameter (const) '$tdata' and code 'r' or 'u'\n"; 499# } 500} 501 502sub printsect($$) { 503 my ($mysect,$mysrest) = @_; 504 if ($mysect ne $lastfsect) { 505 if(defined($dataname)) { 506 printdata($dataname,$datadesc); 507 } 508 if(${$ostr} =~ /\.\.\.\.lastsect\.\.\.\./) { 509 if(!$dosecttest) {$sectstr = ""} 510 elsif($sectstr !~ /[^ ]$/) {$sectstr = ""} 511 else {$sectstr .= "</table>\n"} 512 ${$ostr} =~ s/[.]+lastsect[.]+/$sectstr\n/; 513 } 514 my $mysname = $mysect; 515 $mysname =~ s/\s+/_/; 516 ${$ostr} .= "<hr><h3><a name=\"sec_$mysname\">\n"; 517 518 my $dname = "none"; 519 if(defined($dataname)) {$dname = $dataname} 520 if($dname eq "none") {$dname = "Section"} 521 ${$ostr} .= "$dname: $mysect</a></h3>\n"; 522 523 ${$ostr} .= "$mysrest\n"; 524 ${$ostr} .= "....lastsect...."; 525 $lastfsect = $mysect; 526 my $catdesc = ""; 527 if($fctype ne "") {$catdesc = "Category: '$fctype'"} 528 if(defined($categs{$fctype})) {$catdesc = $categs{$fctype}} 529 $datastr .= "<tr><td> <a href=#sec_$mysname>$mysect</a></td><td>$catdesc</td></tr>\n"; 530 } 531} 532 533sub printsectstatic($$) { 534 my ($mysect, $mysrest) = @_; 535 if ($mysect ne $laststatfsect) { 536 if(defined($dataname)) { 537 printdatastatic($dataname,$datadesc); 538 } 539 if(${$ostr} =~ /\.\.\.\.lastsect\.\.\.\./) { 540 if(!$dosecttest) {$sectstrstatic = ""} 541 elsif($sectstrstatic !~ /[^ ]$/) {$sectstrstatic = ""} 542 else {$sectstrstatic .= "</table>\n"} 543 ${$ostr} =~ s/[.]+lastsect[.]+/$sectstrstatic\n/; 544 } 545 my $mysname = $mysect; 546 $mysname =~ s/\s+/_/; 547 ${$ostr} .= "<hr><h3><a name=\"sec_$mysname\">\n"; 548 ${$ostr} .= "Section: $mysect</a></h3>\n"; 549 ${$ostr} .= "$mysrest\n"; 550 ${$ostr} .= "....lastsect...."; 551 $laststatfsect = $mysect; 552 553 my $catdesc = ""; 554 if(defined($fctype)) {$catdesc = "Category: '$fctype'"} 555 if(defined($categs{$fctype})) {$catdesc = $categs{$fctype}} 556 $datastrstatic .= "<tr><td> <a href=#sec_$mysname>$mysect</a></td><td>$catdesc</td></tr>\n"; 557 } 558} 559 560sub printdata($$) { 561 my ($mydata,$mydrest) = @_; 562 if ($mydata ne $lastdsect) { 563 if(${$ostr} =~ /\.\.\.\.lastdata\.\.\.\./) { 564 if(!$dosecttest) {$datastr = ""} 565 elsif($datastr !~ /[^ ]$/) {$datastr = ""} 566 else {$datastr .= "</table>\n"} 567 ${$ostr} =~ s/[.]+lastdata[.]+/$datastr\n/; 568 } 569 my $mydname = $mydata; 570 $mydname =~ s/\s+/_/; 571 ${$ostr} .= "<hr><h2><a name=\"data_$mydname\">\n"; 572 ${$ostr} .= "Datatype: $mydata</a></h2>\n"; 573 ${$ostr} .= "$mydrest\n"; 574 ${$ostr} .= "....lastdata...."; 575 $lastdsect = $mydata; 576 577 $filestr .= "<tr><td> <a href=#data_$mydname>$mydata</a> </td><td>$datashortdesc</td></tr>\n"; 578 } 579} 580 581sub printdatastatic($$) { 582 my ($mydata, $mydrest) = @_; 583 if ($mydata ne $laststatdsect) { 584 if(${$ostr} =~ /\.\.\.\.lastdata\.\.\.\./) { 585 if(!$dosecttest) {$datastrstatic = ""} 586 elsif($datastrstatic !~ /[^ ]$/) {$datastrstatic = ""} 587 else {$datastrstatic .= "</table>\n"} 588 ${$ostr} =~ s/[.]+lastdata[.]+/$datastrstatic\n/; 589 } 590 my $mydname = $mydata; 591 $mydname =~ s/\s+/_/; 592 ${$ostr} .= "<hr><h2><a name=\"data_$mydname\">\n"; 593 ${$ostr} .= "Datatype: $mydata</a></h2>\n"; 594 ${$ostr} .= "Datatype: $mydata</a></h2>\n"; 595 ${$ostr} .= "$mydrest\n"; 596 ${$ostr} .= "....lastdata...."; 597 $laststatdsect = $mydata; 598 599 $filestrstatic .= "<tr><td> <a href=#data_$mydname>$mydata</a> </td><td>$datashortdesc</td></tr>\n"; 600 } 601} 602 603$pubout = "public"; 604$local = "local"; 605$infile = ""; 606$lib = "unknown"; 607$countglobal=0; 608$countstatic=0; 609$countsection = 0; 610 611@namrules = (); 612@sufname = (); 613@datalist = (); 614$namrulesfilecount=$#namrules; 615$namrulesdatacount=$#namrules; 616$suffixfilecount=$#sufname; 617$suffixdatacount=$#sufname; 618 619$dosecttest = 0; 620$datatype="undefined"; 621$unused = ""; 622$inline = ""; 623$flastname = 0; 624 625$filestr = "<p><b>Datatypes:</b>\n<table> "; 626$filestrstatic = "<p><b>Datatypes:</b>\n<table> "; 627 628$ftable = ""; 629 630$lastfname = ""; 631 632### cppreserved is a list of C++ reserved words not to be used as param names. 633### test is whether to test the return etc. 634### body is whether to print the body code 635 636%cppreserved = ("this" => "thys", "bool" => "boule", "string" => "strng"); 637%test = ("func" => 1, "funcstatic" => 1, "funclist" => 0, "prog" => 0); 638%body = ("func" => 1, "funcstatic" => 1, "funclist" => 1, "prog" => 1); 639 640%categs = ("new" => "Constructors", 641 "delete" => "Destructors", 642 "assign" => "Assignments", 643 "modify" => "Modifiers", 644 "cast" => "Casts", 645 "derive" => "Derievd values", 646 "use" => "General use", 647 "iterate" => "Iterators", 648 "input" => "Input", 649 "output" => "Output", 650 "misc" => "Miscellaneous", 651 "internals" => "Internals"); 652%ctot = (); 653if ($ARGV[0]) {$infile = $ARGV[0];} 654if ($ARGV[1]) {$lib = $ARGV[1];} 655 656foreach $x ("short", "int", "long", "float", "double", "char", 657 "size_t", "time_t", 658 "unsigned", "unsigned char", 659 "unsigned short", "unsigned int", 660 "unsigned long", "unsigned long int") { 661 $simpletype{$x} = 1; 662} 663 664foreach $x ("ajshort", "ajushort", "ajint", "ajuint", "ajlong", "ajulong", 665 "jobject", "jstring", "jboolean", "jclass", "jint", "jbyteArray", 666 "AjBool", "AjStatus", "BOOL", "AjEnum", "PLFLT", "PLINT", 667 "VALIST", "AjEQryLink") { 668 $simpletype{$x} = 1; 669} 670 671foreach $x ("CallFunc", "AjMessVoidRoutine", "AjMessOutRoutine") { 672 $functype{$x} = 1; 673} 674 675foreach $x ("datastatic", "conststatic", "const", "alias", "attr") { 676 $datatoken{$x} = 1; 677} 678 679foreach $x("plus") { 680 $ignore{$x} = 1; 681} 682 683$source = ""; 684 685if ($infile) { 686 (undef, $dir, $pubout) = ($infile =~ /^(([^\/.]*)\/)*([^\/.]+)(\.\S+)?$/); 687## ($dummy, $dir, $pubout) = ($infile =~ /(([^\/.]+)\/)?([^\/.]+)(\.\S+)?$/); 688 $local = $pubout; 689 if ($dir) {$lib = $dir} 690 print "set pubout '$pubout' lib '$lib'\n"; 691 open (INFILE, "$infile") || die "Cannot open $infile"; 692 $linenum=0; 693 while (<INFILE>) { 694 $linenum++; 695 if(length($_) > 81) { 696 printf "%s %d: length %d\n", 697 $infile, $linenum, length($_); 698 } 699 $source .= $_ 700 } 701} 702else { 703 while (<>) {$source .= $_} 704} 705 706open (BOOK, ">$pubout.book"); 707open (OBS, ">>deprecated.new"); 708print OBS "#$pubout\n"; 709open (HTML, ">$pubout.html"); 710open (HTMLB, ">$local\_static.html"); 711open (SRS, ">$pubout.srs"); 712open (LOG, ">$local.log"); 713 714$file = "$pubout\.c"; 715$title = "$file"; 716$out=""; 717$outstatic=""; 718$out .= "<html><head><title>$title</title></head>\n"; 719$out .= "<body bgcolor=\"#ffffff\">\n"; 720$outstatic .= "<html><head><title>$title</title></head>\n"; 721$outstatic .= "<body bgcolor=\"#ffffff\">\n"; 722 723$out .= "<h1>$file</h1>\n...lastfile..."; 724$outstatic .= "<h1>$file</h1>\n...lastfile..."; 725 726$sect = $lastfsect = $laststatfsect = ""; 727$datasect = $lastdsect = $laststatdsect = ""; 728$mainprog = 0; 729$functot = 0; 730$datanum=0; 731$secnum=0; 732$bookstr = "$pubout\.c\n"; 733$datastr = " "; 734$datastrstatic = " "; 735$sectstr = " "; 736$sectstrstatic = " "; 737$fnum=0; 738$ostr = \$out; 739$datatitle = ""; 740$fctype = ""; 741$indep=0; 742$indepbook=0; 743 744############################################################## 745## $source is the entire source file as a string with newlines 746## step through each comment 747## looking for extended JavaDoc style formatting 748## $ccfull is the comment 749## $rest is the rest of the file 750############################################################## 751 752# Process an entire block 753# We process each part below 754 755$fdata = ""; 756 757while ($source =~ m"((\s+)([#]if[^\n]+\n)?)([/][*][^*]*[*]+([^/*][^*]*[*]+)*[/])"gos) { 758 $partnum=0; 759 $mastertoken="undefined"; 760 $prespace = $2; 761 $ifdef = $3; 762 $ccfull = $4; 763 $rest = $POSTMATCH; 764 $pref = $PREMATCH; 765 766 if($indepbook && $ccfull =~ /@/ && $pref =~ /#endif\s*\Z/om) { 767 $indepbook=0; 768# print "unset indepbook\n"; 769 } 770 if($indep && $ccfull =~ /@/ && $pref =~ /#endif\s*\Z/om) { 771 $indep=0; 772 print "unset indep pref '$ccfull'\n"; 773 } 774 775 if(defined($ifdef)){ 776# print "ifdef '$ifdef'\n"; 777 if(!$indepbook && $ifdef =~ /AJ_COMPILE_DEPRECATED_BOOK/g) { 778 $indepbook=1; 779# print "set indepbook\n"; 780 } 781 if(!$indep && $ifdef =~ /AJ_COMPILE_DEPRECATED\n/g) { 782 $indep=1; 783# print "set indep\n"; 784 } 785 } 786 787 ($cc) = ($ccfull =~ /^..\s*(.*\S)*\s*..$/gos); 788 if (defined($cc)) { 789 $cc =~ s/[* ]*\n[* ]*/\n/gos; 790 $cc = " ".$cc; 791 } 792 else { 793 $cc = ""; 794 } 795 $type = ""; 796 $acnt = 0; 797 $rtype = ""; 798 $ismacro = 0; 799 $isprog = 0; 800 $islist = 0; 801 @largs = (); 802 @savecode = (); 803 @savevar = (); 804 @savecast = (); 805 @savedesc = (); 806 $inputargs = ""; 807 $outputargs = ""; 808 $modifyargs = ""; 809 $returnargs = ""; 810 $longdesc = ""; 811 $shortdesc = ""; 812 $usetext = "See source code"; 813 $exampletext = "In preparation"; 814 $errtext = "See source code"; 815 $dependtext = "See source code"; 816 $othertext = "See other functions in this section"; 817 $availtext = "In release 6.5.0"; 818 $ctype = ""; 819 820 while ($cc =~ m/\s@((\S+)\s+([^@]*[^@\s]))/gos) { 821 $data = $1; 822 $token = $2; 823 #print "<$token>\n"; 824 #print "$data\n"; 825 826 if(!$partnum) {$mastertoken = $token} 827 $partnum++; 828 829 if ($token eq "section") { 830 $secnum++; 831 if($out =~ /\.\.\.\.lastsect\.\.\.\./) { 832 if($sectstr !~ /[^ ]$/) {$sectstr = ""} 833 else {$sectstr .= "</table>\n"} 834 $out =~ s/\.\.\.\.lastsect\.\.\.\./$sectstr\n/; 835 } 836 if($outstatic =~ /\.\.\.\.lastsect\.\.\.\./) { 837 if($sectstrstatic !~ /[^ ]$/) {$sectstrstatic = ""} 838 else {$sectstrstatic .= "</table>\n"} 839 $outstatic =~ s/\.\.\.\.lastsect\.\.\.\./$sectstrstatic\n/; 840 } 841 $sectstr = "<p><b>Functions:</b>\n<table> "; 842 $sectstrstatic = "<p><b>Functions:</b>\n<table> "; 843 844 $ostr = \$out; 845 $countglobal++; 846 if($dosecttest && $sect ne "") { 847 if($countsection == 0 && $countstatic == 0) { 848 print "bad section: '$sect' has no public or static functions\n"; 849 } 850 } 851 $countsection = 0; 852 ($sect, $srest) = ($data =~ /\S+\s+([^*\n]+)\s*(.*)/gos); 853 if(!defined($sect)) { 854 print "bad section: cannot parse '$data'\n"; 855 } 856 $sect =~ s/\s+/ /gos; 857 $sect =~ s/^ //gos; 858 $sect =~ s/ $//gos; 859 $srest =~ s/>/\>/gos; 860 $srest =~ s/</\</gos; 861 $srest =~ s/\n\n/\n<p>\n/gos; 862 $srest =~ s/{([^\}]+)}/<a href="#$1">$1<\/a>/gos; 863 print "\nSection $sect\n"; 864 print "-----------------------------\n"; 865 866 if($prespace !~ /^\n\n\n\n\n$/) { 867 if($prespace =~ /^[\n]+$/) { 868 $whitelen = length($&) - 1; 869 print "bad whitespace $whitelen lines at start\n"; 870 } 871 elsif ($prespace =~ / /) { 872 print "bad whitespace has space(s) at start\n"; 873 } 874 elsif ($prespace =~ /\t/) { 875 print "bad whitespace has tab(s) at start\n"; 876 } 877 else { 878 print "bad whitespace at start\n"; 879 } 880 } 881 882 $bookstr .= "\n section: $sect\n"; 883 884 push (@{$datasect{$datatitle}}, $sect); 885 $datasub = "$datatitle - $sect"; 886 @{$datafunc{$datasub}} = (); 887 888 if($dosecttest) { 889 @argnumb = (); 890 @argpref = (); 891 @argname = (); 892 @argtype = (); 893 @argdesc = (); 894 @valname = (); 895 @valtype = (); 896 $lastfname = ""; 897 $fdata = ""; 898 $ctype = ""; 899 $fctype = ""; 900 splice(@namrules, 1+$namrulesdatacount); 901 splice(@namdescs, 1+$namrulesdatacount); 902 splice(@sufname, 1+$suffixdatacount); 903 splice(@sufdesc, 1+$suffixdatacount); 904 } 905 } 906 907 elsif ($token eq "fdata") { 908 $dosecttest = 1; 909 if($mastertoken ne "section") { 910 print "bad syntax \@$token must be in \@section\n"; 911 } 912 ($fdata) = 913 ($data =~ /^\S+\s+[\[]([^\]]+)[\]]\s*(.*)/gos); 914 if(!defined($fdata)) { 915 print "bad fdata: $data\n"; 916 } 917 elsif($fdata ne $datatype) { 918 print "bad fdata <$fdata> <$datatype>\n"; 919 } 920 } 921 922 elsif ($token eq "datasection") { 923 $datanum++; 924 if($out =~ /\.\.\.\.lastdata\.\.\.\./) { 925 if($datastr !~ /[^ ]$/) {$datastr = ""} 926 else {$datastr .= "</table>\n"} 927 $out =~ s/\.\.\.\.lastdata\.\.\.\./$datastr\n/; 928 } 929 if($outstatic =~ /\.\.\.\.lastdata\.\.\.\./) { 930 if($datastrstatic !~ /[^ ]$/) {$datastrstatic = ""} 931 else {$datastrstatic .= "</table>\n"} 932 $outstatic =~ s/\.\.\.\.lastdata\.\.\.\./$datastrstatic\n/; 933 } 934 $datastr = "<p><b>Sections:</b>\n<table> "; 935 $datastrstatic = "<p><b>Sections:</b>\n<table> "; 936 937 $secnum=0; 938 $fnum=0; 939 $dosecttest = 1; 940 if($partnum != 1) { 941 print "bad syntax \@$token must be at start\n"; 942 } 943 $flastname = ""; 944 ($datatype, $datashortdesc, $datadesc) = 945 ($data =~ /\S+\s+[\[]([^\]]+)[\]]\s*([^*\n]+)[*\n]*(.*)/gos); 946 if(!defined($datadesc)) { 947 print "bad datasection: $data\n"; 948 next; 949 } 950 $dataname = $datatype; 951 $dataname =~ s/\s+/ /gos; 952 $dataname =~ s/^ //gos; 953 $dataname =~ s/ $//gos; 954 $datadesc =~ s/\s+/ /gos; 955 $datadesc =~ s/^ //gos; 956 $datadesc =~ s/ $//gos; 957 958 $datatitle = "$dataname: $datashortdesc"; 959 push (@datalist, "$datatitle"); 960 961 @{ $datasect{$datatitle} } = (); 962 $datastr = "<p><b>Sections:</b>\n<table> "; 963 $datastrstatic = "<p><b>Sections:</b>\n<table> "; 964 965 if($prespace !~ /^\n\n\n\n\n$/) { 966 print "Datasection '$datatype' '$datadesc'\n"; 967 if($prespace =~ /^[\n]+$/) { 968 $whitelen = length($&) - 1; 969 print "bad whitespace $whitelen lines at start\n"; 970 } 971 elsif ($prespace =~ / /) { 972 print "bad whitespace has space(s) at start\n"; 973 } 974 elsif ($prespace =~ /\t/) { 975 print "bad whitespace has tab(s) at start\n"; 976 } 977 else { 978 print "bad whitespace at start\n"; 979 } 980 } 981 982 $bookstr .= " $dataname\n $datadesc\n"; 983 splice(@namrules, 1+$namrulesfilecount); 984 splice(@namdescs, 1+$namrulesfilecount); 985 splice(@sufname, 1+$suffixfilecount); 986 splice(@sufdesc, 1+$suffixfilecount); 987 } 988 989 elsif ($token eq "filesection") { 990 $dosecttest = 1; 991 if($partnum != 1) { 992 print "bad syntax \@$token must be at start\n"; 993 } 994 ($sname, $norest) = 995 ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 996 $flastname = ""; 997 splice (@namrules, 0); 998 999 if($prespace !~ /^\n\n\n\n\n$/) { 1000 print "Filesection $sname\n"; 1001 if($prespace =~ /^[\n]+$/) { 1002 $whitelen = length($&) - 1; 1003 print "bad whitespace $whitelen lines at start\n"; 1004 } 1005 elsif ($prespace =~ / /) { 1006 print "bad whitespace has space(s) at start\n"; 1007 } 1008 elsif ($prespace =~ /\t/) { 1009 print "bad whitespace has tab(s) at start\n"; 1010 } 1011 else { 1012 print "bad whitespace at start\n"; 1013 } 1014 } 1015 1016 } 1017 1018 elsif ($token eq "fnote") { 1019 if($mastertoken ne "section") { 1020 print "bad syntax \@$token must be in \@section\n"; 1021 } 1022 } 1023 1024 elsif ($token eq "suffix") { 1025 # can be on its own or in a block? 1026 ($sufname,$sufdesc) = 1027 ($data =~ /\S+\s+(\S+)\s+(.*)/gos); 1028 push(@sufname, $sufname); 1029 push(@sufdesc, $sufdesc); 1030 } 1031 1032 elsif ($token =~ /^nam([1-9])rule$/) { 1033 if($mastertoken ne "section" && 1034 $mastertoken ne "filesection" && 1035 $mastertoken ne "datasection") { 1036 print "bad syntax \@$token must be in \@filesection, \@datasection or \@section\n"; 1037 } 1038 $i = $1 - 1; 1039 ($namrule, $namdesc) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1040 if(!defined($namdesc)) { 1041 print "bad namrule: $data\n"; 1042 next; 1043 } 1044 print LOG "defined nam$i"."rule '$namrule'\n"; 1045 $namdesc =~ s/\n//; 1046 $namdesc =~ s/[.]$//; 1047 push(@{$namrules[$i]},$namrule); 1048 push(@{$namdescs[$i]},$namdesc); 1049 } 1050 1051 elsif ($token eq "valrule") { 1052 if($mastertoken ne "section") { 1053 print "bad syntax \@$token must be in \@section\n"; 1054 } 1055 ($valname,$valtype,$valdesc) = 1056 ($data =~ /\S+\s+(\S+)\s+[\[]([^\]]+)[\]]\s*(.*)/gos); 1057 if(!defined($valdesc)) { 1058 print "bad valrule: $data\n"; 1059 next; 1060 } 1061 $valdesc =~ s/\n//; 1062 $valdesc =~ s/[.]$//; 1063 push (@valname, $valname); 1064 push (@valtype, $valtype); 1065 push (@valdesc, $valdesc); 1066 } 1067 1068 elsif ($token =~ /^arg(\d?)rule$/) { 1069 if($mastertoken ne "section") { 1070 print "bad syntax \@$token must be in \@section\n"; 1071 } 1072 $argnumb = $1; 1073 if ($argnumb ne "") { 1074 print LOG "$token argnumb: $argnumb\n"; 1075 } 1076 ($argpref, $argname, $argtype, $argdesc) = 1077 ($data =~ /\S+\s+(\S+)\s+(\S+)\s+[\[]([^\]]+[\]]?)[\]]\s*(.*)/gos); 1078 if(!defined($argdesc)) { 1079 print "bad argrule: $data\n"; 1080 next; 1081 } 1082 $argdesc =~ s/\n//; 1083 $argdesc =~ s/[.]$//; 1084 push (@argnumb, $argnumb); 1085 push (@argpref, $argpref); 1086 push (@argname, $argname); 1087 push (@argtype, $argtype); 1088 push (@argdesc, $argdesc); 1089 } 1090 1091 elsif (!$dosecttest && $token eq "section") { 1092 if($partnum != 1) { 1093 print "bad syntax \@$token must be at start\n"; 1094 } 1095 $out = \$out; 1096 $countglobal++; 1097 ($sect, $srest) = ($data =~ /\S+\s+([^*\n]+)\s*(.*)/gos); 1098 $sect =~ s/\s+/ /gos; 1099 $sect =~ s/^ //gos; 1100 $sect =~ s/ $//gos; 1101 $srest =~ s/>/\>/gos; 1102 $srest =~ s/</\</gos; 1103 $srest =~ s/\n\n/\n<p>\n/gos; 1104 $srest =~ s/{([^\}]+)}/<a href="#$1">$1<\/a>/gos; 1105 print "Section $sect\n"; 1106 } 1107 1108 elsif ($token eq "func" || $token eq "prog") { 1109 if($partnum != 1) { 1110 print "bad syntax \@$token must be at start\n"; 1111 } 1112 $ismacro = 0; 1113 $isprog = 0; 1114 $fnum++; 1115 if ($token eq "prog") { 1116 $isprog = 1; 1117 $mainprog=1; 1118 if($functot) { 1119 print "bad ordering - main program should come first\n"; 1120 } 1121 } 1122 if($mainprog && !$isprog) { 1123 print "bad function prototype: not static after main program\n"; 1124 } 1125 $ostr = \$out; 1126 $countglobal++; 1127 $functot++; 1128 if($sect ne "") {$countsection++;} 1129 1130 printsect($sect,$srest); 1131 1132 $testrest = $rest; 1133 $testrest =~ s/[\(]assert[\)]/assert/; 1134 $type = $token; 1135 ($name, $frest) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1136 ($ftype,$fname, $fargs) = 1137 $testrest =~ /^\s*([^\(\)]+[^\(\)\s])\s+([^\(\)]+[^\(\)\s]+)\s*[\(]\s*([^{]*)[)]\s*[\{]/os; 1138 if(!defined($ftype)){ 1139 print "bad \@$type header\n"; 1140 } 1141 $ftype =~ s/^inline\s+//; 1142 $ftype =~ s/^__noreturn\s+//; 1143 if($isprog) {$progname = $name} 1144 elsif(defined($datasub)) { 1145 push(@{$datafunc{$datasub}}, "$name"); 1146 } 1147 print "Function $name\n"; 1148 ${$ostr} .= "<hr><h4><a name=\"$name\">\n"; 1149 ${$ostr} .= "Function</a> ".srsref($name)."</h4>\n"; 1150 1151 if($prespace !~ /^\n\n\n\n\n$/) { 1152 if($prespace =~ /^[\n]+$/) { 1153 $whitelen = length($&) - 1; 1154 print "bad whitespace $whitelen lines at start\n"; 1155 } 1156 elsif ($prespace =~ / /) { 1157 print "bad whitespace has space(s) at start\n"; 1158 } 1159 elsif ($prespace =~ /\t/) { 1160 print "bad whitespace has tab(s) at start\n"; 1161 } 1162 else { 1163 print "bad whitespace at start\n"; 1164 } 1165 } 1166 1167 if(!defined($fargs)) { 1168 print "bad function prototype: not parsed\n"; 1169 $ftype = "unknown"; 1170 $fname = "unknown"; 1171 next; 1172 } 1173 if ($isprog && $fname eq "main") {$fname = $pubout} 1174 $trest = $frest; 1175 #if($frest =~ /<(.*)>/) {print "bad HTML tag <$1>\n"} 1176 $frest =~ s/>/\>/gos; 1177 $frest =~ s/</\</gos; 1178 $frest =~ s/\n\n/\n<p>\n/gos; 1179 #${$ostr} .= "$frest\n"; 1180 $longdesc = $frest; 1181 $shortdesc = $frest; 1182 $shortdesc =~ s/\n<p>.*//gos; 1183 1184 $sectstr .= "<tr><td> <a href=#$name>$name</a></td><td>$shortdesc</td></td></tr>\n"; 1185 print SRS "ID $name\n"; 1186 print SRS "TY public\n"; 1187 print SRS "MO $pubout\n"; 1188 print SRS "LB $lib\n"; 1189 print SRS "XX\n"; 1190 1191 $ftype =~ s/\s+/ /gos; 1192 $ftype =~ s/ \*/\*/gos; 1193 $fname =~ s/^[\(]//gos; 1194 $fname =~ s/[\)]$//gos; 1195 if ($fname =~ /^Java_org.*Ajax_([^_]+)$/) { 1196 $fname = "Ajax.".$1; 1197 if ($ftype =~ /JNIEXPORT+\s+(\S+)\s+JNICALL/) { 1198 $ftype = $1; 1199 } 1200 } 1201 if ($isprog && $ftype ne "int") {print "bad main type (not int)\n"} 1202 if (!$ftype) {print "bad function definition\n"} 1203 if ($fname ne $name) {print "bad function name <$name> <$fname>\n"} 1204 if (!$frest) {print "bad function '$name', no description\n"} 1205 1206 $trest =~ s/\n\n+$/\n/gos; 1207 $trest =~ s/\n\n\n+/\n\n/gos; 1208 $trest =~ s/\n([^\n])/\nDE $1/gos; 1209 $trest =~ s/\n\n/\nDE\n/gos; 1210 $trest =~ s/>/\>/gos; 1211 $trest =~ s/</\</gos; 1212 chomp $trest; 1213 print SRS "DE $trest\n"; 1214 print SRS "XX\n"; 1215 1216 $fargs =~ s/\s+/ /gos; # all whitespace is one space 1217 $fargs =~ s/ ,/,/gos; # no space before comma 1218 $fargs =~ s/, /,/gos; # no space after comma 1219 $fargs =~ s/ *(\w+) *((\[[^\]]*\])+)/$2 $1/gos; # [] before name 1220 $fargs =~ s/(\*+)(\S)/$1 $2/g; # put space after run of * 1221 $fargs =~ s/ \*/\*/gos; # no space before run of * 1222 $fargs =~ s/ [\(]\* (\w+)[\)]/ $1/gos; # remove fn arguments 1223 $fargs =~ s/(\w+)\s?[\(][^\)]+[\)],/function $1,/gos; # ditto 1224 $fargs =~ s/(\w+)\s?[\(][^\)]+[\)]$/function $1/gos; # ditto 1225 $fargs =~ s/\s*\(\*(\w+)[^\)]*\)/\* $1/gs; 1226# print "**functype <$ftype> fname <$fname> fargs <$fargs>\n"; 1227 @largs = split(/,/, $fargs); 1228# foreach $x (@largs) { 1229# print "<$x> "; 1230# } 1231# print "\n"; 1232# print "-----------------------------\n"; 1233 $bookstr .= sprintf "%-15s %s (", $ftype, $fname; 1234 $ia = 0; 1235 foreach $f (split(/,/,$fargs)) { 1236 if($ia++) {$bookstr .= ", "} 1237 $bookstr .= $f; 1238 } 1239 $bookstr .= ");\n"; 1240 } 1241 1242 elsif ($token eq "funcstatic") { 1243 if($partnum != 1) { 1244 print "bad syntax \@$token must be at start\n"; 1245 } 1246 $ismacro = 0; 1247 $isprog = 0; 1248 $fnum++; 1249 $ostr = \$outstatic; 1250 $countstatic++; 1251 1252 printsectstatic($sect, $srest); 1253 1254 $type = $token; 1255 ($name, $frest) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1256 ($unused,$inline,$ftype,$fname,$fargs) = 1257 $rest =~ /^\s*(__noreturn\s*)?static\s+(inline\s+)?([^\(\)]+[^\(\)\s])\s+([^\(\)]+[^\(\)\s]+)\s*[\(]\s*([^{]*)[)]\s*[\{]/os; 1258 $ftype =~ s/^inline\s+//; 1259 if(!defined($fname)){ 1260 print "bad \@$type header\n"; 1261 } 1262 print "Static function $name\n"; 1263 1264 if($prespace !~ /^\n\n\n\n\n$/) { 1265 if($prespace =~ /^[\n]+$/) { 1266 $whitelen = length($&) - 1; 1267 print "bad whitespace $whitelen lines at start\n"; 1268 } 1269 else { 1270 print "bad whitespace at start\n"; 1271 } 1272 } 1273 1274 ${$ostr} .= "<hr><h4><a name=\"$name\">\n"; 1275 ${$ostr} .= "Static function</a> ".srsref($name)."</h4>\n"; 1276 if(!defined($ftype)){ 1277 print "bad static function prototype: not parsed\n"; 1278 next; 1279 } 1280 if($mainprog) { 1281 if($name !~ /^$progname[_A-Z]/) { 1282 print "bad name expected prefix '$progname\_'\n"; 1283 } 1284 } 1285 $trest = $frest; 1286 #if($frest =~ /<(.*)>/) {print "bad HTML tag <$1>\n"} 1287 $frest =~ s/>/\>/gos; 1288 $frest =~ s/</\</gos; 1289 $frest =~ s/\n\n/\n<p>\n/gos; 1290 #${$ostr} .= "$frest\n"; 1291 $longdesc = $frest; 1292 $shortdesc = $frest; 1293 $shortdesc =~ s/\n<p>.*//gos; 1294 $sectstrstatic .= "<tr><td> <a href=#$name>$name</a></td><td>$shortdesc</td></td></tr>\n"; 1295 1296 print SRS "ID $name\n"; 1297 print SRS "TY static\n"; 1298 print SRS "MO $pubout\n"; 1299 print SRS "LB $lib\n"; 1300 print SRS "XX\n"; 1301 1302 if ($fname ne $name) {print "bad function name <$name> <$fname>\n"} 1303 if (!$frest) {print "bad function '$name', no description\n"} 1304 1305 $ftype =~ s/\s+/ /gos; 1306 $ftype =~ s/ \*/\*/gos; 1307 1308 $trest =~ s/\n\n+$/\n/gos; 1309 $trest =~ s/\n\n\n+/\n\n/gos; 1310 $trest =~ s/\n([^\n])/\nDE $1/gos; 1311 $trest =~ s/\n\n/\nDE\n/gos; 1312 $trest =~ s/>/\>/gos; 1313 $trest =~ s/</\</gos; 1314 chomp $trest; 1315 print SRS "DE $trest\n"; 1316 print SRS "XX\n"; 1317 1318 1319 $fargs =~ s/\s+/ /gos; # all whitespace is one space 1320 $fargs =~ s/ ,/,/gos; # no space before comma 1321 $fargs =~ s/, /,/gos; # no space after comma 1322 $fargs =~ s/ *(\w+) *((\[[^\]]*\])+)/$2 $1/gos; # [] before name 1323 $fargs =~ s/(\*+)(\S)/$1 $2/g; # put space after run of * 1324 $fargs =~ s/ \*/\*/gos; # no space before run of * 1325 $fargs =~ s/ [\(]\* (\w+)[\)]/ $1/gos; # remove fn arguments 1326 $fargs =~ s/(\w+)\s?[\(][^\)]+[\)],/function $1,/gos; # ditto 1327 $fargs =~ s/(\w+)\s?[\(][^\)]+[\)]$/function $1/gos; # ditto 1328 $fargs =~ s/\s*\(\*(\w+)[^\)]*\)/\* $1/gs; 1329 @largs = split(/,/, $fargs); 1330 } 1331 1332 elsif ($token eq "macro") { 1333 if($partnum != 1) { 1334 print "bad syntax \@$token must be at start\n"; 1335 } 1336 $fnum++; 1337 $ismacro = 1; 1338 $ostr = \$out; 1339 $countglobal++; 1340 if($sect ne "") {$countsection++;} 1341 1342 printsect($sect,$srest); 1343 1344 $type = $token; 1345 ($name, $mrest) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1346 $fname = $name; 1347 print "Macro $name\n"; 1348 1349 if($prespace !~ /^\n\n\n\n\n$/) { 1350 if($prespace =~ /^[\n]+$/) { 1351 $whitelen = length($&) - 1; 1352 print "bad whitespace $whitelen lines at start\n"; 1353 } 1354 else { 1355 print "bad whitespace at start\n"; 1356 } 1357 } 1358 1359 $sectstr .= "<tr><td> <a href=#$name>$name</a></td></tr>\n"; 1360 ### print "args '$margs'\n"; 1361 ${$ostr} .= "<hr><h4><a name=\"$name\">\n"; 1362 ${$ostr} .= "Macro</a> ".srsref($name)."</h4>\n"; 1363 $trest = $mrest; 1364 #if($mrest =~ /<(.*)>/) {print "bad HTML tag <$1>\n"} 1365 $mrest =~ s/>/\>/gos; 1366 $mrest =~ s/</\</gos; 1367 $mrest =~ s/\n\n/\n<p>\n/gos; 1368 #${$ostr} .= "$mrest\n"; 1369 $longdesc = $mrest; 1370 $shortdesc = $mrest; 1371 $shortdesc =~ s/\n<p>.*\n//gos; 1372 1373 $bookmacro = $fname; 1374 @bookmacroparams = (); 1375 print SRS "ID $name\n"; 1376 print SRS "TY macro\n"; 1377 print SRS "MO $pubout\n"; 1378 print SRS "LB $lib\n"; 1379 print SRS "XX\n"; 1380 1381# $ftype =~ s/\s+/ /gos; 1382# $ftype =~ s/ \*/\*/gos; 1383# if (!$ftype) {print "bad macro definition\n"} 1384# if ($fname ne $name) {print "bad macro name <$name> <$fname>\n"} 1385# if (!$frest) {print "bad macro '$name', no description\n"} 1386 1387 $trest =~ s/\n\n+$/\n/gos; 1388 $trest =~ s/\n\n\n+/\n\n/gos; 1389 $trest =~ s/\n([^\n])/\nDE $1/gos; 1390 $trest =~ s/\n\n/\nDE\n/gos; 1391 $trest =~ s/>/\>/gos; 1392 $trest =~ s/</\</gos; 1393 chomp $trest; 1394 print SRS "DE $trest\n"; 1395 print SRS "XX\n"; 1396 } 1397 1398 elsif ($token eq "funclist") { 1399 if($partnum != 1) { 1400 print "bad syntax \@$token must be at start\n"; 1401 } 1402 $fnum++; 1403 $ismacro = 0; 1404 $isprog = 0; 1405 $islist = 1; 1406 $ostr = \$outstatic; 1407 $countstatic++; 1408 1409 printsectstatic($sect, $srest); 1410 1411 $type = $token; 1412 ($name, $mrest) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1413 print "Function list $name\n"; 1414 1415 if($prespace !~ /^\n\n\n\n\n$/) { 1416 if($prespace =~ /^[\n]+$/) { 1417 $whitelen = length($&) - 1; 1418 print "bad whitespace $whitelen lines at start\n"; 1419 } 1420 else { 1421 print "bad whitespace at start\n"; 1422 } 1423 } 1424 1425 $sectstrstatic .= "<tr><td> <a href=#$name>$name</a></td></tr>\n"; 1426 ${$ostr} .= "<hr><h4><a name=\"$name\">\n"; 1427 ${$ostr} .= "Function list</a> ".srsref($name)."</h4>\n"; 1428 $trest = $mrest; 1429 #if($mrest =~ /<(.*)>/) {print "bad HTML tag <$1>\n"} 1430 $mrest =~ s/>/\>/gos; 1431 $mrest =~ s/</\</gos; 1432 $mrest =~ s/\n\n/\n<p>\n/gos; 1433 #${$ostr} .= "$mrest\n"; 1434 $longdesc = $mrest; 1435 $shortdesc = $mrest; 1436 $shortdesc =~ s/\n<p>.*\n//gos; 1437 1438 print SRS "ID $name\n"; 1439 print SRS "TY list\n"; 1440 print SRS "MO $pubout\n"; 1441 print SRS "LB $lib\n"; 1442 print SRS "XX\n"; 1443 1444 $trest =~ s/\n\n+$/\n/gos; 1445 $trest =~ s/\n\n\n+/\n\n/gos; 1446 $trest =~ s/\n([^\n])/\nDE $1/gos; 1447 $trest =~ s/\n\n/\nDE\n/gos; 1448 $trest =~ s/>/\>/gos; 1449 $trest =~ s/</\</gos; 1450 chomp $trest; 1451 print SRS "DE $trest\n"; 1452 print SRS "XX\n"; 1453 } 1454 1455 elsif ($token eq "param") { 1456 if($mastertoken ne "func" && 1457 $mastertoken ne "funcstatic" && 1458 $mastertoken ne "macro" && 1459 $mastertoken ne "funclist") { 1460 print "bad syntax \@$token must be in \@func, funcstatic, funclist or macro\n"; 1461 } 1462 if (!$intable) { 1463 $ftable = "<p><table border=1>\n"; 1464 $ftable .= "<tr><th>Type</th><th>Name</th><th>Read/Write</th><th>Description</th></tr>\n"; 1465 $intable = 1; 1466 } 1467 ($code,$var,$cast, $prest) = ($data =~ m/[\[]([^\]]+)[\]]\s*(\S*)\s*[\[]([^\]]+[\]]?)[\]]\s*(.*)/gos); 1468 if (!defined($code)) { 1469 print "bad paramsyntax:\n$data"; 1470 next; 1471 } 1472 1473 if($prest =~ /([^\{]+)[\{]([^\}]+)[\}]/) { 1474 if($usetext eq "See source code") {$usetext = ""} 1475 else {$usetext .= "<p>\n"} 1476 $usetext .= "<b>$var:</b> $2\n"; 1477 $prest = $1; 1478 } 1479 1480# print "code: <$code> var: <$var> cast: <$cast>\n"; 1481# print "-----------------------------\n"; 1482 $cast =~ s/ \*/\*/gos; # no space before run of * 1483 $cast =~ s/\{/\[/gos; # brackets fixed 1484 $cast =~ s/\}/\]/gos; # brackets fixed 1485 1486 if ($code !~ /^[rwufdvo?][CENP]*$/) { # deleted OSU (all unused) 1487 print "bad code <$code> var: <$var>\n"; 1488 } 1489 elsif ($code =~ /^.([CENP]+)$/){ 1490 {$countcode{$1}++} 1491 } 1492 1493 if($code =~ /^[rfv]/) { 1494 if($code =~ /^r/) {$codename = "Input"} 1495 elsif($code =~ /^f/) {$codename = "Function"} 1496 elsif($code =~ /^v/) {$codename = "Vararg"} 1497 $inputargs .= "<tr><td><b>$var:</b></td><td>($codename)</td><td>$prest</td></tr>"; 1498 } 1499 elsif($code =~ /[wd]/) { 1500 if($code =~ /^w/) {$codename = "Output"} 1501 elsif($code =~ /^d/) {$codename = "Delete"} 1502 $outputargs .= "<tr><td><b>$var:</b></td><td>($codename)</td><td>$prest</td></tr>"; 1503 } 1504 elsif($code =~ /[u]/) { 1505 if($code =~ /^u/) {$codename = "Modify"} 1506 $modifyargs .= "<tr><td><b>$var:</b></td><td>($codename)</td><td>$prest</td></tr>"; 1507 } 1508 else {$codename = "Unknown"} 1509 1510 testvar($var); 1511 if ($ismacro) { # No code to test for macros 1512 push (@bookmacroparams, "$cast $var"); 1513 } 1514 else { 1515 $curarg = $largs[$acnt]; 1516 if (!defined($curarg)) { 1517 print "bad argument \#$acnt not found in prototype for <$var>\n"; 1518 } 1519 else { 1520 ($tcast,$tname) = ($curarg =~ /(\S.*\S)\s+(\S+)/); 1521 if (!defined($tname)) { 1522 $tcast = $curarg; 1523 if (!$var) { 1524 if($curarg eq "...") { 1525 $var = $tname = "vararg"; 1526 } 1527 else { 1528 print "bad argument \#$acnt parsing failed for '$curarg'\n"; 1529 $var = "unknown"; 1530 $tname = "undefined"; 1531 } 1532 } 1533 else { 1534 print "bad argument \#$acnt parsing failed for '$curarg'\n"; 1535 $tname = "undefined"; 1536 } 1537 } 1538 $castfix = $cast; 1539 $castfix =~ s/^CONST +//go; 1540 if (!$isprog && ($castfix ne $tcast)) { 1541 print "bad cast for $tname <$cast> <$tcast>\n"; 1542 } 1543 if (!$isprog && ($var ne $tname)) { 1544 print "bad var <$var> <$tname>\n"; 1545 } 1546 } 1547 } 1548 $acnt++; 1549 1550 push @savecode, $code; 1551 push @savevar, $var; 1552 push @savecast, $cast; 1553 push @savedesc, $prest; 1554 $drest = $prest; 1555 $drest =~ s/\n\n+$/\n/gos; 1556 $drest =~ s/\n\n\n+/\n\n/gos; 1557 $drest =~ s/\n([^\n])/\nPD $1/gos; 1558 $drest =~ s/\n\n/\nPD\n/gos; 1559 $drest =~ s/>/\>/gos; 1560 $drest =~ s/</\</gos; 1561 chomp $drest; 1562 print SRS "PN [$acnt]\n"; 1563 print SRS "PA $code $var $cast\n"; 1564 print SRS "PD $drest\n"; 1565 print SRS "PX\n"; 1566 1567 if (!$prest) {print "bad paramdescription '$var', no description\n"} 1568 $ftable .= "<tr><td><tt>$cast</tt></td><td><tt>$var</tt></td><td>$codename</td><td>$prest</td></tr>\n"; 1569 1570 if ($simpletype{$cast}) { 1571# Simple C types (not structs) 1572# and EMBOSS types that resolve to simple types 1573 if ($code !~ /r/) { 1574 print "bad paramcode '$var' pass by value, code '$code'\n"; 1575 } 1576 } 1577 elsif ($functype{$cast}) { 1578# Known function types - C and EMBOSS-specific 1579 if ($code !~ /f/) { 1580 print "bad paramcode '$var' function type '$cast', code '$code'\n"; 1581 } 1582 } 1583 elsif ($cast =~ / function$/) { 1584# other function types 1585 if ($code !~ /f/) { 1586 print "bad paramcode '$var' function type '$cast', code '$code'\n"; 1587 } 1588 } 1589 elsif ($cast =~ /^const .*[*][*]/) { 1590# Tricky - we can be read-only 1591# or we can set to any const char* string (for example) 1592# e.g. pcre error pointers 1593# but can be d (e.g. in ajTableMapDel functions) 1594 if ($code !~ /[rwud]/) { 1595 print "bad paramcode '$var' const ** but code '$code'\n"; 1596 } 1597 } 1598 elsif ($cast =~ /^const /) { 1599#If it starts const - except const type ** (see above) - it is const 1600# One exception: pcre has a "const int*" array that is set 1601 if ($cast =~ /const[^a-z].*[*]/) 1602 { 1603 if ($code !~ /[rwud]/) { 1604 print "bad paramcode '$var' const($cast) but code '$code'\n"; 1605 } 1606 } 1607 elsif ($code !~ /r/) { 1608 print "bad paramcode '$var' const but code '$code'\n"; 1609 } 1610 } 1611 elsif ($cast =~ /^struct /) { 1612 if ($code !~ /u/) { 1613 print "bad paramcode '$var' struct but code '$code'\n"; 1614 } 1615 } 1616 elsif ($cast =~ / const[^a-z]/) { 1617# also if it has an internal const 1618# For example char* const argv[] is "char* const[]" 1619# One exception: pcre has a "register const uschar*" array that is set 1620 if ($cast =~ / const[^a-z].*[*]/) 1621 { 1622 if ($code !~ /[rwud]/) { 1623 print "bad paramcode '$var' const($cast) but code '$code'\n"; 1624 } 1625 } 1626 elsif ($cast =~ /^[\S+ const[*]/) 1627 { 1628 if ($code !~ /[rwud]/) { 1629 print "bad paramcode '$var' const($cast) but code '$code'\n"; 1630 } 1631 } 1632 elsif ($code !~ /r/) { 1633 print "bad paramcode '$var' const($cast) but code '$code'\n"; 1634 } 1635 } 1636 elsif ($cast =~ / const$/) { 1637# For char* const (so far no examples) 1638# There could be exceptions - but not yet! 1639 if ($code !~ /r/) { 1640 print "bad paramcode '$var' const($cast) but code '$code'\n"; 1641 } 1642 } 1643 elsif ($cast =~ /^[.][.][.]$/) { 1644# varargs can be ... 1645 if ($code !~ /v/) { 1646 print "bad paramcode '$var' type '...' but code '$code'\n"; 1647 } 1648 } 1649 elsif ($cast =~ /^va_list$/) { 1650# varargs can also be va_list down the list 1651# we did use 'a' for this instead of 'v' but it is too confusing 1652 if ($code !~ /v/) { 1653 print "bad paramcode '$var' type '$cast' but code '$code'\n"; 1654 } 1655 } 1656 elsif ($cast =~ /^void[*]$/) { 1657# hard to check - can be read, write, update or delete 1658 if ($code =~ /[?]/) { 1659 print "bad paramcode '$var' code '$code'\n"; 1660 } 1661 } 1662 elsif ($cast =~ /^void[*]+$/) { 1663# hard to check - can be read, write, update or delete 1664# Note: maybe we can put a placeholder in the @param cast 1665 if ($code =~ /[?]/) { 1666 print "bad paramcode '$var' code '$code'\n"; 1667 } 1668 } 1669 elsif ($cast =~ /[\]]$/) { 1670# hard to check - can be read, write, update or delete 1671# because we can't use const for these 1672# Note: maybe we can put a placeholder in the @param cast 1673 if ($code =~ /[?]/) { 1674 print "bad paramcode '$var' code '$code'\n"; 1675 } 1676 if ($code =~ /r/) { 1677 if ($cast =~ /^CONST +/) { 1678 $cast =~ s/^CONST +//o; 1679 } 1680 else 1681 { 1682 print "bad paramcode '$var' code '$code' but '$cast'\n"; 1683 } 1684 } 1685 } 1686 elsif ($cast =~ /[*]+$/) { 1687# hard to check - can be read, write, update or delete 1688# because we can't use const for these 1689# Note: maybe we can put a placeholder in the @param cast 1690 if ($code =~ /[?]/) { 1691 print "bad paramcode '$var' code '$code'\n"; 1692 } 1693 if ($code =~ /r/) { 1694 if ($cast =~ /^CONST +/) { 1695 $cast =~ s/^CONST +//o; 1696 } 1697 else 1698 { 1699 print "bad paramcode '$var' code '$code' but '$cast'\n"; 1700 } 1701 } 1702 } 1703 else { 1704# Standard checks for anything else 1705 if ($code =~ /r/) { 1706 print "bad paramcode '$var' code '$code' but not const\n"; 1707 } 1708 if ($code =~ /[?]/) { 1709 print "bad paramcode '$var' code '$code'\n"; 1710 } 1711 } 1712 } 1713 1714 elsif ($token eq "return") { 1715 if($mastertoken ne "func" && 1716 $mastertoken ne "funcstatic" && 1717 $mastertoken ne "macro" && 1718 $mastertoken ne "funclist") { 1719 print "bad syntax \@$token must be in \@func, funcstatic, funclist or macro\n"; 1720 } 1721 if (!$intable) { 1722 $ftable = "<p><table border=1>\n"; 1723 $ftable .= "<tr><th>Type</th><th>Name</th><th>Read/Write</th><th>Description</th></tr>\n"; 1724 $intable = 1; 1725 } 1726 ($rtype, $rrest) = ($data =~ /\S+\s+\[([^\]]+)\]\s*(.*)/gos); 1727 if(!defined($rtype)) { 1728 print "bad return definition: not parsed\n"; 1729 next; 1730 } 1731 if(!defined($ftype)) {$ftype = "unknown";} 1732 if (!$ismacro && !$isprog && $rtype ne $ftype) { 1733 print "bad return type <$rtype> <$ftype>\n"; 1734 } 1735 if (!$rrest && $rtype ne "void") { 1736 print "bad return description [$rtype], no description\n"; 1737 } 1738 1739 if($rtype eq "void") { 1740 $returnargs = "<tr><td><b>$rtype:</b></td><td>No return value</td></tr>"; 1741 } 1742 else { 1743 $returnargs = "<tr><td><b>$rtype:</b></td><td>$rrest</td></tr>"; 1744 } 1745 if($ismacro) { 1746 $bookstr .= sprintf "%-15s %s (", $rtype, $bookmacro; 1747 $ia = 0; 1748 foreach $f (@bookmacroparams) { 1749 if($ia++) {$bookstr .= ", "} 1750 $bookstr .= $f; 1751 } 1752 $bookstr .= ");\n"; 1753 } 1754 1755 $rrest =~ s/>/\>/gos; 1756 $rrest =~ s/</\</gos; 1757 $ftable .= "<tr><td><tt>$rtype</tt></td><td>\ </td><td>RETURN</td><td>$rrest</td></tr>\n"; 1758 $ftable .= "</table><p>\n"; 1759 $intable = 0; 1760 1761 $drest = $rrest; 1762 $drest =~ s/^$/\n/gos; # make sure we have something 1763 $drest =~ s/\n\n+$/\n/gos; 1764 $drest =~ s/\n\n\n+/\n\n/gos; 1765 $drest =~ s/\n([^\n])/\nRD $1/gos; 1766 $drest =~ s/\n\n/\nRD\n/gos; 1767 $drest =~ s/>/\>/gos; 1768 $drest =~ s/</\</gos; 1769 chomp $drest; 1770 print SRS "RT $rtype\n"; 1771 print SRS "RD $drest\n"; 1772 print SRS "RX\n"; 1773 } 1774 1775 elsif ($token eq "fcategory") { 1776 if($mastertoken ne "section") { 1777 print "bad syntax \@fcategory must be in \@section\n"; 1778 } 1779 ($ctype, $crest) = ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1780 if ($crest) { 1781 print "bad \@$token [$ctype], extra text\n"; 1782 } 1783 1784 $fctype = $ctype; 1785 $ctot{$ctype}++; 1786 secttest($sect,$ctype); 1787 if (!defined($categs{$ctype})) { 1788 print "bad \@fcategory $ctype - unknown category type\n"; 1789 } 1790 } 1791 1792 elsif ($token eq "category") { 1793 if($mastertoken ne "func" && 1794 $mastertoken ne "funcstatic" && 1795 $mastertoken ne "macro") { 1796 print "bad syntax \@category must be in \@func, funcstatic, or macro\n"; 1797 } 1798 ($ctype, $cdata, $crest) = ($data =~ /\S+\s+(\S+)\s+\[([^\]]+)\]\s*(.*)/gos); 1799 if (!$crest) { 1800 print "bad \@$token [$ctype], no description\n"; 1801 } 1802 1803 $crest =~ s/\s+/ /gos; 1804 $crest =~ s/^ //gos; 1805 $crest =~ s/ $//gos; 1806 $crest =~ s/>/\>/gos; 1807 $crest =~ s/</\</gos; 1808 1809 $drest = $crest; 1810 $drest =~ s/^$/\n/gos; # make sure we have something 1811 $drest =~ s/\n\n+$/\n/gos; 1812 $drest =~ s/\n\n\n+/\n\n/gos; 1813 $drest =~ s/\n([^\n])/\nCD $1/gos; 1814 $drest =~ s/\n\n/\nCD\n/gos; 1815 $drest =~ s/>/\>/gos; 1816 $drest =~ s/</\</gos; 1817 chomp $drest; 1818 print SRS "CA $ctype\n"; 1819 print SRS "CT $cdata\n"; 1820 print SRS "CD $drest\n"; 1821 print SRS "CX\n"; 1822 1823### print "category $ctype [$cdata] $fname $pubout $lib : $crest\n"; 1824 $ctot{$ctype}++; 1825 secttest($sect,$ctype); 1826 1827 if ($dosecttest && $fdata ne "") { 1828 $cdata = $fdata; 1829 } 1830 if (!defined($categs{$ctype})) { 1831 print "bad \@$type [$ctype], unknown type\n"; 1832 } 1833 elsif ($ctype eq "new") { 1834 testnew($cdata,$rtype); 1835 } 1836 elsif ($ctype eq "delete") { 1837 testdelete($cdata, $rtype,@savecast,@savecode); 1838 } 1839 elsif ($ctype eq "assign") { 1840 testassign($cdata,$rtype,@savecast,@savecode); 1841 } 1842 elsif ($ctype eq "modify") { 1843 testmodify($cdata,$rtype,@savecast,@savecode); 1844 } 1845 elsif ($ctype eq "cast") { 1846 testcast($cdata,$rtype,@savecast,@savecode); 1847 } 1848 elsif ($ctype eq "derive") { 1849 testderive($cdata,$rtype,@savecast,@savecode); 1850 } 1851 elsif ($ctype eq "use") { 1852 testuse($cdata,@savecast,@savecode); 1853 } 1854 elsif ($ctype eq "iterate") { 1855 testiterate($cdata,$rtype,$crest,@savecast); 1856 } 1857 elsif ($ctype eq "input") { 1858 testinput($cdata,@savecast,@savecode); 1859 } 1860 elsif ($ctype eq "output") { 1861 testoutput($cdata,@savecast,@savecode); 1862 } 1863 elsif ($ctype eq "misc") { 1864 testmisc($cdata,@savecast,@savecode); 1865 } 1866 elsif ($ctype eq "internals") { 1867 testinternals($cdata,@savecast,@savecode); 1868 } 1869 else { 1870 print "bad category type '$ctype' - no validation\n"; 1871 } 1872 } 1873 1874 elsif ($token eq "header") { 1875 if($partnum != 1) { 1876 print "bad syntax \@$token must be at start\n"; 1877 } 1878 next; 1879 } 1880 1881 elsif ($token eq "short") { 1882 if($mastertoken ne "func" && 1883 $mastertoken ne "funcstatic" && 1884 $mastertoken ne "macro") { 1885 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 1886 } 1887 ($shortdesc) = ($data =~ /\S+\s+(.*)/); 1888 $shortdesc =~ s/>/\>/gos; 1889 $shortdesc =~ s/</\</gos; 1890 $shortdesc =~ s/\n\n/\n<p>\n/gos; 1891 } 1892 1893 elsif ($token eq "release") { 1894 if($mastertoken ne "func" && 1895 $mastertoken ne "funcstatic" && 1896 $mastertoken ne "macro") { 1897 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 1898 } 1899 ($availtext) = ($data =~ /\S+\s+(.*)/); 1900 $availtext =~ s/\s+$//gos; 1901 if($availtext =~ /^(\d+[.][.\d]+)$/) { 1902 $availtext = "From EMBOSS $1"; 1903 } 1904 $availtext =~ s/>/\>/gos; 1905 $availtext =~ s/</\</gos; 1906 $availtext =~ s/\n\n/\n<p>\n/gos; 1907 } 1908 1909 elsif ($token eq "cc") { 1910 if($mastertoken ne "func" && 1911 $mastertoken ne "funcstatic" && 1912 $mastertoken ne "macro" && 1913 $mastertoken ne "section" && 1914 $mastertoken ne "filesection" && 1915 $mastertoken ne "datasection") { 1916 print "bad syntax \@$token must be in \@func, funcstatic, or macro or a section\n"; 1917 } 1918 next; 1919 } 1920 1921 elsif ($token eq "obsolete") { 1922 ($oname, $norest) = 1923 ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1924 if($partnum != 1) { 1925 print "bad syntax \@$token $oname must be at start\n"; 1926 } 1927 if(!$indep && !$indepbook) { 1928 print "bad syntax \@$token $oname must be in AJ_COMPILE_DEPRECATED\n"; 1929 } 1930 if($prespace !~ /^\n\n\n\n\n$/) { 1931 print "Obsolete $oname\n"; 1932 if($prespace =~ /^[\n]+$/) { 1933 $whitelen = length($&) - 1; 1934 print "bad whitespace $whitelen lines at start\n"; 1935 } 1936 elsif ($prespace =~ / /) { 1937 print "bad whitespace has space(s) at start\n"; 1938 } 1939 elsif ($prespace =~ /\t/) { 1940 print "bad whitespace has tab(s) at start\n"; 1941 } 1942 else { 1943 print "bad whitespace at start\n"; 1944 } 1945 } 1946 1947 if($norest) { 1948 print "bad obsolete $oname - extra text\n" 1949 } 1950 $replaces = ""; 1951 if ($rest =~ /^\s*__deprecated\s+([^\(\)]*\S)\s+(\S+)\s*[\(]\s*([^{]*)[)]\s*[\{]/os) { 1952 $ofname = $2; 1953 $ofname =~ s/^[*]+//; 1954 if ($oname ne $ofname) { 1955 print "bad obsolete function name <$ofname> <$oname>\n"; 1956 } 1957 } 1958 else { 1959 print "bad obsolete function $oname - not __deprecated\n"; 1960 } 1961 next; 1962 } 1963 1964 elsif ($token eq "rename") { 1965 if($mastertoken ne "obsolete") { 1966 print "bad syntax \@$token must be in \@obsolete\n"; 1967 } 1968 if($partnum == 1) { 1969 print "bad syntax \@$token cannot be the start\n"; 1970 } 1971 ($rename, $norest) = 1972 ($data =~ /\S+\s+(\S+)\s*(.*)/gos); 1973 if($norest) { 1974 print "bad rename $oname $rename - extra text\n"; 1975 next; 1976 } 1977 print OBS "$oname $rename\n"; 1978 next; 1979 } 1980 1981 elsif ($token eq "replace") { 1982 if($mastertoken ne "obsolete") { 1983 print "bad syntax \@$token must be in \@obsolete\n"; 1984 } 1985 if($partnum == 1) { 1986 print "bad syntax \@$token cannot be the start\n"; 1987 } 1988 ($replace, $repargs, $norest) = 1989 ($data =~ /\S+\s+(\S+)\s+[\(]([^\)]+)[\)]\s*(.*)/gos); 1990 if(!defined($repargs)){ 1991 print "bad replace $oname value: failed to parse\n"; 1992 next; 1993 } 1994 if($repargs ne "") { 1995 ($repold, $repnew) = split('/', $repargs); 1996 @repold = split(',', $repold); 1997 @repnew = split(',', $repnew); 1998 print OBS "$oname =$replace $repold $repnew\n"; 1999 } 2000 else { 2001 print "bad replace $oname $replace - no arguments\n"; 2002 next; 2003 } 2004 if($norest) { 2005 print "bad replace $oname $replace - extra text\n"; 2006 next; 2007 } 2008 2009 if($replaces ne "") { 2010 $replaces .= "_or_\@$replace"; 2011 } 2012 else { 2013 $replaces = "\@$replace"; 2014 } 2015 next; 2016 } 2017 2018 elsif ($token eq "remove") { 2019 if($mastertoken ne "obsolete") { 2020 print "bad syntax \@$token must be in \@obsolete\n"; 2021 } 2022 if($partnum == 1) { 2023 print "bad syntax \@$token cannot be the start\n"; 2024 } 2025 ($delrest) = 2026 ($data =~ /\S+\s*(.*)/gos); 2027 if(!$delrest) { 2028 print "bad remove $oname - no explanation\n"; 2029 next; 2030 } 2031 print OBS "$oname -\n"; 2032 next; 2033 } 2034 2035 elsif ($token eq "source") { 2036 if($partnum != 1) { 2037 print "bad syntax \@$token must be at start\n"; 2038 } 2039 next; 2040 } 2041 2042 elsif ($token eq "author") { 2043 if($mastertoken ne "source") { 2044 print "bad syntax \@$token must be in \@source\n"; 2045 } 2046 next; 2047 } 2048 2049 elsif ($token eq "version") { 2050 if($mastertoken ne "source") { 2051 print "bad syntax \@$token must be in \@source\n"; 2052 } 2053 next; 2054 } 2055 2056 elsif ($token eq "modified") { 2057 if($mastertoken ne "source") { 2058 print "bad syntax \@$token must be in \@source\n"; 2059 } 2060 next; 2061 } 2062 2063 elsif ($token eq "error") { 2064 if($mastertoken ne "func" && 2065 $mastertoken ne "funcstatic" && 2066 $mastertoken ne "macro") { 2067 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 2068 } 2069 next; 2070 } 2071 2072 elsif ($token eq "cre") { 2073 if($mastertoken ne "func" && 2074 $mastertoken ne "funcstatic" && 2075 $mastertoken ne "macro") { 2076 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 2077 } 2078 next; 2079 } 2080 2081 elsif ($token eq "see") { 2082 if($mastertoken ne "func" && 2083 $mastertoken ne "funcstatic" && 2084 $mastertoken ne "macro") { 2085 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 2086 } 2087 next; 2088 } 2089 2090 elsif ($token eq "ure") { 2091 if($mastertoken ne "func" && 2092 $mastertoken ne "funcstatic" && 2093 $mastertoken ne "macro") { 2094 print "bad syntax \@$token must be in \@func, funcstatic, or macro\n"; 2095 } 2096 next; 2097 } 2098 2099 elsif ($datatoken{$token}) { 2100 } 2101 elsif (defined($categs{$token})) { 2102 } 2103 elsif ($ignore{$token}) { 2104 } 2105 elsif ($token eq "@") { 2106 if($partnum == 1) { 2107 print "bad syntax \@$token cannot be the start\n"; 2108 } 2109 last; 2110 } 2111 else { 2112 print "Unknown tag '\@$token\n"; 2113 } 2114 } 2115 2116# Whole block read. 2117# Post-processing 2118 2119 if($dosecttest) { 2120 if($mastertoken eq "obsolete") { 2121 if($replaces ne "") { 2122 print OBS "$oname $replaces\n"; 2123 } 2124 } 2125 2126 if($mastertoken eq "filesection") { 2127 $namrulesfilecount=$#namrules; 2128 $suffixfilecount=$#sufname; 2129 } 2130 if($mastertoken eq "datasection") { 2131 $namrulesdatacount=$#namrules; 2132 $suffixdatacount=$#sufname; 2133 } 2134 2135 if($mastertoken eq "section") { 2136 if($fdata eq "") { 2137 print "bad section: '$sect' no fdata $datatype assumed\n"; 2138 } 2139 if($ctype eq "") { 2140 print "bad section: '$sect' no fcategory\n"; 2141 } 2142 } 2143 } 2144 2145 if ($type) { 2146# print "acnt: $acnt largs: $#largs\n"; 2147# print "type $type test $test{$type}\n"; 2148 2149 if ($dosecttest && $type eq "func") { # not funcstatic or funclist 2150 if($type eq "macro") { 2151 @nameparts = nametorules($fname, @namrules); 2152 } 2153 else { 2154 @nameparts = nametowords($fname); 2155 } 2156 if(!testorder($lastfname, $type, @nameparts)) { 2157 print "bad order: Function $fname follows $lastfname\n"; 2158 } 2159 if($type eq "macro") { 2160 $lastfname = ""; 2161 foreach $n(@nameparts) { 2162 $lastfname .= $n; 2163 } 2164 print LOG "Macro lastfname '$lastfname'\n"; 2165 } 2166 else { 2167 $lastfname = $fname; 2168 } 2169 print LOG "function $fname ...\n"; 2170 2171# Function name compared to naming rules 2172 2173 $i=0; 2174 foreach $f (@nameparts) { 2175 $j = $i+1; 2176# print LOG "name $j '$f'\n"; 2177 if(defined($namrules[$i]) && ($f eq $namrules[$i])) { 2178# print LOG "namecheck OK\n"; 2179 } 2180 elsif(issuffix($f,@sufname)) { 2181# print LOG "namecheck OK suffix\n"; 2182 } 2183 else { 2184 if(defined($namrules[$i])) { 2185# print LOG "calling isnamrule i: $i rules $#{$namrules[$i]} names $#nameparts\n"; 2186 if(!isnamrule($i, @{$namrules[$i]}, @nameparts)) { 2187 print "bad namerule $fname: '$f' not found\n"; 2188 print "** \@nam$j"; 2189 if($j == $#nameparts) { 2190 print "rule $f $frest\n"; 2191 } 2192 else{ 2193 print "rule $f Undocumented\n"; 2194 } 2195 last; 2196 } 2197 } 2198 else { 2199 print "bad namerule $fname: '$f' beyond last rule\n"; 2200 last; 2201 } 2202 } 2203 $i++; 2204 } 2205 2206# parameters compared to argument rules 2207 2208# First we use the name to generate a list of arguments 2209 2210 @genargname=(); 2211 @genargtype=(); 2212 @genvalname=(); 2213 @genvaltype=(); 2214 $i=0; 2215 foreach $a (@argpref) { 2216 print LOG "argrule '$a' $argnumb[$i] testing $fname\n"; 2217 $j = $i+1; 2218# print LOG "argrule $j '$a' [$argtype[$i]] '$argdesc[$i]'\n"; 2219 if(($a eq "*") || matchargname($a, $argnumb[$i], @nameparts)) { 2220# print LOG "argrule used: '$a' $argname[$i] [$argtype[$i]]\n"; 2221 push (@genargname, $argname[$i]); 2222 push (@genargtype, $argtype[$i]); 2223 } 2224 $i++; 2225 } 2226 2227### return value = "*" for default, may also have a specific value 2228 2229 $valtypeall = ""; 2230 $i=0; 2231 foreach $v (@valname) { 2232 $vv = $v; 2233# print LOG "valrule '$v' testing $fname\n"; 2234 $j = $i+1; 2235# print LOG "valrule $j '$v' [$valtype[$i]]'\n"; 2236 if(matchargname($v, 0, @nameparts)) { 2237# print LOG "valrule used: '$vv' [$valtype[$i]]\n"; 2238 if($vv =~ /^[*](.+)/) { 2239 $vv = $1; 2240 @genvalname = (); 2241 @genvaltype = (); 2242 } 2243 push (@genvaltype, $valtype[$i]); 2244 push (@genvalname, $vv); 2245 } 2246 if($vv eq "*") { 2247 $valtypeall = $valtype[$i]; 2248 } 2249 $i++; 2250 } 2251 if($valtypeall ne "") { 2252 print LOG "valrule * [$valtypeall]\n"; 2253 if(!defined($genvaltype[0])) { 2254# print LOG " valrule * [$valtypeall] used\n"; 2255 push (@genvaltype, $valtypeall); 2256 } 2257 } 2258 $i=0; 2259 foreach $x (@genargname) { 2260 if(!defined($savevar[$i])) { 2261 print LOG "++ arg '$x' [$genargtype[$i]] ... <undefined>\n"; 2262 } 2263 else { 2264 print LOG "++ arg '$x' [$genargtype[$i]] ... $savevar[$i] [$savecast[$i]]\n"; 2265 if($x ne $savevar[$i]) { 2266 print "bad param name <$savevar[$i]> rule <$x> \n"; 2267 } 2268 if($genargtype[$i] ne $savecast[$i]) { 2269 print "bad param type <$savevar[$i]> [$savecast[$i]] rule <$x> [$genargtype[$i]]\n"; 2270 } 2271 } 2272 $i++; 2273 } 2274# 2275 $isave = $#savevar + 1; 2276 $igen=$#genargname + 1; 2277 if($igen < $isave) { 2278 print "bad argrule: $igen/$isave params defined\n"; 2279 for($i=$igen;$i <$isave;$i++) { 2280 print "** \@argrule $fname $savevar[$i] \[$savecast[$i]\] $savedesc[$i]\n"; 2281 } 2282 } 2283 elsif($igen > $isave) { 2284 print "bad argrule: expected $isave params, found $igen\n"; 2285 } 2286 2287 if($#genvaltype <0) { 2288 print "bad valrule: no matching rule\n" 2289 } 2290 elsif($#genvaltype >0) { 2291 $igenvaltype = $#genvaltype+1; 2292 print "bad valrule: $igenvaltype matching rules:"; 2293 foreach $g(@genvalname) { 2294 print "<$g>"; 2295 } 2296 print "\n"; 2297 } 2298 else { 2299 print LOG "++ val [$genvaltype[0]] ... [$rtype]\n"; 2300 if($rtype ne $genvaltype[0]) { 2301 print "bad return: <$rtype> rule <$genvaltype[0]>\n"; 2302 } 2303 } 2304 if($dosecttest && $fdata ne "") { 2305 $cdata = $fdata; 2306 } 2307 if ($ctype eq "") { 2308 # already an error above 2309 } 2310 elsif ($ctype eq "new") { 2311 testnew($fdata,$rtype); 2312 } 2313 elsif ($ctype eq "delete") { 2314 testdelete($fdata, $rtype,@savecast,@savecode); 2315 } 2316 elsif ($ctype eq "assign") { 2317 testassign($fdata,$rtype,@savecast,@savecode); 2318 } 2319 elsif ($ctype eq "modify") { 2320 testmodify($fdata,$rtype,@savecast,@savecode); 2321 } 2322 elsif ($ctype eq "cast") { 2323 testcast($fdata,$rtype,@savecast,@savecode); 2324 } 2325 elsif ($ctype eq "derive") { 2326 testderive($fdata,$rtype,@savecast,@savecode); 2327 } 2328 elsif ($ctype eq "use") { 2329 testuse($fdata,@savecast,@savecode); 2330 } 2331 elsif ($ctype eq "iterate") { 2332 testiterate($fdata,$rtype,$crest,@savecast); 2333 } 2334 elsif ($ctype eq "input") { 2335 testinput($fdata,@savecast,@savecode); 2336 } 2337 elsif ($ctype eq "output") { 2338 testoutput($fdata,@savecast,@savecode); 2339 } 2340 elsif ($ctype eq "misc") { 2341 testmisc($fdata,@savecast,@savecode); 2342 } 2343 else { 2344 print "bad category type '$ctype' - no validation\n"; 2345 } 2346 } 2347 2348 if ($test{$type}) { 2349 if ($acnt == $#largs) { 2350 if ($largs[$#largs] ne "void") { 2351 print "bad last argument: $largs[$#largs]\n"; 2352 if(!$acnt) { 2353 for ($ii=0;$ii<=$#largs;$ii++) { 2354 ($itcast,$itname) = ($largs[$ii] =~ /(\S.*\S)\s+(\S+)/); 2355 if($itcast =~ /[*]/) 2356 { 2357 print "** \@param [u] $itname [$itcast] Undocumented\n"; 2358 } 2359 else 2360 { 2361 print "** \@param [r] $itname [$itcast] Undocumented\n"; 2362 } 2363 } 2364 } 2365 } 2366 } 2367 if ($acnt < $#largs) { # allow one remaining 2368 $w=$#largs+1; 2369 print "bad \@param list $acnt found $w wanted\n"; 2370 if(!$acnt) { 2371 for ($ii=0;$ii<=$#largs;$ii++) { 2372 ($itcast,$itname) = ($largs[$ii] =~ /(\S.*\S)\s+(\S+)/); 2373 if($itcast =~ /[*]/) 2374 { 2375 print "** \@param [u] $itname [$itcast] Undocumented\n"; 2376 } 2377 else 2378 { 2379 print "** \@param [r] $itname [$itcast] Undocumented\n"; 2380 } 2381 } 2382 } 2383 } 2384 if(!defined($ftype)) {$ftype = "unknown"} 2385 if (!$rtype && $ftype ne "void") {print "bad missing \@return\n"} 2386 print "=============================\n"; 2387 } 2388 print SRS "//\n"; 2389 2390 2391 if($shortdesc) { 2392 ${$ostr} .= "$shortdesc\n"; 2393 } 2394 2395############################################################## 2396## do we want to save what follows the comment? 2397## Yes, for functions (and static functions) and main programs 2398## $rest is what follows the comment 2399############################################################## 2400 2401 if (defined($body{$type}) && $body{$type} == 1) { 2402 2403# body is the code up to a '}' at the start of a line 2404 2405 ($body) = ($rest =~ /(.*?\n\}[^\n]*\n)/os); 2406 if(!defined($body)) { 2407 print "bad code body, closing brace not found\n"; 2408 $body = "\n"; 2409 } 2410 print SRS $body; 2411 2412 if(defined($fname)) { 2413 ${$ostr} .= "<h4>Prototype</h4><pre>"; 2414 ${$ostr} .= "\n$ftype $fname ("; 2415 $firstarg = 1; 2416 foreach $a (@largs) { 2417 if($firstarg) { 2418 ${$ostr} .= "\n $a"; 2419 } 2420 else { 2421 ${$ostr} .= ",\n $a"; 2422 } 2423 $firstarg = 0; 2424 } 2425 if($firstarg) { 2426 ${$ostr} .= "void);\n</pre>\n"; 2427 } 2428 else { 2429 ${$ostr} .= "\n);\n</pre>\n"; 2430 } 2431 if($ftable ne "") { 2432 ${$ostr} .= $ftable; 2433 $ftable = ""; 2434 } 2435 } 2436 } 2437 2438 if (defined($test{$type}) && $test{$type} == 2) { 2439 2440# body is the code up to a line that doesn't end with '\' 2441 2442 ($body) = ($rest =~ /\s*(\n\#define\s+[^(\n]+\s*[(][^)\n]*[)].*?[^\\])$/os); 2443 print SRS "==FUNCLIST\n$body\n==ENDLIST\n"; 2444 print SRS "==REST\n$rest\n==ENDREST\n"; 2445 } 2446 2447# skip these - they duplicate what is in the table 2448 2449# if($inputargs) { 2450# ${$ostr} .= "<h4>Input</h4>\n"; 2451# ${$ostr} .= "<table>$inputargs</table>\n"; 2452# } 2453# if($outputargs) { 2454# ${$ostr} .= "<h4>Output</h4>\n"; 2455# ${$ostr} .= "<table>$outputargs</table>\n"; 2456# } 2457# if($modifyargs) { 2458# ${$ostr} .= "<h4>Input \& Output</h4>\n"; 2459# ${$ostr} .= "<table>$modifyargs</table>\n"; 2460# } 2461# if($returnargs) { 2462# ${$ostr} .= "<h4>Returns</h4>\n"; 2463# ${$ostr} .= "<table>$returnargs</table>\n"; 2464# } 2465 2466# report if not the default string 2467 if($usetext ne "See source code") { 2468 ${$ostr} .= "<h4>Usage</h4>\n"; 2469 ${$ostr} .= "$usetext\n"; 2470 } 2471 if($exampletext ne "In preparation") { 2472 ${$ostr} .= "<h4>Example</h4>\n"; 2473 ${$ostr} .= "$exampletext\n"; 2474 } 2475 if($errtext ne "See source code") { 2476 ${$ostr} .= "<h4>Errors</h4>\n"; 2477 ${$ostr} .= "$errtext\n"; 2478 } 2479 if($dependtext ne "See source code") { 2480 ${$ostr} .= "<h4>Dependencies</h4>\n"; 2481 ${$ostr} .= "$dependtext\n"; 2482 } 2483 if($othertext ne "See other functions in this section") { 2484 ${$ostr} .= "<h4>See Also</h4>\n"; 2485 ${$ostr} .= "$othertext\n"; 2486 } 2487 2488# release tag 2489 if($availtext) { 2490# ${$ostr} .= "<h4>Availability</h4>\n"; 2491 ${$ostr} .= "$availtext\n"; 2492 } 2493 } 2494} 2495 2496if($dosecttest && $sect ne "") { 2497 if($countsection == 0) { 2498 print "bad section: '$sect' has no public functions\n"; 2499 } 2500} 2501 2502if (!$countglobal) { 2503 open (EMPTY, ">$pubout.empty") || die "Cannot open $pubout.empty"; 2504 close EMPTY; 2505 $out .= "<p>No public functions in source file $infile</p>" 2506} 2507if (!$countstatic) { 2508 open (EMPTY, ">$local\_static.empty") || die "Cannot open $local\_static.empty"; 2509 close EMPTY; 2510 $outstatic .= "<p>No static functions in source file $infile</p>" 2511} 2512 2513if($sectstr !~ /[^ ]$/) {$sectstr = ""} 2514else {$sectstr .= "</table>\n"} 2515$out =~ s/[.]+lastsect[.]+/$sectstr\n/; 2516 2517if($sectstrstatic !~ /[^ ]$/) {$sectstrstatic = ""} 2518else {$sectstrstatic .= "</table>\n"} 2519$outstatic =~ s/[.]+lastsect[.]+/$sectstrstatic\n/; 2520 2521if($datastr !~ /[^ ]$/) {$datastr = ""} 2522else {$datastr .= "</table>\n"} 2523$out =~ s/[.]+lastdata[.]+/$datastr\n/; 2524 2525if($datastrstatic !~ /[^ ]$/) {$datastrstatic = ""} 2526else {$datastrstatic .= "</table>\n"} 2527$outstatic =~ s/[.]+lastdata[.]+/$datastrstatic\n/; 2528 2529if($filestr !~ /[^ ]$/) {$filestr = ""} 2530else{$filestr .= "</table>\n"} 2531$out =~ s/[.]+lastfile[.]+/$filestr\n/; 2532 2533if($filestrstatic !~ /[^ ]$/) {$filestrstatic = ""} 2534else{$filestrstatic .= "</table>\n"} 2535$outstatic =~ s/[.]+lastfile[.]+/$filestrstatic\n/; 2536 2537$out .= "</body></html>\n"; 2538$outstatic .= "</body></html>\n"; 2539 2540print HTML "$out"; 2541print HTMLB "$outstatic"; 2542close HTML; 2543close HTMLB; 2544 2545print BOOK "$bookstr\n"; 2546close BOOK; 2547 2548open (TESTLOG, ">>../embossdoc.log") || die "Cannot open embossdoc.log"; 2549 2550$i=0; 2551foreach $ccc (sort(keys(%countcode))) { 2552 if(!$i++) {print TESTLOG "$pubout parameter codes:\n"} 2553 print TESTLOG " $ccc: $countcode{$ccc}\n"; 2554} 2555 2556close TESTLOG; 2557 2558exit (); 2559 2560foreach $x (@datalist) { 2561 print STDERR "$x\n"; 2562 2563 foreach $y (@{$datasect{$x}}) { 2564 print STDERR " $y\n"; 2565 $d = "$x - $y"; 2566 foreach $f (@{$datafunc{$d}}) { 2567 print STDERR " $f\n"; 2568 } 2569 print STDERR "\n"; 2570 } 2571 print STDERR "\n"; 2572} 2573 2574