1#!/usr/bin/perl -Tw 2#use diagnostics; 3# 4# Convert Pascal code to something that Doxygen can understand 5# 6# This version is proof of concept, and may/maynot work, as it's my first perl script... 7# 8# Darren Bowles 18th June 2002 9# 10# TODO 11# handle constructor / destructor 12# const's within functions shouldn't be documented. 13# handle override, safecall etc. 14# cr/lf issues between linux / windows. 15# handle type<cr> x = y; 16# handle class function 17# handle dispinterface 18# TLB's not handled well. 19 20# done in this version 21# process function/procedure merged into build_line 22# obsolete function removed 23# started on handle class function, interface, dispinterface, TLB 24 25use Getopt::Std; 26use Getopt::Long; 27GetOptions('help', \$help, 'list=s', \$list, 'file=s', \$fle); 28 29if ($help || !($fle | $list)) 30{ 31 print "pas2dox -h/--help -f/--file singlefile.pas -l/--list listoffiles\n"; 32 exit 0; 33} 34 35die "No Files Specified" if (!$list & !$fle); 36 37if ($fle) 38{ 39 process_file ($fle); 40}; 41 42if ($list) 43{ 44 process_list ($list); 45}; 46 47print STDERR "\tDone...\n"; 48 49# ================================================================================= 50# functions 51# ================================================================================= 52 53sub tidy_line 54{ 55 my $str = shift; 56 return $str; 57} 58 59# ================================================================================= 60# tidy up line, i.e. remove spaces, tabs and newlines 61sub tidy_line2 62{ 63 my $str = shift; 64 65# remove tabs and newlines 66 $str =~ s/\t|\n//g; 67 68 while ( $str =~ / / ) 69 { 70 $str =~ s/ / /g; 71 } 72 return $str; 73} 74 75# ================================================================================= 76# process class block 77sub process_class 78{ 79 my $line = shift; 80#$newline .= "processing class line $line\n"; 81 82SWITCH: for (tidy_line($line)) 83 { 84# handle comments 85 m/^\/\// && do 86 { 87 $newline .= "$line\n"; 88 last; 89 }; 90 91 /(private|protected|public)/i && do 92 { 93 # output keyword as lowercase 94 $newline .= lc ($1); 95 $newline .= " : \n"; 96 last; 97 }; 98 99# special handling of published 100 m/published/i && do 101 { 102 $newline .= "// published: \n"; 103 last; 104 }; 105 106# todo Not sure how to handle property yet 107#property x : type read fx write fy; 108 m/^property/i && do 109 { 110#property MessageListThread: TMessageListThread read oMessageListThread write oMessageListThread; 111 $newline .= "// property = $line\n"; 112 #if ( $line =~ /(property)(.*)(:)(.*)(read)(.*)(write)(.*)/i ) 113 if ( $line =~ /(property)(.*)(:)(.*)( read)(.*)( write)(.*)(;)/i ) 114 { 115 $newline .= "$4 $2;\n"; 116 } 117#property x : type read or write f; 118 elsif ($line =~ /(property)(.*)(:)(.*)( read| write)(.*)/i ) 119 { 120#$newline .= "pf1 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 121 $newline .= "$4 $2;\n"; 122 } 123 else 124 { 125# FIX : does get here if property is in the line 126# i.e. procedure xxxPropertyxxx(const Propertyxxx: type; 127# out x: type; out b: type); safecall; 128 129 $newline .= "// should not get here -> "; 130 $newline .= $line; 131 } 132 last; 133 }; 134 135# end of class 136 /end;/i && do 137 { 138 $state = $DO_DEFAULT; 139 $newline .= "};\n"; 140 last; 141 }; 142 143 /function/i && do 144 { 145#$newline .= "processing a function\n"; 146 $state = $DO_CLASSFUNCTION; 147 $function = 1; 148 if ( build_line ($line, "1", 1) == 1) 149 { 150 $function = 1; 151 $split_line = 1; 152 } 153 else 154 { 155 $function = 0; 156 $split_line = 0; 157 } 158 159 last; 160 }; 161 162 /procedure/i && do 163 { 164 $state = $DO_CLASSPROCEDURE; 165 $procedure = 1; 166 if ( build_line ($line, "1", 0) == 1) 167 { 168 $procedure = 1; 169 $split_line = 1; 170 } 171 else 172 { 173 $procedure = 0; 174 $split_line = 0; 175 } 176 177 last; 178 }; 179 180 181 /dispinterface/i && do 182 { 183 if ( $line =~ /(.*)(\=)(.*)/ ) 184 { 185 $newline .= "dispinterface $1;\n"; 186 } 187 188 last; 189 }; 190 191 # x = interface(IDispatch) 192 /(.*)(\=)(.*)(interface)([^(]*)(.*\()(.*)(\))(.*)/i && do 193 { 194 $newline .= "interface $1 : $7\n{\n"; 195 196 last; 197 }; 198 199 /(.*)(\=)(.*)(interface)(.*)(;)/i && do 200 { 201 $newline .= "interface $1;\n"; 202 last; 203 }; 204 205 206 207# X : Y; 208 /(.*)(:)(.*)(;)(.*)/ && do 209 { 210 $newline .= "$3 $1;"; 211 212# add untrimmed comments 213 $comments = $line; 214 $comments =~ /(.*)(;)(.*)/; 215 216 $newline .= "$3\n"; 217 218 last; 219 }; 220 221# get rid of {} style commenting 222 $line =~ s/{\/\// /; 223 $line =~ s/}//; 224 225 $newline .= "//<?> $line\n"; 226 } 227} 228 229# ================================================================================= 230# Parse function line 231sub parse_function 232{ 233# $newline .= "parsing function\n"; 234# $newline .= "\n>> $funcline<<\n"; 235 236 # remove safecall line 237 $funcline =~ s/safecall\;//; 238 239 $mline = ""; 240 241 # function a.b(x, y : type) : type; 242 if ( tidy_line($funcline) =~ /(function)(.*)(\.)([^(]*)(.*\()(.*)(\))(.*\:)(.*)(;)/i ) 243 { 244 $mline = func1($funcline); 245 } 246 # function b(x, y : type) : type; 247 elsif ( tidy_line($funcline) =~ /(function)(.*)(\()(.*)(\))(.*\:)(.*)(;)/i ) 248 { 249 $mline = func2($funcline); 250 } 251 # function a.b : type; 252 elsif ( tidy_line($funcline) =~ /(function)(.*)(\.)(.*)(:)(.*)(;)/i ) 253 { 254 $mline = func3($funcline); 255 } 256 # function a.b; 257 elsif ( tidy_line($funcline) =~ /(function)(.*)(\.)(.*)(;)/i ) 258 { 259 $mline = func4($funcline); 260 } 261 # function a : type; 262 elsif ( tidy_line($funcline) =~ /(function)(.*)(:)(.*)(;)/i ) 263 { 264 $mline = func5($funcline); 265 } 266 # function x; 267 else 268 { 269$newline .= $funcline; 270 $mline = func6($funcline); 271 } 272 273 $newline .= $mline; 274 $funcline = ""; 275} 276 277# ================================================================================= 278# Build up a func/proc line 279sub build_line 280{ 281 my $line = shift; 282 $type = shift; 283 my $buildtype = shift; # are we building a function or procedure 284 285 chomp($line); 286 # TODO pretty sure i was stripping out ^M's here... code broke on 287 # windows, so commented out... 288 # $line =~ s///; 289 290#$newline .= "build_line = $line\n"; 291 292 # Are we processing a func or proc? 293 if ( $function == 1 | $procedure == 1) 294 { 295 # are we working on a split function? 296 if ( $split_line == 1 ) 297 { 298 # we have ended the parameter list on this line 299 # or we have already reached the endparameters ) 300 if ( $line =~ /\)/ | $end_parameter == 1 ) 301 { 302 $end_parameter = 1; 303 # have we got the end of the function? 304 if ( $line =~ /\;/ ) 305 { 306 $funcline .= $line; 307 308 # now we need to parse the full function declaration 309 310 if ( $buildtype == 1 ) 311 { 312 parse_function; 313 $function = 0; 314 } 315 else 316 { 317 parse_procedure(); 318 $procedure = 0; 319 } 320 321 $funcline = ""; 322 return 0; 323 } 324 # not at end of declaration yet. 325 else 326 { 327 $funcline .= $line; 328 return 1; 329 } 330 } 331 # not end of parameter list yet. 332 else 333 { 334 $funcline .= $line; 335 return 1; 336 } 337 } 338 # Process first line of the function 339 else 340 { 341 # we have started parameter list 342 if ( $line =~ /\(/ ) 343 { 344 # starting the parameter list 345 $end_parameter = 0; 346 347 # we have ended the parameter list on this line 348 if ( $line =~ /\)/ ) 349 { 350 $end_parameter = 1; 351 352 # have we got a semicolon on this line? 353 if ( $line =~ /;/ ) 354 { 355 $funcline .= $line; 356 357 if ( $buildtype == 1 ) 358 { 359 parse_function; 360 } 361 else 362 { 363 parse_procedure(); 364 } 365 } 366 # we have a multiline declaration 367 else 368 { 369 $split_line = 1; 370 $funcline .= $line; 371 return 1; 372 } 373 } 374 # line didn't have an ending ), so we must be split over multiple lines 375 else 376 { 377 $split_line = 1; 378 $funcline .= $line; 379 return 1; 380 } 381 } 382 # parameter list not started on this line 383 else 384 { 385 # have we got a semicolon on this line? 386 if ( $line =~ /;/ ) 387 { 388 $funcline .= $line; 389 390 if ( $buildtype == 1 ) 391 { 392 parse_function; 393 } 394 else 395 { 396 parse_procedure(); 397 } 398 } 399 # we have a multiline declaration 400 else 401 { 402 $split_line = 1; 403 $funcline .= $line; 404 return 1; 405 } 406 } 407 } 408 } 409 410 $newline .= $funcline; 411 412 if ( $buildtype == 1 ) 413 { 414 $function = 0; 415 } 416 else 417 { 418 $procedure = 0; 419 } 420 421 $funcline = ""; 422 return 0; 423} 424 425# ================================================================================= 426# process parameters 427sub process_params 428{ 429 430 my $str = shift; 431 432# $newline .= "// >> $str <<\n"; 433 434 435# split parameters out 436 437 @a = split(/;/, $str); 438 439 $cur = 0; 440chomp @a; 441 foreach $z (@a) 442 { 443# x, y, x : type; 444 445 446 $z =~ /([^:]*)(:)(.*)/; 447 $typ = $3; 448 449# now sort out any comma'd parameters 450 451 @p1 = split(/,/, $1); 452 453 $v = 0; 454 foreach $t (@p1) 455 { 456 $mline .= $typ; 457 $mline .= " "; 458 $mline .= $t; 459 460 if ( $v < $#p1 ) 461 { 462 $mline .= ", "; 463 } 464 465 $v++; 466 467 } 468 469 if ( $cur < $#a ) 470 { 471 $mline .= ", "; 472 } 473 474 $cur++; 475 } 476 477} 478 479# ================================================================================= 480# function class.name(x, y : type) : type; 481sub func1 482{ 483 my $funcline = shift; 484 485 tidy_line($funcline) =~ /(function)(.*)(\.)([^(]*)(.*\()(.*)(\))(.*\:)(.*)(;)/i; 486 487 $mline .= "// function class.name(x, y : type) : type\n"; 488#$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 489 $mline .= $9; 490 $mline .= " "; 491 $mline .= $2; 492 $mline .= "::"; 493 $mline .= $4; 494 $mline .= "("; 495 496 $v = $6; 497 498 process_params ($v); 499 500 $mline .= ")"; 501 502 $function = 0; 503 if ( $type == 0) 504 { 505 if ( $implementation == 0 ) 506 { 507 $mline .= ";"; 508 } 509 510 $mline .= "\n"; 511 $state = $DO_DEFAULT; 512 } 513 else 514 { 515 $mline .= ";\n"; 516 $state = $DO_CLASS; 517 } 518 519 # $newline .= $mline; 520 # $funcline = ""; 521 522 return $mline; 523} 524 525# ================================================================================= 526# function b(x, y : type) : type; 527sub func2 528{ 529 my $funcline = shift; 530 tidy_line($funcline) =~ /(function)(.*)(\()(.*)(\))(.*\:)(.*)(;)/i; 531 532 $mline = "// function b(x, y : type) : type;\n"; 533 $mline .= "$7 $2 ("; 534 $v = $4; 535 536 process_params($v); 537 538 $mline .= ")"; 539 540 $function = 0; 541 if ( $type == 0) 542 { 543 if ( $implementation == 0 ) 544 { 545 $mline .= ";"; 546 } 547 548 $mline .= "\n"; 549 $state = $DO_DEFAULT; 550 } 551 else 552 { 553 $mline .= ";\n"; 554 $state = $DO_CLASS; 555 } 556 557 return $mline; 558 559} 560 561# ================================================================================= 562# function a.b : type; 563sub func3 564{ 565 my $funcline = shift; 566 567 tidy_line($funcline) =~ /(function)(.*)(\.)(.*)(:)(.*)(;)/i; 568 569 #$newline .= "func3 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 570 571 $mline = "// function a.b : type;\n"; 572 $mline .= "$6 $2::$4 ()"; 573 574 $function = 0; 575 if ( $type == 0) 576 { 577 if ( $implementation == 0 ) 578 { 579 $mline .= ";"; 580 } 581 582 $mline .= "\n"; 583 $state = $DO_DEFAULT; 584 } 585 else 586 { 587 $mline .= ";\n"; 588 $state = $DO_CLASS; 589 } 590 591 return $mline; 592} 593 594# ================================================================================= 595# function a.b; 596sub func4 597{ 598 my $funcline = shift; 599 600 tidy_line($funcline) =~ /(function)(.*)(\.)(.*)(;)/i; 601 602 #$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 603 604 $mline = "// function a.b;\n"; 605 $mline .= "void $2::$4 ()"; 606 607 $function = 0; 608 if ( $type == 0) 609 { 610 if ( $implementation == 0 ) 611 { 612 $mline .= ";"; 613 } 614 615 $mline .= "\n"; 616 $state = $DO_DEFAULT; 617 } 618 else 619 { 620 $mline .= ";\n"; 621 $state = $DO_CLASS; 622 } 623 624 625 return $mline; 626 627} 628 629# ================================================================================= 630# function a : type; 631sub func5 632{ 633 my $funcline = shift; 634 635 tidy_line($funcline) =~ /(function)(.*)(:)(.*)(;)/i; 636 637 $mline = "// function a : type;\n"; 638 $mline .= "$4 $2()"; 639 640 $function = 0; 641 if ( $type == 0) 642 { 643 if ( $implementation == 0 ) 644 { 645 $mline .= ";"; 646 } 647 648 $mline .= "\n"; 649 $state = $DO_DEFAULT; 650 } 651 else 652 { 653 $mline .= ";\n"; 654 $state = $DO_CLASS; 655 } 656 657 return $mline; 658} 659 660# ================================================================================= 661# function x; 662sub func6 663{ 664 my $funcline = shift; 665 666 tidy_line($funcline) =~ /(function)(.*)(;)/i; 667 668 $mline = "// function x;\n"; 669# $newline .= "func6 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 670 $mline .= "void $2 ()"; 671 672 $function = 0; 673 if ( $type == 0) 674 { 675 if ( $implementation == 0 ) 676 { 677 $mline .= ";"; 678 } 679 680 $mline .= "\n"; 681 $state = $DO_DEFAULT; 682 } 683 else 684 { 685 $mline .= ";\n"; 686 $state = $DO_CLASS; 687 } 688 689 return $mline; 690} 691# ================================================================================= 692 693 694# ================================================================================= 695# Parse procedure line 696sub parse_procedure 697{ 698# $newline .= "parsing procedure\n"; 699# $newline .= "\n>> $funcline<<\n"; 700 701# procedure a.b(x, y : type); 702# procedure b(x, y : type); 703# procedure a.b; 704# procedure a; 705 706# remove safecall line 707 $funcline =~ s/safecall\;//; 708 709 $mline = ""; 710 711 # procedure a.b(x, y : type); 712 if ( tidy_line($funcline) =~ /(procedure)(.*)(\.)([^(]*)(.*\()(.*)(\))(.*)(;)/i ) 713 { 714 $mline = proc1($funcline); 715 } 716 # procedure b(x, y : type); 717 elsif ( tidy_line($funcline) =~ /(procedure)(.*)(\()(.*)(\))(.*)(;)/i ) 718 { 719 $mline = proc2($funcline); 720 } 721 # procedure a.b; 722 elsif ( tidy_line($funcline) =~ /(procedure)(.*)(\.)(.*)(;)/i ) 723 { 724 $mline = proc3($funcline); 725 } 726 # procedure a; 727 else 728 { 729 $mline = proc4($funcline); 730 } 731 732 $newline .= $mline; 733 $funcline = ""; 734} 735 736 737 738# ================================================================================= 739# procedure a.b(x, y : type); 740sub proc1 741{ 742 my $funcline = shift; 743 744 tidy_line($funcline) =~ /(procedure)(.*)(\.)([^(]*)(.*\()(.*)(\))(.*)(;)/i; 745 746 $mline = "// procedure a.b(x, y : type);\n"; 747#$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 748 $mline .= "void $2::$4 ("; 749 750 $v = $6; 751 process_params($v); 752 753 $mline .= ")"; 754 755 $procedure = 0; 756 if ( $type == 0) 757 { 758 759 if ( $implementation == 0 ) 760 { 761 $mline .= ";"; 762 } 763 764 $mline .= "\n"; 765 $state = $DO_DEFAULT; 766 } 767 else 768 { 769 $mline .= ";\n"; 770 $state = $DO_CLASS; 771 } 772 773 return $mline; 774} 775 776 777# ================================================================================= 778# procedure b(x, y : type); 779sub proc2 780{ 781 my $funcline = shift; 782 783 tidy_line($funcline) =~ /(procedure)(.*)(\()(.*)(\))(.*)(;)/i; 784 785 $mline = "// procedure b(x, y : type);\n"; 786#$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 787 788 $mline .= "void $2 ("; 789 790 $v = $4; 791# --- processing for COM stuff 792 $v =~ s/ out / \[out\] /g; 793# --- 794 795 process_params($v); 796 797 $mline .= ")"; 798 799 $procedure = 0; 800 if ( $type == 0) 801 { 802 803 if ( $implementation == 0 ) 804 { 805 $mline .= ";"; 806 } 807 808 $mline .= "\n"; 809 $state = $DO_DEFAULT; 810 } 811 else 812 { 813 $mline .= ";\n"; 814 $state = $DO_CLASS; 815 } 816 817 return $mline; 818} 819 820# ================================================================================= 821# procedure a.b; 822sub proc3 823{ 824 my $funcline = shift; 825 826 tidy_line($funcline) =~ /(procedure)(.*)(\.)(.*)(;)/i; 827 828 $mline = "// procedure a.b;\n"; 829#$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 830 $mline .= "void $2::$4 ()"; 831 832 $procedure = 0; 833 if ( $type == 0) 834 { 835 836 if ( $implementation == 0 ) 837 { 838 $mline .= ";"; 839 } 840 841 $mline .= "\n"; 842 $state = $DO_DEFAULT; 843 } 844 else 845 { 846 $mline .= ";\n"; 847 $state = $DO_CLASS; 848 } 849 850 return $mline; 851} 852 853 854# ================================================================================= 855# procedure a; 856sub proc4 857{ 858 my $funcline = shift; 859 860 tidy_line($funcline) =~ /(procedure)(.*)(;)/i; 861 862 $mline = "// procedure a;\n"; 863#$newline .= "pf0 - 1-$1,\n2-$2,\n3-$3,\n4-$4,\n5-$5,\n6-$6,\n7-$7,\n8-$8,\n9-$9,\n10-$10\n"; 864 $mline .= "void $2 ()"; 865 866 $procedure = 0; 867 if ( $type == 0) 868 { 869 if ( $implementation == 0 ) 870 { 871 $mline .= ";"; 872 } 873 874 $mline .= "\n"; 875 $state = $DO_DEFAULT; 876 } 877 else 878 { 879 $mline .= ";\n"; 880 $state = $DO_CLASS; 881 } 882 883 return $mline; 884} 885 886# ================================================================================= 887sub process_file 888{ 889 my $fle = shift; 890 open (CFG, $fle); 891 print STDERR "Analyzing $fle\n"; 892 893 analyse_file ($fle); 894} 895 896# ================================================================================= 897sub process_list 898{ 899 my $list = shift; 900 901 #open the file to read the list of projects from 902 open (FILE, "<$list"); 903 904 # while we still have files to iterate through 905 open (FILE, "<$list"); 906 907 print STDERR "Analyzing list $list...\n"; 908 909 while ($fle = <FILE> ) 910 { 911 process_file ($fle); 912 } 913 914 close (FILE); 915} 916 917sub analyse_file 918{ 919 my $fle = shift; 920 921 if ( $fle =~ /(.*)\.(.+)$/ ) 922 { 923 $name = $1; 924 # $2 will hold the extension, TODO convert .pas files only. 925 } 926 927 print STDERR "\tConverting file $fle"; 928 929# open file for output 930 931 $outname = $name; 932 $outname .= "."; 933 $outname .= "cpp"; 934 935 open (OUT, ">$outname"); 936 937# reset flags 938 939 $newline = ""; # line to be generated 940 $funcline = ""; # function line being generated 941 $block_cnt = 0; # block counter 942 $skip = 1; # skip lines 943 $function = 0; # processing function 944 $procedure = 0; # processing procedure 945 $split_line = 0; # func/proc split over multiple lines 946 $implementation = 0; # implementation not reached yet 947 948 $DO_DEFAULT = 1; 949 $DO_BLOCK = 2; 950 $DO_CLASS = 3; 951 $DO_CONST = 4; 952 $DO_FUNCTION = 5; 953 $DO_PROCEDURE = 6; 954 $DO_CLASSFUNCTION = 7; 955 $DO_CLASSPROCEDURE = 8; 956 $DO_DISPINTERFACE = 9; 957 958 $state = $DO_DEFAULT; 959 960 while ( $line = <CFG> ) 961 { 962LOOP: 963 { 964# $newline .= "$function, $split_line, $state, line = $line\n"; 965 if ( $state == $DO_DEFAULT ) 966 { 967# Ignore comments 968 if ( $line =~ m/^\/\// ) 969 { 970 $newline .= $line; 971 last; 972 } 973 elsif ( $line =~ /(.*{)(.*)(.*})/ ) 974 { 975 $newline .= "/*$2*/\n"; 976 $skip = 1; 977 last; 978 } 979 elsif ( $line =~ /(.*{)(.*)/ ) 980 { 981 $newline .= "/* $2"; 982 $skip = 1; 983 last; 984 } 985 elsif ( $line =~ /(.*})/ ) 986 { 987 $newline .= "$1 */\n"; 988 $skip = 0; 989 last; 990 } 991 elsif( $line =~ m/^type/i ) 992 { 993 $skip = 0; 994 } 995 elsif ( $line =~ m/^constructor/i ) 996 { 997 $skip = 1; 998 } 999 elsif ( $line =~ m/destructor/i ) 1000 { 1001 $skip = 1; 1002 } 1003 elsif ( $line =~ m/^const/i ) 1004 { 1005 $state = $DO_CONST; 1006 $skip = 1; 1007 } 1008 elsif ( tidy_line($line) =~ m/^begin/i ) # process begin block 1009 { 1010 $skip = 0; 1011 $state = $DO_BLOCK; 1012 $block_cnt++; 1013 $newline .= "{\n"; 1014 } 1015 elsif ( tidy_line($line) =~ m/^var/i ) # variable block 1016 { 1017 $state = $DO_DEFAULT; 1018 $skip = 1; 1019 } 1020 elsif ( tidy_line($line) =~ m/^implementation/i ) 1021 { 1022 $state = $DO_DEFAULT; 1023 $skip = 0; 1024 $implementation = 1; 1025 last; 1026 } 1027 elsif ( tidy_line($line) =~ m/^function/i ) 1028 { 1029 $state = $DO_FUNCTION; 1030 $function = 1; 1031 } 1032 elsif ( tidy_line($line) =~ /class/i ) 1033 { 1034 if ( tidy_line($line) =~ m/^class/i ) 1035 { 1036 if ( tidy_line($line) =~ /class function/i ) 1037 { 1038 $line =~ s/class //g; 1039 $state = $DO_FUNCTION; 1040 $function = 1; 1041 } 1042 else 1043 { 1044 $state = $DO_CLASS; 1045 } 1046 } 1047 elsif ( tidy_line($line) =~ /(.*)(\=)(.*)(class)/i ) 1048 { 1049#$newline .= "aclass $1\n{\n"; 1050 $state = $DO_CLASS; 1051 } 1052 1053 } 1054 elsif ( tidy_line($line) =~ m/^procedure/i ) 1055 { 1056 $state = $DO_PROCEDURE; 1057 $procedure = 1; 1058 } 1059 elsif ( tidy_line($line) =~ /dispinterface/i ) 1060 { 1061 if ( tidy_line($line) =~ /(.*)(\=)(.*)(;)/ ) 1062 { 1063 $newline .= "$3 $1;\n"; 1064 last; 1065 } 1066 else 1067 { 1068 if ( tidy_line($line) =~ /(.*)(\=)(.*)/ ) 1069 { 1070 $newline .= "dispinterface $1\n{\n"; 1071 } 1072 1073 $state = $DO_CLASS; 1074 last LOOP; 1075 } 1076 } 1077 elsif ( tidy_line($line) =~ /interface/i ) 1078 { 1079#$newline .= "// 2 >>> $line\n"; 1080 1081 if ( tidy_line($line) =~ /(.*)(\=)(.*)(;)/i ) 1082 { 1083 $newline .= "interface $1;\n"; 1084 } 1085 elsif ( tidy_line($line) =~ /^interface/i ) 1086 { 1087 $newline .= "// interface ignored\n"; 1088 } 1089 elsif ( tidy_line($line) =~ /(.*)(\=)(.*)(interface)([^(]*)(.*\()(.*)(\))(.*)/i ) 1090 { 1091 $newline .= "interface $1 : $7\n{\n"; 1092 $state = $DO_CLASS; 1093 } 1094 else 1095 { 1096#$newline .= ">>> 1 - $line\n"; 1097$state = $DO_CLASS; 1098 last LOOP; 1099 } 1100 1101 last; 1102#$state = $DO_CLASS; 1103 } 1104 1105 1106 1107# Working on a function 1108 if ( $state == $DO_FUNCTION ) 1109 { 1110#$newline .= "about to process a function\n"; 1111 if ( build_line ($line, "0", 1) == 1 ) 1112 { 1113 $function = 1; 1114 $split_line = 1; 1115 } 1116 else 1117 { 1118 $function = 0; 1119 $split_line = 0; 1120 } 1121 last LOOP; 1122 }; 1123 1124# Working on a procedure 1125 if ( $state == $DO_PROCEDURE ) 1126 { 1127 if ( build_line ($line, "0", 0) == 1 ) 1128 { 1129 $procedure = 1; 1130 $split_line = 1; 1131 } 1132 else 1133 { 1134 $procedure = 0; 1135 $split_line = 0; 1136 } 1137 last LOOP; 1138 }; 1139 1140#$newline .= "about to do block - $line\n"; 1141 if ( $block_cnt == 0) 1142 { 1143 if ( $skip == 0 ) 1144 { 1145 if ( $line =~ /(^.*)( = class)()(.*)$/i) # class definition 1146 { 1147 $newline .= "class "; 1148 $newline .= $1; 1149 $newline .= ":"; 1150 $newline .= $4; 1151 $newline .= "{\n"; 1152 $state = $DO_CLASS; 1153 } 1154 else # Get rid of { } style commenting 1155 { 1156 $line =~ s/{/\/\/\/ /; 1157 $line =~ s/}//; 1158 1159 if ( tidy_line($line) =~ m/procedure/i ) 1160 { 1161 build_line ($line, "1", 0); 1162 } 1163 else 1164 { 1165 if ( tidy_line($line) =~ m/^\/\// ) 1166 { 1167 $newline .= $line; 1168 } 1169 else 1170 { 1171 $newline .= "// > $line"; 1172 } 1173 } 1174 } 1175 } 1176 } 1177 1178 last LOOP; 1179 }; 1180 1181 1182 if ( $state == $DO_BLOCK ) 1183 { 1184 if ( $line =~ m/^end/i ) # end block 1185 { 1186 $state = $DO_DEFAULT; 1187 $block_cnt--; 1188 $newline .= "}"; 1189 $newline .= "\n"; 1190 } 1191 1192 last LOOP; 1193 }; 1194 1195 if ( $state == $DO_CONST ) 1196 { 1197#NAME = 'SOMETHING'; 1198 if ( $line =~ /([^=]*)(.*=)(.*)(;)(.*)/i ) 1199 { 1200 $newline .= "#define "; 1201 $newline .= $1; 1202 $newline .= " "; 1203 $newline .= $3; 1204 $newline .= ";\n"; 1205 } 1206 else 1207 { 1208 $newline .= "// const error - "; 1209# $newline .= $line; 1210 $state = $DO_DEFAULT; 1211 $skip = 0; 1212 } 1213 1214 last LOOP; 1215 }; 1216 1217# Working on a class structure 1218 if ( $state == $DO_CLASS ) 1219 { 1220#$newline .= "then got here - $line \n"; 1221 process_class ($line); 1222 1223 last LOOP; 1224 }; 1225 1226# working on function split over lines 1227 if ( $state == $DO_FUNCTION ) 1228 { 1229 if ( build_line ($line, "0", 1) == 0) 1230 { 1231 $function = 0; 1232 $split_line = 0; 1233 $state = $DO_DEFAULT; 1234 } 1235 }; 1236 1237# working on class function declaration, split over lines 1238 if ( $state == $DO_CLASSFUNCTION ) 1239 { 1240 if ( build_line ($line, "1", 1) == 0) 1241 { 1242 $function = 0; 1243 $split_line = 0; 1244 $state = $DO_CLASS; 1245 } 1246 }; 1247 1248# working on procedure split over lines 1249 if ( $state == $DO_PROCEDURE ) 1250 { 1251 if ( build_line ($line, "0", 0) == 0) 1252 { 1253 $procedure = 0; 1254 $split_line = 0; 1255 $state = $DO_DEFAULT; 1256 } 1257 }; 1258 1259 1260# working on class procedure declaration, split over lines 1261 if ( $state == $DO_CLASSPROCEDURE ) 1262 { 1263 if ( build_line ($line, "1", 0) == 0) 1264 { 1265 $procedure = 0; 1266 $split_line = 0; 1267 $state = $DO_CLASS; 1268 } 1269 }; 1270} 1271} 1272 1273print OUT $newline; 1274close (OUT); 1275 1276 1277} 1278