1#!/usr/local/bin/perl 2########################################################################### 3# API Sanity Checker 1.98.4 4# An automatic generator of basic unit tests for a C/C++ library API 5# 6# Copyright (C) 2009-2010 The Linux Foundation 7# Copyright (C) 2009-2011 Institute for System Programming, RAS 8# Copyright (C) 2011-2013 ROSA Laboratory 9# 10# Written by Andrey Ponomarenko 11# 12# PLATFORMS 13# ========= 14# Linux, FreeBSD, Mac OS X, MS Windows 15# 16# REQUIREMENTS 17# ============ 18# Linux 19# - ABI Compliance Checker (1.99 or newer) 20# - G++ (3.0-4.7, recommended 4.5 or newer) 21# - GNU Binutils (readelf, c++filt, objdump) 22# - Perl 5 (5.8 or newer) 23# - Ctags (5.8 or newer) 24# 25# Mac OS X 26# - ABI Compliance Checker (1.99 or newer) 27# - Xcode (gcc, c++filt, nm) 28# - Ctags (5.8 or newer) 29# 30# MS Windows 31# - ABI Compliance Checker (1.99 or newer) 32# - MinGW (3.0-4.7, recommended 4.5 or newer) 33# - MS Visual C++ (dumpbin, undname, cl) 34# - Active Perl 5 (5.8 or newer) 35# - Ctags (5.8 or newer) 36# - Add tool locations to the PATH environment variable 37# - Run vsvars32.bat (C:\Microsoft Visual Studio 9.0\Common7\Tools\) 38# 39# This program is free software: you can redistribute it and/or modify 40# it under the terms of the GNU General Public License or the GNU Lesser 41# General Public License as published by the Free Software Foundation. 42# 43# This program is distributed in the hope that it will be useful, 44# but WITHOUT ANY WARRANTY; without even the implied warranty of 45# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 46# GNU General Public License for more details. 47# 48# You should have received a copy of the GNU General Public License 49# and the GNU Lesser General Public License along with this program. 50# If not, see <http://www.gnu.org/licenses/>. 51########################################################################### 52use Getopt::Long; 53Getopt::Long::Configure ("posix_default", "no_ignore_case"); 54use POSIX qw(setsid); 55use File::Path qw(mkpath rmtree); 56use File::Temp qw(tempdir); 57use File::Copy qw(copy); 58use Cwd qw(abs_path cwd realpath); 59use Config; 60 61my $TOOL_VERSION = "1.98.4"; 62my $OSgroup = get_OSgroup(); 63my $ORIG_DIR = cwd(); 64my $TMP_DIR = tempdir(CLEANUP=>1); 65 66my $ABICC = "/usr/local/bin/abi-compliance-checker.pl"; 67my $ABICC_VERSION = "1.99"; 68 69# Internal modules 70my $MODULES_DIR = get_Modules(); 71push(@INC, get_dirname($MODULES_DIR)); 72 73my ($Help, $InfoMsg, $TargetLibraryName, $GenerateTests, $TargetInterfaceName, 74$BuildTests, $RunTests, $CleanTests, $DisableReuse, $LongVarNames, %Descriptor, 75$UseXvfb, $TestTool, $MinimumCode, $TestDataPath, $MaximumCode, $RandomCode, 76$GenerateDescriptorTemplate, $GenerateSpecTypeTemplate, $InterfacesListPath, 77$SpecTypes_PackagePath, $CheckReturn, $DisableDefaultValues, $ShowRetVal, 78$CheckHeadersOnly, $Template2Code, $Standalone, $ShowVersion, $MakeIsolated, 79$ParameterNamesFilePath, $CleanSources, $DumpVersion, $TargetHeaderName, 80$RelativeDirectory, $TargetLibraryFullName, $TargetVersion, $StrictGen, 81$StrictBuild, $StrictRun, $Strict, $Debug, $UseCache, $NoInline, $Browse, 82$OpenReport, $UserLang, $OptimizeIncludes, $KeepInternal, $TargetCompiler); 83 84my $CmdName = get_filename($0); 85my %OS_LibExt=( 86 "linux"=>"so", 87 "macos"=>"dylib", 88 "windows"=>"dll", 89 "symbian"=>"dso", 90 "default"=>"so" 91); 92 93my %ERROR_CODE = ( 94 # Passed 95 "Success"=>0, 96 # Failed 97 "Failed"=>1, 98 # Undifferentiated error code 99 "Error"=>2, 100 # Cannot access input files 101 "Access_Error"=>4, 102 # Cannot find a module 103 "Module_Error"=>9 104); 105 106my %HomePage = ( 107 "Wiki"=>"http://ispras.linuxbase.org/index.php/API_Sanity_Checker", 108 "Dev"=>"https://github.com/lvc/api-sanity-checker" 109); 110 111my $ShortUsage = "API Sanity Checker $TOOL_VERSION 112Unit test generator for a C/C++ library API 113Copyright (C) 2013 ROSA Lab 114License: GNU LGPL or GNU GPL 115 116Usage: $CmdName [options] 117Example: $CmdName -lib NAME -d VER.xml -gen -build -run 118 119VER.xml is XML-descriptor: 120 121 <version> 122 1.0 123 </version> 124 125 <headers> 126 /path/to/headers/ 127 </headers> 128 129 <libs> 130 /path/to/libraries/ 131 </libs> 132 133More info: $CmdName --help\n"; 134 135if($#ARGV==-1) 136{ 137 print $ShortUsage; 138 exit(0); 139} 140 141my @INPUT_OPTIONS = @ARGV; 142 143GetOptions("h|help!" => \$Help, 144 "info!" => \$InfoMsg, 145 "v|version!" => \$ShowVersion, 146 "dumpversion!" => \$DumpVersion, 147# general options 148 "l|lib|library=s" => \$TargetLibraryName, 149 "d|descriptor=s" => \$Descriptor{"Path"}, 150 "gen|generate!" => \$GenerateTests, 151 "build|make!" => \$BuildTests, 152 "run!" => \$RunTests, 153 "clean!" => \$CleanTests, 154# extra options 155 "d-tmpl|descriptor-template!" =>\$GenerateDescriptorTemplate, 156 "s-tmpl|specialized-type-template!" =>\$GenerateSpecTypeTemplate, 157 "vnum=s" =>\$TargetVersion, 158 "s|symbol|f|function|i|interface=s" => \$TargetInterfaceName, 159 "symbols-list|functions-list|interfaces-list=s" => \$InterfacesListPath, 160 "header=s" => \$TargetHeaderName, 161 "xvfb!" => \$UseXvfb, 162 "t2c|template2code" => \$Template2Code, 163 "strict-gen!" => \$StrictGen, 164 "strict-build!" => \$StrictBuild, 165 "strict-run!" => \$StrictRun, 166 "strict!" => \$Strict, 167 "r|random!" =>\$RandomCode, 168 "min!" =>\$MinimumCode, 169 "max!" =>\$MaximumCode, 170 "show-retval!" => \$ShowRetVal, 171 "check-retval!" => \$CheckReturn, 172 "st|specialized-types=s" => \$SpecTypes_PackagePath, 173 "td|test-data=s" => \$TestDataPath, 174 "headers-only!" => \$CheckHeadersOnly, 175 "no-inline!" => \$NoInline, 176 "keep-internal!" => \$KeepInternal, 177 "isolated!" => \$MakeIsolated, 178 "view-only!" => \$CleanSources, 179 "disable-default-values!" => \$DisableDefaultValues, 180 "optimize-includes=s" => \$OptimizeIncludes, 181 "p|params=s" => \$ParameterNamesFilePath, 182 "l-full|lib-full=s" => \$TargetLibraryFullName, 183 "relpath|reldir=s" => \$RelativeDirectory, 184 "lang=s" => \$UserLang, 185 "target=s" => \$TargetCompiler, 186 "debug!" => \$Debug, 187 "cache!" => \$UseCache, 188# other options 189 "test!" => \$TestTool, 190 "disable-variable-reuse!" => \$DisableReuse, 191 "long-variable-names!" => \$LongVarNames, 192 "b|browse=s" => \$Browse, 193 "open!" => \$OpenReport 194) or ERR_MESSAGE(); 195 196sub ERR_MESSAGE() 197{ 198 print $ShortUsage; 199 exit(1); 200} 201 202my $LIB_EXT = $OS_LibExt{$OSgroup}?$OS_LibExt{$OSgroup}:$OS_LibExt{"default"}; 203 204my $HelpMessage=" 205NAME: 206 API Sanity Checker ($CmdName) 207 Generate basic unit tests for a C/C++ library API 208 209DESCRIPTION: 210 API Sanity Checker is an automatic generator of basic unit tests for a C/C++ 211 library. It helps to quickly generate simple (\"sanity\" or \"shallow\" 212 quality) tests for every function in an API using their signatures, data type 213 definitions and relationships between functions straight from the library 214 header files (\"Header-Driven Generation\"). Each test case contains a function 215 call with reasonable (in most, but unfortunately not all, cases) input 216 parameters. The quality of generated tests allows to check absence of critical 217 errors in simple use cases and can be greatly improved by involving of highly 218 reusable specialized types for the library. 219 220 The tool can execute generated tests and detect crashes, aborts, all kinds of 221 emitted signals, non-zero program return code, program hanging and requirement 222 failures (if specified). The tool can be considered as a tool for out-of-box 223 low-cost sanity checking of library API or as a test development framework for 224 initial generation of templates for advanced tests. Also it supports universal 225 Template2Code format of tests, splint specifications, random test generation 226 mode and other useful features. 227 228 This tool is free software: you can redistribute it and/or modify it 229 under the terms of the GNU LGPL or GNU GPL. 230 231USAGE: 232 $CmdName [options] 233 234EXAMPLE: 235 $CmdName -lib NAME -d VER.xml -gen -build -run 236 237 VERSION.xml is XML-descriptor: 238 239 <version> 240 1.0 241 </version> 242 243 <headers> 244 /path1/to/header(s)/ 245 /path2/to/header(s)/ 246 ... 247 </headers> 248 249 <libs> 250 /path1/to/library(ies)/ 251 /path2/to/library(ies)/ 252 ... 253 </libs> 254 255INFORMATION OPTIONS: 256 -h|-help 257 Print this help. 258 259 -info 260 Print complete info. 261 262 -v|-version 263 Print version information. 264 265 -dumpversion 266 Print the tool version ($TOOL_VERSION) and don't do anything else. 267 268GENERAL OPTIONS: 269 -l|-lib|-library NAME 270 Library name (without version). 271 272 -d|-descriptor PATH 273 Path to the library descriptor (VER.xml file): 274 275 <version> 276 1.0 277 </version> 278 279 <headers> 280 /path1/to/header(s)/ 281 /path2/to/header(s)/ 282 ... 283 </headers> 284 285 <libs> 286 /path1/to/library(ies)/ 287 /path2/to/library(ies)/ 288 ... 289 </libs> 290 291 ... (XML-descriptor template 292 can be generated by -d-tmpl option) 293 294 For more information, please see: 295 http://ispras.linuxbase.org/index.php/Library_Descriptor 296 297 -gen|-generate 298 Generate test(s). Options -l and -d should be specified. 299 To generate test for the particular function use it with -f option. 300 Exit code: number of test cases failed to build. 301 302 -build|-make 303 Build test(s). Options -l and -d should be specified. 304 To build test for the particular function use it with -f option. 305 Exit code: number of test cases failed to generate. 306 307 -run 308 Run test(s), create test report. Options -l and -d should be specified. 309 To run test for the particular function use it with -f option. 310 Exit code: number of failed test cases. 311 312 -clean 313 Clean test(s). Options -l and -d should be specified. 314 To clean test for the particular function use it with -f option.\n"; 315 316sub HELP_MESSAGE() { 317 print $HelpMessage." 318MORE INFO: 319 $CmdName --info\n\n"; 320} 321 322sub INFO_MESSAGE() 323{ 324 printMsg("INFO", "$HelpMessage 325EXTRA OPTIONS: 326 -d-tmpl|-descriptor-template 327 Create XML-descriptor template ./VERSION.xml 328 329 -s-tmpl|specialized-type-template 330 Create specialized type template ./SPECTYPES.xml 331 332 -vnum NUM 333 Specify library version outside the descriptor. 334 335 -s|-symbol NAME 336 Generate/Build/Run test for the specified function 337 (mangled name in C++). 338 339 -symbols-list PATH 340 This option allows to specify a file with a list of functions 341 (one per line, mangled name in C++) that should be tested, 342 other library functions will not be tested. 343 344 -header NAME 345 This option allows to restrict a list of functions that should be tested 346 by providing a header file name in which they are declared. This option 347 is intended for step-by-step tests development. 348 349 -xvfb 350 Use Xvfb-server instead of current X-server (default) 351 for running tests. 352 353 -t2c|-template2code 354 Generate tests in the universal Template2Code format. 355 For more information, please see: 356 http://sourceforge.net/projects/template2code/ 357 358 -strict-gen 359 Terminate the process of generating tests and return 360 error code '1' if cannot generate at least one test case. 361 362 -strict-build 363 Terminate the process of building tesst and return 364 error code '1' if cannot build at least one test case. 365 366 -strict-run 367 Terminate the process of running tests and return 368 error code '1' if at least one test case failed. 369 370 -strict 371 This option enables all -strict-* options. 372 373 -r|-random 374 Random test generation mode. 375 376 -min 377 Generate minimun code, call functions with minimum number of parameters 378 to initialize parameters of other functions. 379 380 -max 381 Generate maximum code, call functions with maximum number of parameters 382 to initialize parameters of other functions. 383 384 -show-retval 385 Show the function return type in the report. 386 387 -check-retval 388 Insert requirements on return values (retval!=NULL) for each 389 called function. 390 391 -st|-specialized-types PATH 392 Path to the file with the collection of specialized types. 393 For more information, please see: 394 http://ispras.linuxbase.org/index.php/Specialized_Type 395 396 -td|-test-data PATH 397 Path to the directory with the test data files. 398 For more information, please see: 399 http://ispras.linuxbase.org/index.php/Specialized_Type 400 401 -headers-only 402 If the library consists of inline functions only and has no shared 403 objects then you should specify this option. 404 405 -no-inline 406 Don't generate tests for inline functions. 407 408 -keep-internal 409 Generate tests for internal symbols (functions with '__' prefix and 410 methods of classes declared inside other classes). 411 412 -isolated 413 Allow to restrict functions usage by the lists specified by the 414 -functions-list option or by the group devision in the descriptor. 415 416 -view-only 417 Remove all files from the test suite except *.html files. This option 418 allows to create a lightweight html-index for all tests. 419 420 -disable-default-values 421 Disable usage of default values for function parameters. 422 423 -optimize-includes LEVEL 424 Enable optimization of the list of included headers in each test case. 425 Available levels: 426 High (default) 427 Medium 428 Low 429 None - disable 430 431 -p|-params PATH 432 Path to file with the function parameter names. It can be used for 433 improving generated tests if the library header files don't contain 434 parameter names. File format: 435 436 func1;param1;param2;param3 ... 437 func2;param1;param2;param3 ... 438 ... 439 440 -l-full|-lib-full NAME 441 Library name in the report title. 442 443 -relpath|-reldir PATH 444 Replace {RELPATH} in the library descriptor by PATH. 445 446 -lang LANG 447 Set library language (C or C++). You can use this option if the tool 448 cannot auto-detect a language. 449 450 -target COMPILER 451 The compiler that should be used to build generated tests under Windows. 452 Supported: 453 gcc - GNU compiler 454 cl - MS compiler (default) 455 456 -debug 457 Write extended log for debugging. 458 459 -cache 460 Cache the ABI dump and use it on the next run. 461 462OTHER OPTIONS: 463 -test 464 Run internal tests. Create a simple library and run the tool on it. 465 This option allows to check if the tool works correctly on the system. 466 467 -disable-variable-reuse 468 Disable reusing of previously created variables in the test. 469 470 -long-variable-names 471 Enable long (complex) variable names instead of short names. 472 473 -b|-browse PROGRAM 474 Open report(s) in the browser (firefox, opera, etc.). 475 476 -open 477 Open report(s) in the default browser. 478 479EXIT CODES: 480 0 - Successful tests. The tool has run without any errors. 481 non-zero - Tests failed or the tool has run with errors. 482 483REPORT BUGS TO: 484 Andrey Ponomarenko <aponomarenko\@rosalab.ru> 485 486MORE INFORMATION: 487 ".$HomePage{"Wiki"}." 488 ".$HomePage{"Dev"}."\n"); 489} 490 491my $Descriptor_Template = " 492<?xml version=\"1.0\" encoding=\"utf-8\"?> 493<descriptor> 494 495/* XML-descriptor template */ 496 497/* Primary sections */ 498 499<version> 500 /* Version of the library */ 501</version> 502 503<headers> 504 /* The list of paths to header files and/or 505 directories with header files, one per line */ 506</headers> 507 508<libs> 509 /* The list of paths to shared libraries and/or 510 directories with libraries, one per line */ 511</libs> 512 513/* Optional sections */ 514 515<include_paths> 516 /* The list of paths to be searched for header files 517 needed for compiling of library headers, one per line. 518 NOTE: If you define this section then the tool 519 will not automatically detect include paths */ 520</include_paths> 521 522<add_include_paths> 523 /* The list of include paths that should be added 524 to the automatically detected include paths, one per line */ 525</add_include_paths> 526 527<gcc_options> 528 /* Additional GCC options, one per line */ 529</gcc_options> 530 531<include_preamble> 532 /* The list of header files that should be 533 included before other headers, one per line */ 534</include_preamble> 535 536<test_include_preamble> 537 /* The list of header files that should be 538 included in each test case before other 539 headers, one per line */ 540</test_include_preamble> 541 542<libs_depend> 543 /* The list of paths to libraries that should be 544 provided to gcc for resolving undefined symbols 545 (if NEEDED elf section doesn't include them) */ 546</libs_depend> 547 548<opaque_types> 549 /* The list of opaque types, one per line */ 550</opaque_types> 551 552<skip_symbols> 553 /* The list of functions (mangled names in C++) 554 that should not be called in the tests, one per line */ 555</skip_symbols> 556 557<skip_headers> 558 /* The list of header files and/or directories with header files 559 that should not be processed, one name per line */ 560</skip_headers> 561 562<skip_libs> 563 /* The list of shared libraries and/or directories with shared libraries 564 that should not be processed, one name per line */ 565</skip_libs> 566 567<defines> 568 /* Add defines at the headers compiling stage, one per line: 569 #define A B 570 #define C D */ 571</defines> 572 573<test_defines> 574 /* Add defines to test cases */ 575</test_defines> 576 577<libgroup> 578 <name> 579 /* Name of the libgroup */ 580 </name> 581 582 <symbols> 583 /* The list of symbols (mangled names in C++) 584 in the group that should be tested, one per line */ 585 </symbols> 586</libgroup> 587 588<out_params> 589 /* Associating of out(returned)-parameters 590 with symbols, one entry per line: 591 symbol:param_name 592 or 593 symbol:param_number 594 Examples: 595 dbus_parse_address:entry 596 dbus_parse_address:2 */ 597</out_params> 598 599<skip_warnings> 600 /* The list of warnings that should not be shown in the report, one pattern per line */ 601</skip_warnings> 602 603</descriptor>"; 604 605my $SpecType_Template=" 606<?xml version=\"1.0\" encoding=\"utf-8\"?> 607<collection> 608 609<!-- 610 C/C++ language extensions in the code: 611 \$(type) - instruction initializing an instance of data type 612 \$[symbol] - instruction for symbol call with properly initialized parameters 613 \$0 - an instance of the specialized type 614 \$1, \$2, ... - references to 1st, 2nd and other parameters 615 \$obj - reference to the object that current method calls on (C++ only) 616 For more information, please see: 617 http://ispras.linuxbase.org/index.php/Specialized_Type 618--> 619 620<spec_type> 621 <kind> 622 /* Kind of the specialized type. 623 Select it from the following list: 624 normal 625 common_param 626 common_retval 627 env 628 common_env */ 629 </kind> 630 631 <data_type> 632 /* Name of the corresponding real data type. 633 You can specify several data types if kind is 'common_param' 634 or 'common_retval', one per line. This section is not used 635 if kind is 'env' or 'common_env' */ 636 </data_type> 637 638 <value> 639 /* Value for initialization (true, 1.0, \"string\", ...) */ 640 </value> 641 642 <pre_condition> 643 /* Precondition on associated function parameter. 644 Example: \$0!=NULL */ 645 </pre_condition> 646 647 <post_condition> 648 /* Postcondition on associated function return value or parameter. 649 Example: \$0!=NULL && \$obj.style()==Qt::DotLine */ 650 </post_condition> 651 652 <decl_code> 653 /* Code that will be pasted instead of parameter automatic declaration. 654 Example: char \$0[16]; */ 655 </decl_code> 656 657 <init_code> 658 /* Code that should be invoked before function call. 659 Example: \$0->start(); */ 660 </init_code> 661 662 <final_code> 663 /* Code that should be invoked after function call 664 Example: \$0->end(); */ 665 </final_code> 666 667 <global_code> 668 /* Declarations of auxiliary functions 669 and global variables, header includes */ 670 </global_code> 671 672 <associating> 673 /* Several \"associating\" sections 674 are allowed simultaneously */ 675 676 <symbols> 677 /* List of symbols (mangled names in C++) 678 that will be associated with the specialized type, one per line */ 679 </symbols> 680 681 <except> 682 /* List of symbols (mangled names in C++) 683 that will not be associated with the specialized type, one per line. 684 This section is used if kind is 'common_env', 'common_param' 685 or 'common_return' */ 686 </except> 687 688 <links> 689 /* Associations with the return value, parameters 690 or/and object, one per line: 691 param1 692 param2 693 param3 694 ... 695 object 696 retval */ 697 </links> 698 699 <param_names> 700 /* Associations with the parameters by name, one per line: 701 param_name1 702 param_name2 703 param_name3 704 ... 705 */ 706 </param_names> 707 </associating> 708 709 <name> 710 /* Name of the specialized type */ 711 </name> 712 713 <libs> 714 /* External shared libraries, one per line. 715 If spectype contains call of the functions from 716 some external shared libraries then these objects 717 should be listed here. Corresponding external 718 header files should be included in global_code */ 719 </libs> 720</spec_type> 721 722<spec_type> 723 /* Other specialized type */ 724</spec_type> 725 726</collection>"; 727 728# Constants 729my $BUFF_SIZE = 256; 730my $DEFAULT_ARRAY_AMOUNT = 4; 731my $MAX_PARAMS_INLINE = 3; 732my $MAX_PARAMS_LENGTH_INLINE = 60; 733my $HANGED_EXECUTION_TIME = 7; 734my $TOOL_SIGNATURE; 735my $MIN_PARAMS_MATRIX = 8; 736my $MATRIX_WIDTH = 4; 737my $MATRIX_MAX_ELEM_LENGTH = 7; 738my $LIBRARY_PREFIX_MAJORITY = 10; 739 740my %Operator_Indication = ( 741 "not" => "~", 742 "assign" => "=", 743 "andassign" => "&=", 744 "orassign" => "|=", 745 "xorassign" => "^=", 746 "or" => "|", 747 "xor" => "^", 748 "addr" => "&", 749 "and" => "&", 750 "lnot" => "!", 751 "eq" => "==", 752 "ne" => "!=", 753 "lt" => "<", 754 "lshift" => "<<", 755 "lshiftassign" => "<<=", 756 "rshiftassign" => ">>=", 757 "call" => "()", 758 "mod" => "%", 759 "modassign" => "%=", 760 "subs" => "[]", 761 "land" => "&&", 762 "lor" => "||", 763 "rshift" => ">>", 764 "ref" => "->", 765 "le" => "<=", 766 "deref" => "*", 767 "mult" => "*", 768 "preinc" => "++", 769 "delete" => " delete", 770 "vecnew" => " new[]", 771 "vecdelete" => " delete[]", 772 "predec" => "--", 773 "postinc" => "++", 774 "postdec" => "--", 775 "plusassign" => "+=", 776 "plus" => "+", 777 "minus" => "-", 778 "minusassign" => "-=", 779 "gt" => ">", 780 "ge" => ">=", 781 "new" => " new", 782 "multassign" => "*=", 783 "divassign" => "/=", 784 "div" => "/", 785 "neg" => "-", 786 "pos" => "+", 787 "memref" => "->*", 788 "compound" => "," ); 789 790my %IsKeyword= map {$_=>1} ( 791 "delete", 792 "if", 793 "else", 794 "for", 795 "public", 796 "private", 797 "new", 798 "protected", 799 "main", 800 "sizeof", 801 "malloc", 802 "return", 803 "include", 804 "true", 805 "false", 806 "const", 807 "int", 808 "long", 809 "void", 810 "short", 811 "float", 812 "unsigned", 813 "char", 814 "double", 815 "class", 816 "struct", 817 "union", 818 "enum", 819 "volatile", 820 "restrict" 821); 822 823my %ShortTokens=( 824 "err"=>"error", 825 "warn"=>"warning" ); 826 827# Global variables 828my $ST_ID=0; 829my $REPORT_PATH; 830my $TEST_SUITE_PATH; 831my $DEBUG_PATH; 832my $CACHE_PATH; 833my $LOG_PATH; 834my %Interface_TestDir; 835my %LibsDepend; 836my $CompilerOptions_Libs; 837my $CompilerOptions_Cflags; 838my %Language; 839my %Cache; 840my $TestedInterface; 841my $COMMON_LANGUAGE; 842my %SubClass_Created; 843my %Constants; 844my $MaxTypeId_Start; 845my $STAT_FIRST_LINE; 846 847# Mangling 848my %tr_name; 849 850# Types 851my %TypeInfo; 852my %OpaqueTypes; 853my %TName_Tid; 854my %StructUnionPName_Tid; 855my %Class_Constructors; 856my %Class_Destructors; 857my %ReturnTypeId_Interface; 858my %BaseType_PLevel_Return; 859my %OutParam_Interface; 860my %BaseType_PLevel_OutParam; 861my %Interface_OutParam; 862my %Interface_OutParam_NoUsing; 863my %OutParamInterface_Pos; 864my %OutParamInterface_Pos_NoUsing; 865my %Class_SubClasses; 866my %Type_Typedef; 867my %Typedef_BaseName; 868my %NameSpaces; 869my %NestedNameSpaces; 870my %EnumMembers; 871my %SubClass_Instance; 872my %SubClass_ObjInstance; 873my %BaseType_PLevel_Type; 874my %Struct_SubClasses; 875my %Struct_Parent; 876my %Library_Prefixes; 877my %Struct_Mapping; 878 879# Interfaces 880my %SymbolInfo; 881my %CompleteSignature; 882my %SkipInterfaces; 883my %SkipInterfaces_Pattern; 884my %Library_Class; 885my %Library_Symbol; 886my %DepLibrary_Symbol; 887my %Symbol_Library; 888my %DepSymbol_Library; 889my %UndefinedSymbols; 890my %Library_Needed; 891my %Class_PureVirtFunc; 892my %Class_Method; 893my %Class_PureMethod; 894my %Interface_Overloads; 895my %OverloadedInterface; 896my %InterfacesList; 897my %MethodNames; 898my %FuncNames; 899my %GlobalDataNames; 900my %Func_TypeId; 901my %Header_Interface; 902my %SoLib_IntPrefix; 903my $NodeInterface; 904my %LibGroups; 905my %Interface_LibGroup; 906my %AddIntParams; 907my %Func_ShortName_MangledName; 908my %UserDefinedOutParam; 909my $LibraryMallocFunc; 910my %LibraryInitFunc; 911my %LibraryExitFunc; 912 913# Headers 914my @Include_Preamble; 915my %SpecTypeHeaders; 916my %SkipWarnings; 917my %SkipWarnings_Pattern; 918my %Include_Order; 919my %Include_RevOrder; 920my $IncludeString; 921my %IncludePrefix; 922my %SkipHeaders; 923 924my %RegisteredHeaders; 925my %RegisteredHeaders_R; 926 927my %RegisteredIncludes; 928my %RegisteredIncludes_R; 929 930my %DirectIncludes; 931my %RecursiveIncludes; 932my %RecursiveIncludes_R; 933my %KnownHeaders; 934my %Include_Redirect; 935 936my $MAX_INC = 0; 937 938# Shared objects 939my %UsedSharedObjects; 940my %RegisteredLibs; 941my $LibString; 942my %KnownLibs; 943 944# Default paths 945my @DefaultLibPaths = (); # /usr/lib 946my @DefaultIncPaths = (); # /usr/include 947 948# Test results 949my %GenResult; 950my %BuildResult; 951my %RunResult; 952my %ResultCounter; 953 954#Signals 955my %SigNo; 956my %SigName; 957 958# Recursion locks 959my @RecurTypeId; 960my @RecurInterface; 961my @RecurSpecType; 962 963# Global state 964my (%ValueCollection, %Block_Variable, %UseVarEveryWhere, %SpecEnv, %Block_InsNum, $MaxTypeId, %Wrappers, 965%Wrappers_SubClasses, %IntSubClass, %IntrinsicNum, %AuxType, %AuxFunc, %UsedConstructors, 966%ConstraintNum, %RequirementsCatalog, %UsedProtectedMethods, %Create_SubClass, %SpecCode, 967%SpecLibs, %UsedInterfaces, %OpenStreams, %IntSpecType, %Block_Param, %Class_SubClassTypedef, %AuxHeaders, 968%Template2Code_Defines, %TraceFunc); 969 970# Block initialization 971my $CurrentBlock; 972 973# Special types 974my %SpecType; 975my %InterfaceSpecType; 976my %Common_SpecEnv; 977my %Common_SpecType_Exceptions; 978my %ProxyValue = (); 979 980# Report 981my $ContentSpanStart = "<span class=\"section\" onclick=\"javascript:showContent(this, 'CONTENT_ID')\"><span class='ext' style='padding-right:2px'>[+]</span>\n"; 982my $ContentSpanStart_Title = "<span class=\"section_title\" onclick=\"javascript:showContent(this, 'CONTENT_ID')\"><span class='ext_title' style='padding-right:2px'>[+]</span>\n"; 983my $ContentSpanEnd = "</span>\n"; 984my $ContentDivStart = "<div id=\"CONTENT_ID\" style=\"display:none;\">\n"; 985my $ContentDivEnd = "</div>\n"; 986my $ContentID = 1; 987my $Content_Counter = 0; 988 989# Test Case 990my $TestFormat; 991 992# Recursion Locks 993my @RecurLib; 994 995# Debug 996my %DebugInfo; 997 998sub get_Modules() 999{ 1000 my $TOOL_DIR = get_dirname($0); 1001 if(not $TOOL_DIR) 1002 { # patch for MS Windows 1003 $TOOL_DIR = "."; 1004 } 1005 my @SEARCH_DIRS = ( 1006 # tool's directory 1007 abs_path($TOOL_DIR), 1008 # relative path to modules 1009 abs_path($TOOL_DIR)."/../share/api-sanity-checker", 1010 # install path 1011 'MODULES_INSTALL_PATH' 1012 ); 1013 foreach my $DIR (@SEARCH_DIRS) 1014 { 1015 if(not is_abs($DIR)) 1016 { # relative path 1017 $DIR = abs_path($TOOL_DIR)."/".$DIR; 1018 } 1019 if(-d $DIR."/modules") { 1020 return $DIR."/modules"; 1021 } 1022 } 1023 exitStatus("Module_Error", "can't find modules"); 1024} 1025 1026my %LoadedModules = (); 1027 1028sub loadModule($) 1029{ 1030 my $Name = $_[0]; 1031 if(defined $LoadedModules{$Name}) { 1032 return; 1033 } 1034 my $Path = $MODULES_DIR."/Internals/$Name.pm"; 1035 if(not -f $Path) { 1036 exitStatus("Module_Error", "can't access \'$Path\'"); 1037 } 1038 require $Path; 1039 $LoadedModules{$Name} = 1; 1040} 1041 1042sub readModule($$) 1043{ 1044 my ($Module, $Name) = @_; 1045 my $Path = $MODULES_DIR."/Internals/$Module/".$Name; 1046 if(not -f $Path) { 1047 exitStatus("Module_Error", "can't access \'$Path\'"); 1048 } 1049 return readFile($Path); 1050} 1051 1052sub is_abs($) { 1053 return ($_[0]=~/\A(\/|\w+:[\/\\])/); 1054} 1055 1056sub get_abs_path($) 1057{ # abs_path() should NOT be called for absolute inputs 1058 # because it can change them 1059 my $Path = $_[0]; 1060 if(not is_abs($Path)) { 1061 $Path = abs_path($Path); 1062 } 1063 return $Path; 1064} 1065 1066sub get_OSgroup() 1067{ 1068 if($Config{"osname"}=~/macos|darwin|rhapsody/i) { 1069 return "macos"; 1070 } 1071 elsif($Config{"osname"}=~/freebsd|dragonfly|openbsd|netbsd/i) { 1072 return "bsd"; 1073 } 1074 elsif($Config{"osname"}=~/haiku|beos/i) { 1075 return "beos"; 1076 } 1077 elsif($Config{"osname"}=~/symbian|epoc/i) { 1078 return "symbian"; 1079 } 1080 elsif($Config{"osname"}=~/win/i) { 1081 return "windows"; 1082 } 1083 else { 1084 return $Config{"osname"}; 1085 } 1086} 1087 1088sub detectDisplay() 1089{ 1090 my $DISPLAY_NUM = 9; # default display number 1091 # use xprop to get a free display number 1092 foreach my $DNUM (9, 8, 7, 6, 5, 4, 3, 2, 10, 11, 12) 1093 { # try these display numbers only 1094 system("xprop -display :$DNUM".".0 -root >$TMP_DIR/null 2>&1"); 1095 if($? ne 0) 1096 { # no properties found for this display, guess it is free 1097 $DISPLAY_NUM = $DNUM; 1098 last; 1099 } 1100 } 1101 return ":$DISPLAY_NUM.0"; 1102} 1103 1104sub runXvfb() 1105{ 1106 # Find a free display to use for Xvfb 1107 my $XT_DISPLAY = detectDisplay(); 1108 my $TEST_DISPLAY = $XT_DISPLAY; 1109 my $running = `pidof Xvfb`; 1110 chomp($running); 1111 if(not $running or $OSgroup!~/\A(linux|bsd)\Z/) 1112 { 1113 printMsg("INFO", "starting X Virtual Frame Buffer on the display $TEST_DISPLAY"); 1114 system("Xvfb -screen 0 1024x768x24 $TEST_DISPLAY -ac +bs +kb -fp /usr/share/fonts/misc/ >$TMP_DIR/null 2>&1 & sleep 1"); 1115 if($?) { 1116 exitStatus("Error", "can't start Xvfb: $?"); 1117 } 1118 $ENV{"DISPLAY"} = $TEST_DISPLAY; 1119 $ENV{"G_SLICE"} = "always-malloc"; 1120 return 1; 1121 } 1122 else 1123 { 1124 # Xvfb is running, determine the display number 1125 my $CMD_XVFB = `ps -p "$running" -f | tail -n 1`; 1126 chomp($CMD_XVFB); 1127 $CMD_XVFB=~/(\:\d+\.0)/; 1128 $XT_DISPLAY = $1; 1129 $ENV{"DISPLAY"} = $XT_DISPLAY; 1130 $ENV{"G_SLICE"} = "always-malloc"; 1131 printMsg("INFO", "Xvfb is already running (display: $XT_DISPLAY), so it will be used"); 1132 return 0; 1133 } 1134} 1135 1136sub stopXvfb($) 1137{ 1138 if($_[0]==1) 1139 { 1140 my $pid = `pidof Xvfb`; 1141 chomp($pid); 1142 if($pid) { 1143 kill(9, $pid); 1144 } 1145 } 1146} 1147 1148sub parseTag($$) 1149{ 1150 my ($CodeRef, $Tag) = @_; 1151 return "" if(not $CodeRef or not ${$CodeRef} or not $Tag); 1152 if(${$CodeRef}=~s/\<\Q$Tag\E\>((.|\n)+?)\<\/\Q$Tag\E\>//) 1153 { 1154 my $Content = $1; 1155 $Content=~s/\A[\n]+//g; 1156 while($Content=~s/\A([ \t]+[\n]+)//g){} 1157 $Content=~s/\A[\n]+//g; 1158 $Content=~s/\s+\Z//g; 1159 if($Content=~/\n/) { 1160 $Content = alignSpaces($Content); 1161 } 1162 else { 1163 $Content=~s/\A[ \t]+//g; 1164 } 1165 return $Content; 1166 } 1167 else { 1168 return ""; 1169 } 1170} 1171 1172sub add_os_spectypes() 1173{ 1174 if($OSgroup eq "beos") 1175 { # http://www.haiku-os.org/legacy-docs/bebook/TheKernelKit_Miscellaneous.html 1176 readSpecTypes(" 1177 <spec_type> 1178 <name> 1179 disable debugger in Haiku 1180 </name> 1181 <kind> 1182 common_env 1183 </kind> 1184 <global_code> 1185 #include <kernel/OS.h> 1186 </global_code> 1187 <init_code> 1188 disable_debugger(1); 1189 </init_code> 1190 <libs> 1191 libroot.so 1192 </libs> 1193 <associating> 1194 <except> 1195 disable_debugger 1196 </except> 1197 </associating> 1198 </spec_type>"); 1199 } 1200} 1201 1202sub register_out_param($$$$) 1203{ 1204 my ($Interface, $ParamPos, $ParamName, $ParamTypeId) = @_; 1205 $OutParamInterface_Pos{$Interface}{$ParamPos}=1; 1206 $Interface_OutParam{$Interface}{$ParamName}=1; 1207 $BaseType_PLevel_OutParam{get_FoundationTypeId($ParamTypeId)}{get_PointerLevel($ParamTypeId)-1}{$Interface}=1; 1208 foreach my $TypeId (get_OutParamFamily($ParamTypeId, 0)) { 1209 $OutParam_Interface{$TypeId}{$Interface}=$ParamPos; 1210 } 1211} 1212 1213sub cmpVersions($$) 1214{ # compare two versions in dotted-numeric format 1215 my ($V1, $V2) = @_; 1216 return 0 if($V1 eq $V2); 1217 my @V1Parts = split(/\./, $V1); 1218 my @V2Parts = split(/\./, $V2); 1219 for (my $i = 0; $i <= $#V1Parts && $i <= $#V2Parts; $i++) 1220 { 1221 return -1 if(int($V1Parts[$i]) < int($V2Parts[$i])); 1222 return 1 if(int($V1Parts[$i]) > int($V2Parts[$i])); 1223 } 1224 return -1 if($#V1Parts < $#V2Parts); 1225 return 1 if($#V1Parts > $#V2Parts); 1226 return 0; 1227} 1228 1229sub numToStr($) 1230{ 1231 my $Number = int($_[0]); 1232 if($Number>3) { 1233 return $Number."th"; 1234 } 1235 elsif($Number==1) { 1236 return "1st"; 1237 } 1238 elsif($Number==2) { 1239 return "2nd"; 1240 } 1241 elsif($Number==3) { 1242 return "3rd"; 1243 } 1244 else { 1245 return $Number; 1246 } 1247} 1248 1249sub readSpecTypes($) 1250{ 1251 my $Package = $_[0]; 1252 return if(not $Package); 1253 $Package=~s/\/\*(.|\n)+?\*\///g; # remove C++ comments 1254 $Package=~s/<\!--(.|\n)+?-->//g; # remove XML comments 1255 if($Package!~/<collection>/ or $Package!~/<\/collection>/) 1256 { # add <collection> tag (support for old spectype packages) 1257 $Package = "<collection>\n".$Package."\n</collection>"; 1258 } 1259 while(my $Collection = parseTag(\$Package, "collection")) 1260 { 1261 # import specialized types 1262 while(my $SpecType = parseTag(\$Collection, "spec_type")) 1263 { 1264 $ST_ID+=1; 1265 my (%Attr, %DataTypes) = (); 1266 $Attr{"Kind"} = parseTag(\$SpecType, "kind"); 1267 $Attr{"Kind"} = "normal" if(not $Attr{"Kind"}); 1268 foreach my $DataType (split(/\n/, parseTag(\$SpecType, "data_type")), 1269 split(/\n/, parseTag(\$SpecType, "data_types"))) 1270 { # data_type==data_types, support of <= 1.5 versions 1271 $DataTypes{$DataType} = 1; 1272 if(not get_TypeIdByName($DataType)) { 1273 printMsg("ERROR", "unknown data type \'$DataType\' in one of the \'".$Attr{"Kind"}."\' spectypes, try to define it more exactly"); 1274 } 1275 } 1276 if(not keys(%DataTypes) and $Attr{"Kind"}=~/\A(normal|common_param|common_retval)\Z/) 1277 { 1278 printMsg("ERROR", "missed \'data_type\' attribute in one of the \'".$Attr{"Kind"}."\' spectypes"); 1279 next; 1280 } 1281 $Attr{"Name"} = parseTag(\$SpecType, "name"); 1282 $Attr{"Value"} = parseTag(\$SpecType, "value"); 1283 $Attr{"PreCondition"} = parseTag(\$SpecType, "pre_condition"); 1284 $Attr{"PostCondition"} = parseTag(\$SpecType, "post_condition"); 1285 if(not $Attr{"PostCondition"}) 1286 { # constraint==post_condition, support of <= 1.6 versions 1287 $Attr{"PostCondition"} = parseTag(\$SpecType, "constraint"); 1288 } 1289 $Attr{"InitCode"} = parseTag(\$SpecType, "init_code"); 1290 $Attr{"DeclCode"} = parseTag(\$SpecType, "decl_code"); 1291 $Attr{"FinalCode"} = parseTag(\$SpecType, "final_code"); 1292 $Attr{"GlobalCode"} = parseTag(\$SpecType, "global_code"); 1293 foreach my $Lib (split(/\n/, parseTag(\$SpecType, "libs"))) { 1294 $Attr{"Libs"}{$Lib} = 1; 1295 } 1296 if($Attr{"Kind"} eq "common_env") { 1297 $Common_SpecEnv{$ST_ID} = 1; 1298 } 1299 while(my $Associating = parseTag(\$SpecType, "associating")) 1300 { 1301 my (%Interfaces, %Except) = (); 1302 foreach my $Interface (split(/\n/, parseTag(\$Associating, "interfaces")), 1303 split(/\n/, parseTag(\$Associating, "symbols"))) 1304 { 1305 $Interface=~s/\A\s+|\s+\Z//g; 1306 $Interfaces{$Interface} = 1; 1307 $Common_SpecType_Exceptions{$Interface}{$ST_ID} = 0; 1308 if($Interface=~/\*/) 1309 { 1310 $Interface=~s/\*/.*/; 1311 foreach my $Int (keys(%CompleteSignature)) 1312 { 1313 if($Int=~/\A$Interface\Z/) 1314 { 1315 $Common_SpecType_Exceptions{$Int}{$ST_ID} = 0; 1316 $Interfaces{$Interface} = 1; 1317 } 1318 } 1319 } 1320 elsif(not defined $CompleteSignature{$Interface} 1321 or not $CompleteSignature{$Interface}{"ShortName"}) { 1322 printMsg("ERROR", "unknown symbol $Interface"); 1323 } 1324 } 1325 foreach my $Interface (split(/\n/, parseTag(\$Associating, "except"))) 1326 { 1327 $Interface=~s/\A\s+|\s+\Z//g; 1328 $Except{$Interface} = 1; 1329 $Common_SpecType_Exceptions{$Interface}{$ST_ID} = 1; 1330 if($Interface=~/\*/) 1331 { 1332 $Interface=~s/\*/.*/; 1333 foreach my $Int (keys(%CompleteSignature)) 1334 { 1335 if($Int=~/\A$Interface\Z/) 1336 { 1337 $Common_SpecType_Exceptions{$Int}{$ST_ID} = 1; 1338 $Except{$Int} = 1; 1339 } 1340 } 1341 } 1342 } 1343 if($Attr{"Kind"} eq "env") 1344 { 1345 foreach my $Interface (keys(%Interfaces)) 1346 { 1347 next if($Except{$Interface}); 1348 $InterfaceSpecType{$Interface}{"SpecEnv"} = $ST_ID; 1349 } 1350 } 1351 else 1352 { 1353 foreach my $Link (split(/\n/, parseTag(\$Associating, "links").parseTag(\$Associating, "param_num"))) 1354 { 1355 $Link=~s/\A\s+|\s+\Z//g; 1356 if(lc($Link)=~/\Aparam(\d+)\Z/) 1357 { 1358 my $Param_Num = $1; 1359 foreach my $Interface (keys(%Interfaces)) 1360 { 1361 next if($Except{$Interface}); 1362 if(defined $InterfaceSpecType{$Interface}{"SpecParam"}{$Param_Num - 1}) { 1363 printMsg("ERROR", "more than one spectypes have been linked to ".numToStr($Param_Num)." parameter of $Interface"); 1364 } 1365 $InterfaceSpecType{$Interface}{"SpecParam"}{$Param_Num - 1} = $ST_ID; 1366 } 1367 } 1368 elsif(lc($Link)=~/\Aobject\Z/) 1369 { 1370 foreach my $Interface (keys(%Interfaces)) 1371 { 1372 next if($Except{$Interface}); 1373 if(defined $InterfaceSpecType{$Interface}{"SpecObject"}) { 1374 printMsg("ERROR", "more than one spectypes have been linked to calling object of $Interface"); 1375 } 1376 $InterfaceSpecType{$Interface}{"SpecObject"} = $ST_ID; 1377 } 1378 } 1379 elsif(lc($Link)=~/\Aretval\Z/) 1380 { 1381 foreach my $Interface (keys(%Interfaces)) 1382 { 1383 next if($Except{$Interface}); 1384 if(defined $InterfaceSpecType{$Interface}{"SpecReturn"}) { 1385 printMsg("ERROR", "more than one spectypes have been linked to return value of $Interface"); 1386 } 1387 $InterfaceSpecType{$Interface}{"SpecReturn"} = $ST_ID; 1388 } 1389 } 1390 else { 1391 printMsg("ERROR", "unrecognized link \'$Link\' in one of the \'".$Attr{"Kind"}."\' spectypes"); 1392 } 1393 } 1394 foreach my $Name (split(/\n/, parseTag(\$Associating, "param_name"))) 1395 { 1396 $Name=~s/\A\s+|\s+\Z//g; 1397 if(keys(%Interfaces)) 1398 { 1399 foreach my $Interface (keys(%Interfaces)) 1400 { 1401 next if($Except{$Interface}); 1402 foreach my $ParamPos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 1403 { 1404 if($Name eq $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}) { 1405 $InterfaceSpecType{$Interface}{"SpecParam"}{$ParamPos} = $ST_ID; 1406 } 1407 } 1408 } 1409 } 1410 else 1411 { 1412 foreach my $Interface (keys(%CompleteSignature)) 1413 { 1414 next if($Except{$Interface}); 1415 foreach my $ParamPos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 1416 { 1417 if($Name eq $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}) 1418 { 1419 my $TypeId_Param = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"type"}; 1420 my $FTypeId_Param = get_FoundationTypeId($TypeId_Param); 1421 my $FTypeType_Param = get_TypeType($FTypeId_Param); 1422 foreach my $DataType (keys(%DataTypes)) 1423 { 1424 my $TypeId = get_TypeIdByName($DataType); 1425 if(my $FTypeId = get_FoundationTypeId($TypeId) and $FTypeId_Param) 1426 { 1427 if($FTypeType_Param eq "Intrinsic"?$TypeId==$TypeId_Param:$FTypeId==$FTypeId_Param) { 1428 $InterfaceSpecType{$Interface}{"SpecParam"}{$ParamPos} = $ST_ID; 1429 } 1430 } 1431 } 1432 } 1433 } 1434 } 1435 } 1436 } 1437 } 1438 } 1439 if($Attr{"Kind"}=~/\A(common_param|common_retval)\Z/) 1440 { 1441 foreach my $DataType (keys(%DataTypes)) 1442 { 1443 $Attr{"DataType"} = $DataType; 1444 %{$SpecType{$ST_ID}} = %Attr; 1445 $ST_ID+=1; 1446 } 1447 } 1448 elsif($Attr{"Kind"} eq "normal") 1449 { 1450 $Attr{"DataType"} = (keys(%DataTypes))[0]; 1451 %{$SpecType{$ST_ID}} = %Attr; 1452 } 1453 else { 1454 %{$SpecType{$ST_ID}} = %Attr; 1455 } 1456 } 1457 } 1458} 1459 1460sub join_P($$) 1461{ 1462 my $S = "/"; 1463 if($OSgroup eq "windows") { 1464 $S = "\\"; 1465 } 1466 return join($S, @_); 1467} 1468 1469sub registerHeader($$) 1470{ 1471 my ($Path, $To) = @_; 1472 my $Name = get_filename($Path); 1473 if(not defined $To->{$Name}) 1474 { 1475 $To->{$Name} = $Path; 1476 if(my $Prefix = getFilePrefix($Path)) { 1477 $To->{join_P($Prefix, $Name)} = $Path; 1478 } 1479 } 1480} 1481 1482sub registerDir($) 1483{ 1484 my $Path = $_[0]; 1485 foreach my $P (sort {length($b)<=>length($a)} cmd_find($Path,"f","","")) 1486 { # NOTE: duplicated 1487 registerHeader($P, \%RegisteredHeaders); 1488 $RegisteredHeaders_R{$P} = 1; 1489 } 1490} 1491 1492sub getFilePrefix($) 1493{ 1494 if(my $Dir = get_dirname($_[0])) 1495 { 1496 if($Dir = get_filename($Dir)) 1497 { 1498 if($Dir ne "include" 1499 and $Dir=~/\A[a-z]+\Z/i) { 1500 return $Dir; 1501 } 1502 } 1503 } 1504 return undef; 1505} 1506 1507sub registerHeaders($) 1508{ 1509 my $Path = $_[0]; 1510 if(-d $Path) { 1511 registerDir($Path); 1512 } 1513 elsif(-f $Path) 1514 { 1515 registerHeader($Path, \%RegisteredHeaders); 1516 $RegisteredHeaders_R{$Path} = 1; 1517 1518 if(my $Dir = get_dirname($Path)) { 1519 registerDir($Dir); 1520 } 1521 } 1522} 1523 1524sub registerLibs($) 1525{ 1526 my $Path = $_[0]; 1527 $Path = get_abs_path($Path); 1528 if(-d $Path) 1529 { 1530 foreach my $P (cmd_find($Path,"f","","")) { 1531 $RegisteredLibs{get_filename($P)} = $P; 1532 } 1533 } 1534 elsif(-f $Path) { 1535 $RegisteredLibs{get_filename($Path)} = $Path; 1536 } 1537} 1538 1539sub push_U($@) 1540{ # push unique 1541 if(my $Array = shift @_) 1542 { 1543 if(@_) 1544 { 1545 my %Exist = map {$_=>1} @{$Array}; 1546 foreach my $Elem (@_) 1547 { 1548 if(not defined $Exist{$Elem}) 1549 { 1550 push(@{$Array}, $Elem); 1551 $Exist{$Elem} = 1; 1552 } 1553 } 1554 } 1555 } 1556} 1557 1558sub readDescriptor($) 1559{ 1560 my $Path = $_[0]; 1561 1562 my $Content = readFile($Path); 1563 if(not $Content) { 1564 exitStatus("Error", "library descriptor is empty"); 1565 } 1566 if($Content!~/\</) { 1567 exitStatus("Error", "incorrect descriptor (see -d option)"); 1568 } 1569 $Content=~s/\/\*(.|\n)+?\*\///g; 1570 $Content=~s/<\!--(.|\n)+?-->//g; 1571 1572 $Descriptor{"Version"} = parseTag(\$Content, "version"); 1573 $Descriptor{"Version"} = $TargetVersion if($TargetVersion); 1574 if(not $Descriptor{"Version"}) { 1575 exitStatus("Error", "version in the descriptor is not specified (section <version>)"); 1576 } 1577 if($Content=~/{RELPATH}/) 1578 { 1579 if($RelativeDirectory) { 1580 $Content =~ s/{RELPATH}/$RelativeDirectory/g; 1581 } 1582 else { 1583 exitStatus("Error", "you have not specified -relpath option, but the descriptor contains {RELPATH} macro"); 1584 } 1585 } 1586 1587 $Descriptor{"Headers"} = parseTag(\$Content, "headers"); 1588 $Descriptor{"Libs"} = parseTag(\$Content, "libs"); 1589 1590 $Descriptor{"SkipHeaders"} = parseTag(\$Content, "skip_headers"); 1591 $Descriptor{"SkipIncluding"} = parseTag(\$Content, "skip_including"); 1592 1593 foreach my $Header (split(/\s*\n\s*/, parseTag(\$Content, "test_include_preamble"))) 1594 { 1595 push_U(\@Include_Preamble, $Header); 1596 } 1597 foreach my $Order (split(/\s*\n\s*/, parseTag(\$Content, "include_order"))) 1598 { 1599 if($Order=~/\A(.+):(.+)\Z/) { 1600 $Include_Order{$2} = $1; 1601 } 1602 } 1603 # $Include_Order{"freetype.h"} = "ft2build.h"; 1604 %Include_RevOrder = reverse(%Include_Order); 1605 1606 foreach my $Interface_Name (split(/\s*\n\s*/, parseTag(\$Content, "skip_interfaces")), 1607 split(/\s*\n\s*/, parseTag(\$Content, "skip_symbols"))) 1608 { 1609 if($Interface_Name=~s/\*/.*/g) { 1610 $SkipInterfaces_Pattern{$Interface_Name} = 1; 1611 } 1612 else { 1613 $SkipInterfaces{$Interface_Name} = 1; 1614 } 1615 } 1616 foreach my $Type_Name (split(/\s*\n\s*/, parseTag(\$Content, "opaque_types"))) 1617 { 1618 $OpaqueTypes{$Type_Name} = 1; 1619 } 1620 foreach my $Warning (split(/\s*\n\s*/, parseTag(\$Content, "skip_warnings"))) 1621 { 1622 if($Warning=~s/\*/.*/g) { 1623 $SkipWarnings_Pattern{$Warning} = 1; 1624 } 1625 else { 1626 $SkipWarnings{$Warning} = 1; 1627 } 1628 } 1629 1630 while(my $LibGroupTag = parseTag(\$Content, "libgroup")) 1631 { 1632 my $LibGroupName = parseTag(\$LibGroupTag, "name"); 1633 foreach my $Interface (split(/\s*\n\s*/, parseTag(\$LibGroupTag, "interfaces")), 1634 split(/\s*\n\s*/, parseTag(\$LibGroupTag, "symbols"))) 1635 { 1636 $LibGroups{$LibGroupName}{$Interface} = 1; 1637 $Interface_LibGroup{$Interface}=$LibGroupName; 1638 } 1639 } 1640 if(keys(%Interface_LibGroup)) 1641 { 1642 if(keys(%InterfacesList)) { 1643 %InterfacesList=(); 1644 } 1645 foreach my $LibGroup (keys(%LibGroups)) 1646 { 1647 foreach my $Interface (keys(%{$LibGroups{$LibGroup}})) { 1648 $InterfacesList{$Interface}=1; 1649 } 1650 } 1651 } 1652 1653 foreach my $Option (split(/\s*\n\s*/, parseTag(\$Content, "gcc_options"))) 1654 { 1655 if($Option=~/\A\-(Wl|l|L)/ 1656 or $Option=~/\.$LIB_EXT[0-9.]*\Z/) 1657 { # to linker 1658 $CompilerOptions_Libs .= " ".$Option; 1659 } 1660 else { 1661 $CompilerOptions_Cflags .= " ".$Option; 1662 } 1663 } 1664 if(my $DDefines = parseTag(\$Content, "test_defines")) 1665 { 1666 $Descriptor{"Defines"} .= "\n".$DDefines; 1667 } 1668 foreach my $Dep (split(/\s*\n\s*/, parseTag(\$Content, "libs_depend"))) 1669 { 1670 if(not -f $Dep) { 1671 exitStatus("Access_Error", "can't access \'$Dep\': no such file"); 1672 } 1673 $Dep = abs_path($Dep) if($Dep!~/\A(\/|\w+:[\/\\])/); 1674 $LibsDepend{$Dep} = 1; 1675 } 1676 foreach my $IntParam (split(/\s*\n\s*/, parseTag(\$Content, "out_params"))) 1677 { 1678 if($IntParam=~/(.+)(:|;)(.+)/) { 1679 $UserDefinedOutParam{$1}{$3} = 1; 1680 } 1681 } 1682} 1683 1684sub getArch() 1685{ 1686 my $Arch = $ENV{"CPU"}; 1687 if(not $Arch) 1688 { 1689 if($OSgroup=~/linux|bsd|macos/) 1690 { 1691 $Arch = `uname -m`; 1692 chomp($Arch); 1693 if(not $Arch) 1694 { 1695 $Arch = `uname -p`; 1696 chomp($Arch); 1697 } 1698 } 1699 } 1700 if(not $Arch) { 1701 $Arch = $Config{"archname"}; 1702 } 1703 $Arch = "x86" if($Arch=~/i[3-7]86/); 1704 if($OSgroup eq "windows") 1705 { 1706 $Arch = "x86" if($Arch=~/win32/i); 1707 $Arch = "x86-64" if($Arch=~/win64/i); 1708 } 1709 $Arch=~s/\-multi\-thread(-|\Z)//g; 1710 return $Arch; 1711} 1712 1713sub get_Summary() 1714{ 1715 my $Summary = "<h2>Summary</h2><hr/>"; 1716 $Summary .= "<table cellpadding='3' class='summary'>"; 1717 my $Verdict = ""; 1718 if($ResultCounter{"Run"}{"Fail"} > 0) 1719 { 1720 $Verdict = "<span style='color:Red;'><b>Test Failed</b></span>"; 1721 $STAT_FIRST_LINE .= "verdict:failed;"; 1722 } 1723 else 1724 { 1725 $Verdict = "<span style='color:Green;'><b>Test Passed</b></span>"; 1726 $STAT_FIRST_LINE .= "verdict:passed;"; 1727 } 1728 $Summary .= "<tr><td class='table_header summary_item'>Total tests</td><td align='right' class='summary_item_value'>".($ResultCounter{"Run"}{"Success"}+$ResultCounter{"Run"}{"Fail"})."</td></tr>"; 1729 $STAT_FIRST_LINE .= "total:".($ResultCounter{"Run"}{"Success"}+$ResultCounter{"Run"}{"Fail"}).";"; 1730 my $Success_Tests_Link = "0"; 1731 $Success_Tests_Link = $ResultCounter{"Run"}{"Success"} if($ResultCounter{"Run"}{"Success"}>0); 1732 $STAT_FIRST_LINE .= "passed:".$ResultCounter{"Run"}{"Success"}.";"; 1733 my $Failed_Tests_Link = "0"; 1734 $Failed_Tests_Link = "<a href='#Failed_Tests' style='color:Blue;'>".$ResultCounter{"Run"}{"Fail"}."</a>" if($ResultCounter{"Run"}{"Fail"}>0); 1735 $STAT_FIRST_LINE .= "failed:".$ResultCounter{"Run"}{"Fail"}.";"; 1736 $Summary .= "<tr><td class='table_header summary_item'>Passed / Failed tests</td><td align='right' class='summary_item_value'>$Success_Tests_Link / $Failed_Tests_Link</td></tr>"; 1737 if($ResultCounter{"Run"}{"Warnings"}>0) 1738 { 1739 my $Warnings_Link = "<a href='#Warnings' style='color:Blue;'>".$ResultCounter{"Run"}{"Warnings"}."</a>"; 1740 $Summary .= "<tr><td class='table_header summary_item'>Warnings</td><td align='right' class='summary_item_value'>$Warnings_Link</td></tr>"; 1741 } 1742 $STAT_FIRST_LINE .= "warnings:".$ResultCounter{"Run"}{"Warnings"}; 1743 $Summary .= "<tr><td class='table_header summary_item'>Verdict</td><td align='right'>$Verdict</td></tr>"; 1744 $Summary .= "</table>\n"; 1745 return $Summary; 1746} 1747 1748sub get_Problem_Summary() 1749{ 1750 my $Problem_Summary = ""; 1751 my %ProblemType_Interface = (); 1752 foreach my $Interface (keys(%RunResult)) 1753 { 1754 next if($RunResult{$Interface}{"Warnings"}); 1755 $ProblemType_Interface{$RunResult{$Interface}{"Type"}}{$Interface} = 1; 1756 } 1757 my $ColSpan = 1; 1758 my $SignalException = ($OSgroup eq "windows")?"Exception":"Signal"; 1759 my $ProblemType = "Received_".$SignalException; 1760 if(keys(%{$ProblemType_Interface{$ProblemType}})) 1761 { 1762 my %SignalName_Interface = (); 1763 foreach my $Interface (keys(%{$ProblemType_Interface{"Received_$SignalException"}})) { 1764 $SignalName_Interface{$RunResult{$Interface}{"Value"}}{$Interface} = 1; 1765 } 1766 if(keys(%SignalName_Interface)==1) 1767 { 1768 my $SignalName = (keys(%SignalName_Interface))[0]; 1769 my $Amount = keys(%{$SignalName_Interface{$SignalName}}); 1770 my $Link = "<a href=\'#".$ProblemType."_".$SignalName."\' style='color:Blue;'>$Amount</a>"; 1771 $STAT_FIRST_LINE .= lc($ProblemType."_".$SignalName.":$Amount;"); 1772 $Problem_Summary .= "<tr><td class='table_header summary_item'>Received ".lc($SignalException)." $SignalName</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1773 } 1774 elsif(keys(%SignalName_Interface)>1) 1775 { 1776 $Problem_Summary .= "<tr><td class='table_header summary_item' rowspan='".keys(%SignalName_Interface)."'>Received ".lc($SignalException)."</td>"; 1777 my $num = 1; 1778 foreach my $SignalName (sort keys(%SignalName_Interface)) 1779 { 1780 my $Amount = keys(%{$SignalName_Interface{$SignalName}}); 1781 my $Link = "<a href=\'#".$ProblemType."_".$SignalName."\' style='color:Blue;'>$Amount</a>"; 1782 $STAT_FIRST_LINE .= lc($ProblemType."_".$SignalName.":$Amount;"); 1783 $Problem_Summary .= (($num!=1)?"<tr>":"")."<td class='table_header summary_item'>$SignalName</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1784 $num+=1; 1785 } 1786 $ColSpan = 2; 1787 } 1788 } 1789 if(keys(%{$ProblemType_Interface{"Exited_With_Value"}})) 1790 { 1791 my %ExitValue_Interface = (); 1792 foreach my $Interface (keys(%{$ProblemType_Interface{"Exited_With_Value"}})) 1793 { 1794 $ExitValue_Interface{$RunResult{$Interface}{"Value"}}{$Interface} = 1; 1795 } 1796 if(keys(%ExitValue_Interface)==1) 1797 { 1798 my $ExitValue = (keys(%ExitValue_Interface))[0]; 1799 my $Amount = keys(%{$ExitValue_Interface{$ExitValue}}); 1800 my $Link = "<a href=\'#Exited_With_Value_$ExitValue\' style='color:Blue;'>$Amount</a>"; 1801 $STAT_FIRST_LINE .= lc("Exited_With_Value_$ExitValue:$Amount;"); 1802 $Problem_Summary .= "<tr><td class='table_header summary_item' colspan=\'$ColSpan\'>Exited with value \"$ExitValue\"</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1803 } 1804 elsif(keys(%ExitValue_Interface)>1) 1805 { 1806 $Problem_Summary .= "<tr><td class='table_header summary_item' rowspan='".keys(%ExitValue_Interface)."'>Exited with value</td>"; 1807 foreach my $ExitValue (sort keys(%ExitValue_Interface)) 1808 { 1809 my $Amount = keys(%{$ExitValue_Interface{$ExitValue}}); 1810 my $Link = "<a href=\'#Exited_With_Value_$ExitValue\' style='color:Blue;'>$Amount</a>"; 1811 $STAT_FIRST_LINE .= lc("Exited_With_Value_$ExitValue:$Amount;"); 1812 $Problem_Summary .= "<td class='table_header summary_item'>\"$ExitValue\"</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1813 } 1814 $Problem_Summary .= "</tr>"; 1815 $ColSpan = 2; 1816 } 1817 } 1818 if(keys(%{$ProblemType_Interface{"Hanged_Execution"}})) 1819 { 1820 my $Amount = keys(%{$ProblemType_Interface{"Hanged_Execution"}}); 1821 my $Link = "<a href=\'#Hanged_Execution\' style='color:Blue;'>$Amount</a>"; 1822 $STAT_FIRST_LINE .= "hanged_execution:$Amount;"; 1823 $Problem_Summary .= "<tr><td class='table_header summary_item' colspan=\'$ColSpan\'>Hanged execution</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1824 } 1825 if(keys(%{$ProblemType_Interface{"Requirement_Failed"}})) 1826 { 1827 my $Amount = keys(%{$ProblemType_Interface{"Requirement_Failed"}}); 1828 my $Link = "<a href=\'#Requirement_Failed\' style='color:Blue;'>$Amount</a>"; 1829 $STAT_FIRST_LINE .= "requirement_failed:$Amount;"; 1830 $Problem_Summary .= "<tr><td class='table_header summary_item' colspan=\'$ColSpan\'>Requirement failed</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1831 } 1832 if(keys(%{$ProblemType_Interface{"Other_Problems"}})) 1833 { 1834 my $Amount = keys(%{$ProblemType_Interface{"Other_Problems"}}); 1835 my $Link = "<a href=\'#Other_Problems\' style='color:Blue;'>$Amount</a>"; 1836 $STAT_FIRST_LINE .= "other_problems:$Amount;"; 1837 $Problem_Summary .= "<tr><td class='table_header summary_item' colspan=\'$ColSpan\'>Other problems</td><td align='right' class='summary_item_value'>$Link</td></tr>"; 1838 } 1839 if($Problem_Summary) 1840 { 1841 $Problem_Summary = "<h2>Problem Summary</h2><hr/>"."<table cellpadding='3' class='summary'>".$Problem_Summary."</table>\n"; 1842 return $Problem_Summary; 1843 } 1844 else 1845 { 1846 return ""; 1847 } 1848} 1849 1850sub get_Report_Header() 1851{ 1852 my $Report_Header = "<h1>Test results for the <span style='color:Blue;'>$TargetLibraryFullName</span>-<span style='color:Blue;'>".$Descriptor{"Version"}."</span> library on <span style='color:Blue;'>".getArch()."</span></h1>\n"; 1853 return $Report_Header; 1854} 1855 1856sub get_TestSuite_Header() 1857{ 1858 my $Report_Header = "<h1>Test suite for the <span style='color:Blue;'>$TargetLibraryFullName</span>-<span style='color:Blue;'>".$Descriptor{"Version"}."</span> library on <span style='color:Blue;'>".getArch()."</span></h1>\n"; 1859 return $Report_Header; 1860} 1861 1862sub get_problem_title($$) 1863{ 1864 my ($ProblemType, $Value) = @_; 1865 if($ProblemType eq "Received_Signal") { 1866 return "Received signal $Value"; 1867 } 1868 elsif($ProblemType eq "Received_Exception") { 1869 return "Received exception $Value"; 1870 } 1871 elsif($ProblemType eq "Exited_With_Value") { 1872 return "Exited with value \"$Value\""; 1873 } 1874 elsif($ProblemType eq "Requirement_Failed") { 1875 return "Requirement failed"; 1876 } 1877 elsif($ProblemType eq "Hanged_Execution") { 1878 return "Hanged execution"; 1879 } 1880 elsif($ProblemType eq "Unexpected_Output") { 1881 return "Unexpected Output"; 1882 } 1883 elsif($ProblemType eq "Other_Problems") { 1884 return "Other problems"; 1885 } 1886 else { 1887 return ""; 1888 } 1889} 1890 1891sub get_count_title($$) 1892{ 1893 my ($Word, $Number) = @_; 1894 if($Number>=2 or $Number==0) { 1895 return "$Number $Word"."s"; 1896 } 1897 elsif($Number==1) { 1898 return "1 $Word"; 1899 } 1900} 1901 1902sub get_TestView($$) 1903{ 1904 my ($Test, $Interface) = @_; 1905 $Test = highlight_code($Test, $Interface); 1906 $Test = htmlSpecChars($Test); 1907 $Test=~s/\@LT\@/</g; 1908 $Test=~s/\@GT\@/>/g; 1909 $Test=~s/\@SP\@/ /g; 1910 $Test=~s/\@NL\@/\n/g; 1911 return "<table class='test_view'><tr><td>".$Test."</td></tr></table>\n"; 1912} 1913 1914sub rm_prefix($) 1915{ 1916 my $Str = $_[0]; 1917 $Str=~s/\A[_~]+//g; 1918 return $Str; 1919} 1920 1921sub select_Symbol_NS($) 1922{ 1923 my $Symbol = $_[0]; 1924 return "" if(not $Symbol); 1925 my $NS = $CompleteSignature{$Symbol}{"NameSpace"}; 1926 if(not $NS) 1927 { 1928 if(my $Class = $CompleteSignature{$Symbol}{"Class"}) { 1929 $NS = $TypeInfo{$Class}{"NameSpace"}; 1930 } 1931 } 1932 if($NS) 1933 { 1934 if(defined $NestedNameSpaces{$NS}) { 1935 return $NS; 1936 } 1937 else 1938 { 1939 while($NS=~s/::[^:]+\Z//) 1940 { 1941 if(defined $NestedNameSpaces{$NS}) { 1942 return $NS; 1943 } 1944 } 1945 } 1946 } 1947 1948 return ""; 1949} 1950 1951sub get_TestSuite_List() 1952{ 1953 my ($TEST_LIST, %LibGroup_Header_Interface); 1954 my $Tests_Num = 0; 1955 return "" if(not keys(%Interface_TestDir)); 1956 foreach my $Interface (keys(%Interface_TestDir)) 1957 { 1958 my $Header = get_filename($CompleteSignature{$Interface}{"Header"}); 1959 my $SharedObject = get_filename($Symbol_Library{$Interface}); 1960 $SharedObject = get_filename($DepSymbol_Library{$Interface}) if(not $SharedObject); 1961 $LibGroup_Header_Interface{$Interface_LibGroup{$Interface}}{$SharedObject}{$Header}{$Interface} = 1; 1962 $Tests_Num += 1; 1963 } 1964 foreach my $LibGroup (sort {lc($a) cmp lc($b)} keys(%LibGroup_Header_Interface)) 1965 { 1966 foreach my $SoName (sort {($a eq "") cmp ($b eq "")} sort {lc($a) cmp lc($b)} keys(%{$LibGroup_Header_Interface{$LibGroup}})) 1967 { 1968 foreach my $HeaderName (sort {lc($a) cmp lc($b)} keys(%{$LibGroup_Header_Interface{$LibGroup}{$SoName}})) 1969 { 1970 my %NameSpace_Interface = (); 1971 foreach my $Interface (keys(%{$LibGroup_Header_Interface{$LibGroup}{$SoName}{$HeaderName}})) { 1972 $NameSpace_Interface{select_Symbol_NS($Interface)}{$Interface} = 1; 1973 } 1974 foreach my $NameSpace (sort keys(%NameSpace_Interface)) 1975 { 1976 $TEST_LIST .= getTitle($HeaderName, $SoName, $LibGroup, $NameSpace); 1977 my @SortedInterfaces = sort {lc(rm_prefix($CompleteSignature{$a}{"ShortName"})) cmp lc(rm_prefix($CompleteSignature{$b}{"ShortName"}))} keys(%{$NameSpace_Interface{$NameSpace}}); 1978 @SortedInterfaces = sort {$CompleteSignature{$a}{"Destructor"} <=> $CompleteSignature{$b}{"Destructor"}} @SortedInterfaces; 1979 @SortedInterfaces = sort {lc(get_TypeName($CompleteSignature{$a}{"Class"})) cmp lc(get_TypeName($CompleteSignature{$b}{"Class"}))} @SortedInterfaces; 1980 foreach my $Interface (@SortedInterfaces) 1981 { 1982 my $RelPath = $Interface_TestDir{$Interface}; 1983 $RelPath=~s/\A\Q$TEST_SUITE_PATH\E[\/\\]*//g; 1984 my $Signature = get_Signature($Interface); 1985 if($NameSpace) { 1986 $Signature=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 1987 } 1988 $RelPath=~s/:/\%3A/g; 1989 $TEST_LIST .= "<a class='link' href=\'$RelPath/view.html\'><span class='int'>"; 1990 $TEST_LIST .= highLight_Signature_Italic_Color($Signature); 1991 $TEST_LIST .= "</span></a><br/>\n"; 1992 } 1993 $TEST_LIST .= "<br/>\n"; 1994 } 1995 } 1996 } 1997 } 1998 $STAT_FIRST_LINE .= "total:$Tests_Num"; 1999 return "<h2>Tests ($Tests_Num)</h2><hr/>\n".$TEST_LIST."<a style='font-size:11px;' href='#Top'>to the top</a><br/>\n"; 2000} 2001 2002sub getTitle($$$$) 2003{ 2004 my ($Header, $Library, $LibGroup, $NameSpace) = @_; 2005 2006 if($Library and $Library!~/\.\w+\Z/) { 2007 $Library .= " (.$LIB_EXT)"; 2008 } 2009 2010 my $Title = ""; 2011 if($Header and $Library) 2012 { 2013 $Title .= "<span class='header'>$Header</span>"; 2014 $Title .= ", <span class='lib_name'>$Library</span><br/>\n"; 2015 } 2016 elsif($Library) { 2017 $Title .= "<span class='lib_name'>$Library</span><br/>\n"; 2018 } 2019 elsif($Header) { 2020 $Title .= "<span class='header'>$Header</span><br/>\n"; 2021 } 2022 if($LibGroup) { 2023 $Title .= " <span class='libgroup'>\"$LibGroup\"</span>\n"; 2024 } 2025 if($NameSpace) { 2026 $Title .= "<span class='ns'>namespace <b>$NameSpace</b></span><br/>\n"; 2027 } 2028 return $Title; 2029} 2030 2031sub get_FailedTests($) 2032{ 2033 my $Kind = $_[0];# Failures or Warnings 2034 my ($FAILED_TESTS, %Type_Value_LibGroup_Header_Interface); 2035 foreach my $Interface (keys(%RunResult)) 2036 { 2037 if($Kind eq "Failures") { 2038 next if($RunResult{$Interface}{"Warnings"}); 2039 } 2040 elsif($Kind eq "Warnings") { 2041 next if(not $RunResult{$Interface}{"Warnings"}); 2042 } 2043 my $Header = get_filename($RunResult{$Interface}{"Header"}); 2044 my $SharedObject = $RunResult{$Interface}{"SharedObject"}; 2045 my $ProblemType = $RunResult{$Interface}{"Type"}; 2046 my $ProblemValue = $RunResult{$Interface}{"Value"}; 2047 $Type_Value_LibGroup_Header_Interface{$ProblemType}{$ProblemValue}{$Interface_LibGroup{$Interface}}{$SharedObject}{$Header}{$Interface} = 1; 2048 } 2049 foreach my $ProblemType ("Received_Signal", "Received_Exception", "Exited_With_Value", "Hanged_Execution", "Requirement_Failed", "Unexpected_Output", "Other_Problems") 2050 { 2051 next if(not keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}})); 2052 foreach my $ProblemValue (sort keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}})) 2053 { 2054 my $PROBLEM_REPORT = "<br/>\n"; 2055 my $Problems_Count = 0; 2056 foreach my $LibGroup (sort {lc($a) cmp lc($b)} keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}{$ProblemValue}})) 2057 { 2058 foreach my $SoName (sort {($a eq "") cmp ($b eq "")} sort {lc($a) cmp lc($b)} keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}{$ProblemValue}{$LibGroup}})) 2059 { 2060 foreach my $HeaderName (sort {lc($a) cmp lc($b)} keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}{$ProblemValue}{$LibGroup}{$SoName}})) 2061 { 2062 next if(not $HeaderName or not $SoName); 2063 my $HEADER_LIB_REPORT = ""; 2064 2065 my %NameSpace_Interface = (); 2066 foreach my $Interface (keys(%{$Type_Value_LibGroup_Header_Interface{$ProblemType}{$ProblemValue}{$LibGroup}{$SoName}{$HeaderName}})) { 2067 $NameSpace_Interface{$RunResult{$Interface}{"NameSpace"}}{$Interface} = 1; 2068 } 2069 foreach my $NameSpace (sort keys(%NameSpace_Interface)) 2070 { 2071 $HEADER_LIB_REPORT .= getTitle($HeaderName, $SoName, $LibGroup, $NameSpace); 2072 my @SortedInterfaces = sort {$RunResult{$a}{"Signature"} cmp $RunResult{$b}{"Signature"}} keys(%{$NameSpace_Interface{$NameSpace}}); 2073 foreach my $Interface (@SortedInterfaces) 2074 { 2075 my $Signature = $RunResult{$Interface}{"Signature"}; 2076 if($NameSpace) { 2077 $Signature=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 2078 } 2079 my $Info = $RunResult{$Interface}{"Info"}; 2080 my $Test = $RunResult{$Interface}{"Test"}; 2081 $HEADER_LIB_REPORT .= $ContentSpanStart; 2082 if($Signature) { 2083 $HEADER_LIB_REPORT .= highLight_Signature_Italic_Color($Signature); 2084 } 2085 else { 2086 $HEADER_LIB_REPORT .= $Interface; 2087 } 2088 $HEADER_LIB_REPORT .= $ContentSpanEnd."<br/>\n"; 2089 $HEADER_LIB_REPORT .= $ContentDivStart; 2090 my $RESULT_INFO = "<table class='test_result' cellpadding='2'><tr><td>".htmlSpecChars($Info)."</td></tr></table>"; 2091 $HEADER_LIB_REPORT .= $RESULT_INFO.$Test."<br/>".$ContentDivEnd; 2092 $HEADER_LIB_REPORT = insertIDs($HEADER_LIB_REPORT); 2093 $Problems_Count += 1; 2094 } 2095 $HEADER_LIB_REPORT .= "<br/>\n"; 2096 } 2097 $PROBLEM_REPORT .= $HEADER_LIB_REPORT; 2098 } 2099 } 2100 } 2101 if($PROBLEM_REPORT) 2102 { 2103 my $Title = "<a name=\'".$ProblemType.(($ProblemValue)?"_".$ProblemValue:"")."\'></a>"; 2104 $Title .= $ContentSpanStart_Title; 2105 $Title .= get_problem_title($ProblemType, $ProblemValue)." <span class='ext_title'>(".get_count_title(($Kind eq "Failures")?"problem":"warning", $Problems_Count).")</span>"; 2106 $Title .= $ContentSpanEnd."<br/>\n"; 2107 $Title .= $ContentDivStart."\n"; 2108 2109 $PROBLEM_REPORT = insertIDs($Title).$PROBLEM_REPORT."<a style='font-size:11px;' href='#Top'>to the top</a><br/>\n".$ContentDivEnd; 2110 $FAILED_TESTS .= $PROBLEM_REPORT; 2111 } 2112 } 2113 } 2114 if($FAILED_TESTS) 2115 { 2116 if($Kind eq "Failures") { 2117 $FAILED_TESTS = "<a name='Failed_Tests'></a><h2>Failed Tests (".$ResultCounter{"Run"}{"Fail"}.")</h2><hr/>\n".$FAILED_TESTS; 2118 } 2119 elsif($Kind eq "Warnings") { 2120 $FAILED_TESTS = "<a name='Warnings'></a><h2>Warnings (".$ResultCounter{"Run"}{"Warnings"}.")</h2><hr/>\n".$FAILED_TESTS; 2121 } 2122 } 2123 return $FAILED_TESTS; 2124} 2125 2126sub composeHTML_Head($$$$$) 2127{ 2128 my ($Title, $Keywords, $Description, $Styles, $Scripts) = @_; 2129 return "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> 2130 <html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\"> 2131 <head> 2132 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\" /> 2133 <meta name=\"keywords\" content=\"$Keywords\" /> 2134 <meta name=\"description\" content=\"$Description\" /> 2135 <title> 2136 $Title 2137 </title> 2138 <style type=\"text/css\"> 2139 $Styles 2140 </style> 2141 <script type=\"text/javascript\" language=\"JavaScript\"> 2142 <!-- 2143 $Scripts 2144 --> 2145 </script> 2146 </head>"; 2147} 2148 2149sub create_Index() 2150{ 2151 my $Title = $TargetLibraryFullName."-".$Descriptor{"Version"}.": Test suite"; 2152 my $Keywords = "$TargetLibraryFullName, tests, API"; 2153 my $Description = "Test suite for the $TargetLibraryFullName-".$Descriptor{"Version"}." library on ".getArch(); 2154 2155 my $Header = get_TestSuite_Header(); 2156 my $CssStyles = readModule("Styles", "List.css"); 2157 my $Report = get_TestSuite_List(); # initialized $STAT_FIRST_LINE variable 2158 2159 $Report = "<!-- $STAT_FIRST_LINE -->\n".composeHTML_Head($Title, $Keywords, $Description, $CssStyles, "")."\n<body>\n<div><a name='Top'></a>\n$Header<br/>\n$Report</div>\n"."<br/><br/>$TOOL_SIGNATURE\n<div style='height:99px;'></div>\n</body></html>"; 2160 2161 writeFile("$TEST_SUITE_PATH/view_tests.html", $Report); 2162 2163 if($Browse or $OpenReport) { 2164 openReport("$TEST_SUITE_PATH/view_tests.html"); 2165 } 2166} 2167 2168sub createReport() 2169{ 2170 my $Title = $TargetLibraryFullName."-".$Descriptor{"Version"}.": test results"; 2171 my $Keywords = "$TargetLibraryFullName, test, API"; 2172 my $Description = "Test results for the $TargetLibraryFullName-".$Descriptor{"Version"}." library on ".getArch(); 2173 2174 my $CssStyles = readModule("Styles", "Report.css"); 2175 my $JScripts = readModule("Scripts", "Sections.js"); 2176 2177 my $Summary = get_Summary(); # initialized $STAT_FIRST_LINE variable 2178 my $Report = get_Report_Header()."<br/>\n$Summary<br/>\n".get_Problem_Summary()."<br/>\n".get_FailedTests("Failures")."<br/>\n".get_FailedTests("Warnings"); 2179 $Report = "<!-- $STAT_FIRST_LINE -->\n".composeHTML_Head($Title, $Keywords, $Description, $CssStyles, $JScripts)."\n<body>\n<div><a name='Top'></a>\n".$Report."</div>\n"."<br/><br/>$TOOL_SIGNATURE\n<div style='height:999px;'></div>\n</body></html>"; 2180 2181 writeFile("$REPORT_PATH/test_results.html", $Report); 2182 2183 if($Browse or $OpenReport) { 2184 openReport("$REPORT_PATH/test_results.html"); 2185 } 2186} 2187 2188sub check_Cmd($) 2189{ 2190 my $Cmd = $_[0]; 2191 foreach my $Path (sort {length($a)<=>length($b)} split(/:/, $ENV{"PATH"})) 2192 { 2193 if(-x $Path."/".$Cmd) { 2194 return 1; 2195 } 2196 } 2197 return 0; 2198} 2199 2200sub openReport($) 2201{ 2202 my $Path = $_[0]; 2203 my $Cmd = ""; 2204 if($Browse) 2205 { # user-defined browser 2206 $Cmd = $Browse." \"$Path\""; 2207 } 2208 if(not $Cmd) 2209 { # default browser 2210 if($OSgroup eq "macos") { 2211 $Cmd = "open \"$Path\""; 2212 } 2213 elsif($OSgroup eq "windows") { 2214 $Cmd = "start ".path_format($Path, $OSgroup); 2215 } 2216 else 2217 { # linux, freebsd, solaris 2218 my @Browsers = ( 2219 "x-www-browser", 2220 "sensible-browser", 2221 "firefox", 2222 "opera", 2223 "xdg-open", 2224 "lynx", 2225 "links" 2226 ); 2227 foreach my $Br (@Browsers) 2228 { 2229 if(check_Cmd($Br)) 2230 { 2231 $Cmd = $Br." \"$Path\""; 2232 last; 2233 } 2234 } 2235 } 2236 } 2237 if($Cmd) 2238 { 2239 if($Debug) { 2240 printMsg("INFO", "running $Cmd"); 2241 } 2242 if($OSgroup ne "windows" 2243 and $OSgroup ne "macos") 2244 { 2245 if($Cmd!~/lynx|links/) { 2246 $Cmd .= " >\"/dev/null\" 2>&1 &"; 2247 } 2248 } 2249 system($Cmd); 2250 } 2251 else { 2252 printMsg("ERROR", "cannot open report in browser"); 2253 } 2254} 2255 2256sub cmd_find($;$$$$) 2257{ # native "find" is much faster than File::Find (~6x) 2258 # also the File::Find doesn't support --maxdepth N option 2259 # so using the cross-platform wrapper for the native one 2260 my ($Path, $Type, $Name, $MaxDepth, $UseRegex) = @_; 2261 return () if(not $Path or not -e $Path); 2262 if($OSgroup eq "windows") 2263 { 2264 $Path = get_abs_path($Path); 2265 $Path = path_format($Path, $OSgroup); 2266 my $Cmd = "dir \"$Path\" /B /O"; 2267 if($MaxDepth!=1) { 2268 $Cmd .= " /S"; 2269 } 2270 if($Type eq "d") { 2271 $Cmd .= " /AD"; 2272 } 2273 elsif($Type eq "f") { 2274 $Cmd .= " /A-D"; 2275 } 2276 my @Files = split(/\n/, `$Cmd 2>\"$TMP_DIR/null\"`); 2277 if($Name) 2278 { 2279 if(not $UseRegex) 2280 { # FIXME: how to search file names in MS shell? 2281 # wildcard to regexp 2282 $Name=~s/\*/.*/g; 2283 $Name='\A'.$Name.'\Z'; 2284 } 2285 @Files = grep { /$Name/i } @Files; 2286 } 2287 my @AbsPaths = (); 2288 foreach my $File (@Files) 2289 { 2290 if(not is_abs($File)) { 2291 $File = join_P($Path, $File); 2292 } 2293 if($Type eq "f" and not -f $File) 2294 { # skip dirs 2295 next; 2296 } 2297 push(@AbsPaths, path_format($File, $OSgroup)); 2298 } 2299 if($Type eq "d") { 2300 push(@AbsPaths, $Path); 2301 } 2302 return @AbsPaths; 2303 } 2304 else 2305 { 2306 $Path = get_abs_path($Path); 2307 if(-d $Path and -l $Path 2308 and $Path!~/\/\Z/) 2309 { # for directories that are symlinks 2310 $Path.="/"; 2311 } 2312 my $Cmd = "find \"$Path\""; 2313 if($MaxDepth) { 2314 $Cmd .= " -maxdepth $MaxDepth"; 2315 } 2316 if($Type) { 2317 $Cmd .= " -type $Type"; 2318 } 2319 if($Name and not $UseRegex) 2320 { # wildcards 2321 $Cmd .= " -name \"$Name\""; 2322 } 2323 my $Res = `$Cmd 2>\"$TMP_DIR/null\"`; 2324 if($? and $!) { 2325 printMsg("ERROR", "problem with \'find\' utility ($?): $!"); 2326 } 2327 my @Files = split(/\n/, $Res); 2328 if($Name and $UseRegex) 2329 { # regex 2330 @Files = grep { /$Name/ } @Files; 2331 } 2332 return @Files; 2333 } 2334} 2335 2336sub get_filename($) 2337{ # much faster than basename() from File::Basename module 2338 return $Cache{"get_filename"}{$_[0]} if($Cache{"get_filename"}{$_[0]}); 2339 if($_[0]=~/([^\/\\]+)\Z/) { 2340 return ($Cache{"get_filename"}{$_[0]} = $1); 2341 } 2342 return ""; 2343} 2344 2345sub get_dirname($) 2346{ # much faster than dirname() from File::Basename module 2347 if($_[0]=~/\A(.*)[\/\\]+([^\/\\]*)\Z/) { 2348 return $1; 2349 } 2350 return ""; 2351} 2352 2353sub get_depth($$) 2354{ 2355 my ($Str, $Sym) = @_; 2356 return $Cache{"get_depth"}{$Str}{$Sym} if(defined $Cache{"get_depth"}{$Str}{$Sym}); 2357 $Cache{"get_depth"}{$Str}{$Sym} = scalar ( ( ) = $Str=~/($Sym)/g ); 2358 return $Cache{"get_depth"}{$Str}{$Sym}; 2359} 2360 2361sub getPrefix($) 2362{ 2363 my $Str = $_[0]; 2364 if($Str=~/\A[_]*(([a-z]|[A-Z])[a-z]+)[A-Z]/) { 2365 return $1; 2366 } 2367 elsif($Str=~/\A[_]*([A-Z]+)[A-Z][a-z]+([A-Z][a-z]+|\Z)/) { 2368 return $1; 2369 } 2370 elsif($Str=~/\A([a-z0-9]+_)[a-z]+/i) { 2371 return $1; 2372 } 2373 elsif($Str=~/\A(([a-z])\2{1,})/i) 2374 { # ffopen 2375 return $1; 2376 } 2377 else { 2378 return ""; 2379 } 2380} 2381 2382sub get_Type($) 2383{ 2384 my $TypeId = $_[0]; 2385 return "" if(not $TypeId or not $TypeInfo{$TypeId}); 2386 return %{$TypeInfo{$TypeId}}; 2387} 2388 2389sub uncover_typedefs($) 2390{ 2391 my $TypeName = $_[0]; 2392 return "" if(not $TypeName); 2393 return $Cache{"uncover_typedefs"}{$TypeName} if(defined $Cache{"uncover_typedefs"}{$TypeName}); 2394 my ($TypeName_New, $TypeName_Pre) = (formatName($TypeName, "T"), ""); 2395 while($TypeName_New ne $TypeName_Pre) 2396 { 2397 $TypeName_Pre = $TypeName_New; 2398 my $TypeName_Copy = $TypeName_New; 2399 my %Words = (); 2400 while($TypeName_Copy=~s/(\W|\A)([a-z_][\w:]*)(\W|\Z)//io) 2401 { 2402 my $Word = $2; 2403 next if(not $Word or $Word=~/\A(true|false|const|int|long|void|short|float|unsigned|char|double|class|struct|union|enum)\Z/); 2404 $Words{$Word} = 1; 2405 } 2406 foreach my $Word (sort keys(%Words)) 2407 { 2408 my $BaseType_Name = $Typedef_BaseName{$Word}; 2409 next if($TypeName_New=~/(\W|\A)(class|struct|union|enum)\s+\Q$Word\E(\W|\Z)/); 2410 next if(not $BaseType_Name); 2411 if($BaseType_Name=~/\([\*]+\)/) 2412 { 2413 if($TypeName_New=~/\Q$Word\E(.*)\Z/) 2414 { 2415 my $Type_Suffix = $1; 2416 $TypeName_New = $BaseType_Name; 2417 if($TypeName_New=~s/\(([\*]+)\)/($1 $Type_Suffix)/) { 2418 $TypeName_New = formatName($TypeName_New, "T"); 2419 } 2420 } 2421 } 2422 else 2423 { 2424 if($TypeName_New=~s/(\W|\A)\Q$Word\E(\W|\Z)/$1$BaseType_Name$2/g) { 2425 $TypeName_New = formatName($TypeName_New, "T"); 2426 } 2427 } 2428 } 2429 } 2430 $Cache{"uncover_typedefs"}{$TypeName} = $TypeName_New; 2431 return $TypeName_New; 2432} 2433 2434sub get_type_short_name($) 2435{ 2436 my $TypeName = $_[0]; 2437 $TypeName=~s/[ ]*<.*>[ ]*//g; 2438 $TypeName=~s/\Astruct //g; 2439 $TypeName=~s/\Aunion //g; 2440 $TypeName=~s/\Aclass //g; 2441 return $TypeName; 2442} 2443 2444sub is_transit_function($) 2445{ 2446 my $ShortName = $_[0]; 2447 return 1 if($ShortName=~/(_|\A)dup(_|\Z)|(dup\Z)|_dup/i); 2448 return 1 if($ShortName=~/replace|merge|search|copy|append|duplicat|find|query|open|handle|first|next|entry/i); 2449 return grep(/\A(get|prev|last|from|of|dup)\Z/i, @{get_tokens($ShortName)}); 2450} 2451 2452sub get_TypeLib($) 2453{ 2454 my $TypeId = $_[0]; 2455 if(defined $Cache{"get_TypeLib"}{$TypeId} 2456 and not defined $AuxType{$TypeId}) { 2457 return $Cache{"get_TypeLib"}{$TypeId}; 2458 } 2459 my $Header = $TypeInfo{$TypeId}{"Header"}; 2460 foreach my $Interface (sort keys(%{$Header_Interface{$Header}})) 2461 { 2462 if(my $SoLib = get_filename($Symbol_Library{$Interface})) 2463 { 2464 $Cache{"get_TypeLib"}{$TypeId} = $SoLib; 2465 return $SoLib; 2466 } 2467 elsif(my $SoLib = get_filename($DepSymbol_Library{$Interface})) 2468 { 2469 $Cache{"get_TypeLib"}{$TypeId} = $SoLib; 2470 return $SoLib; 2471 } 2472 } 2473 $Cache{"get_TypeLib"}{$TypeId} = "unknown"; 2474 return $Cache{"get_TypeLib"}{$TypeId}; 2475} 2476 2477sub detect_typedef($) 2478{ 2479 my $Type_Id = $_[0]; 2480 return "" if(not $Type_Id); 2481 my $Typedef_Id = get_base_typedef($Type_Id); 2482 if(not $Typedef_Id) { 2483 $Typedef_Id = get_type_typedef(get_FoundationTypeId($Type_Id)); 2484 } 2485 return $Typedef_Id; 2486} 2487 2488sub get_symbol_suffix($) 2489{ 2490 my $Symbol = $_[0]; 2491 my $Signature = $tr_name{$Symbol}; 2492 my $Suffix = substr($Signature, find_center($Signature, "(")); 2493 return $Suffix; 2494} 2495 2496sub get_Signature($) 2497{ 2498 my $Interface = $_[0]; 2499 if(defined $Cache{"get_Signature"}{$Interface}) { 2500 return $Cache{"get_Signature"}{$Interface}; 2501 } 2502 my $Func_Signature = ""; 2503 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 2504 if($Interface=~/\A(_Z|\?)/) 2505 { 2506 if(my $ClassId = $CompleteSignature{$Interface}{"Class"}) 2507 { 2508 if(get_TypeName($ClassId)=~/<|>|::/ 2509 and my $Typedef_Id = detect_typedef($ClassId)) { 2510 $ClassId = $Typedef_Id; 2511 } 2512 $Func_Signature = get_TypeName($ClassId)."::".((($CompleteSignature{$Interface}{"Destructor"}))?"~":"").$ShortName; 2513 } 2514 elsif(my $NameSpace = $CompleteSignature{$Interface}{"NameSpace"}) { 2515 $Func_Signature = $NameSpace."::".$ShortName; 2516 } 2517 else { 2518 $Func_Signature = $ShortName; 2519 } 2520 } 2521 else { 2522 $Func_Signature = $Interface; 2523 } 2524 my @ParamArray = (); 2525 foreach my $Pos (sort {int($a) <=> int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 2526 { 2527 next if($Pos eq ""); 2528 my $ParamTypeId = $CompleteSignature{$Interface}{"Param"}{$Pos}{"type"}; 2529 next if(not $ParamTypeId); 2530 my $ParamTypeName = get_TypeName($ParamTypeId); 2531 my $ParamFTypeId = get_FoundationTypeId($ParamTypeId); 2532 if($ParamTypeName=~/<|>|::/ and get_TypeType($ParamFTypeId)=~/\A(Class|Struct)\Z/) 2533 { 2534 if(my $Typedef_Id = detect_typedef($ParamTypeId)) { 2535 $ParamTypeName = cover_by_typedef($ParamTypeName, $ParamFTypeId, $Typedef_Id); 2536 } 2537 } 2538 if(my $ParamName = $CompleteSignature{$Interface}{"Param"}{$Pos}{"name"}) { 2539 push(@ParamArray, create_member_decl($ParamTypeName, $ParamName)); 2540 } 2541 else { 2542 push(@ParamArray, $ParamTypeName); 2543 } 2544 } 2545 if(not $CompleteSignature{$Interface}{"Data"}) 2546 { 2547 if($Interface=~/\A(_Z|\?)/) 2548 { 2549 if(my $ChargeLevel = get_ChargeLevel($Interface)) { 2550 $Func_Signature .= " [".$ChargeLevel."]"; 2551 } 2552 } 2553 $Func_Signature .= " (".join(", ", @ParamArray).")"; 2554 if($Interface=~/\A_ZNK/) { 2555 $Func_Signature .= " const"; 2556 } 2557 if($CompleteSignature{$Interface}{"Static"}) { 2558 $Func_Signature .= " [static]"; 2559 } 2560 } 2561 if(defined $ShowRetVal 2562 and my $ReturnTId = $CompleteSignature{$Interface}{"Return"}) 2563 { 2564 my $ReturnTypeName = get_TypeName($ReturnTId); 2565 my $ReturnFTypeId = get_FoundationTypeId($ReturnTId); 2566 if($ReturnTypeName=~/<|>|::/ and get_TypeType($ReturnFTypeId)=~/\A(Class|Struct)\Z/) 2567 { 2568 if(my $Typedef_Id = detect_typedef($ReturnTId)) { 2569 $ReturnTypeName = cover_by_typedef($ReturnTypeName, $ReturnFTypeId, $Typedef_Id); 2570 } 2571 } 2572 $Func_Signature .= " :".$ReturnTypeName; 2573 } 2574 return ($Cache{"get_Signature"}{$Interface} = $Func_Signature); 2575} 2576 2577sub get_ChargeLevel($) 2578{ 2579 my $Symbol = $_[0]; 2580 if($CompleteSignature{$Symbol}{"Constructor"}) 2581 { 2582 if($Symbol=~/C1E/) { 2583 return "in-charge"; 2584 } 2585 elsif($Symbol=~/C2E/) { 2586 return "not-in-charge"; 2587 } 2588 } 2589 elsif($CompleteSignature{$Symbol}{"Destructor"}) 2590 { 2591 if($Symbol=~/D1E/) { 2592 return "in-charge"; 2593 } 2594 elsif($Symbol=~/D2E/) { 2595 return "not-in-charge"; 2596 } 2597 elsif($Symbol=~/D0E/) { 2598 return "in-charge-deleting"; 2599 } 2600 } 2601 return ""; 2602} 2603 2604sub htmlSpecChars($) 2605{ 2606 my $Str = $_[0]; 2607 # $Str=~s/\&([^#]|\Z)/&$1/g; 2608 $Str=~s/\&/&/g; 2609 $Str=~s/</</g; 2610 $Str=~s/>/>/g; 2611 $Str=~s/([^ ]) ([^ ])/$1\@SP1\@$2/g; 2612 $Str=~s/([^ ]) ([^ ])/$1\@SP1\@$2/g; 2613 $Str=~s/ / /g; 2614 $Str=~s/\@SP1\@/ /g; 2615 $Str=~s/\n/<br\/>/g; 2616 return $Str; 2617} 2618 2619sub highLight_Signature_Italic_Color($) 2620{ 2621 my $Signature = $_[0]; 2622 return highLight_Signature_PPos_Italic($Signature, "", 1, 1); 2623} 2624 2625sub highLight_Signature_PPos_Italic($$$$) 2626{ 2627 my ($Signature, $Param_Pos, $ItalicParams, $ColorParams) = @_; 2628 my ($Begin, $End, $Return) = (substr($Signature, 0, find_center($Signature, "(")), "", ""); 2629 if($ShowRetVal and $Signature=~s/([^:])\s*:([^:].+?)\Z/$1/g) { 2630 $Return = $2; 2631 } 2632 if($Signature=~/\)((| const)(| \[static\]))\Z/) { 2633 $End = $1; 2634 } 2635 my @Parts = (); 2636 my @SParts = get_Signature_Parts($Signature, 1); 2637 foreach my $Pos (0 .. $#SParts) 2638 { 2639 my $Part = $SParts[$Pos]; 2640 $Part=~s/\A\s+|\s+\Z//g; 2641 my ($Part_Styled, $ParamName) = (htmlSpecChars($Part), ""); 2642 if($Part=~/\([\*]+(\w+)\)/i) { 2643 $ParamName = $1;#func-ptr 2644 } 2645 elsif($Part=~/(\w+)[\,\)]*\Z/i) { 2646 $ParamName = $1; 2647 } 2648 if(not $ParamName) 2649 { 2650 push(@Parts, $Part_Styled); 2651 next; 2652 } 2653 if($ItalicParams 2654 and not $TName_Tid{$Part}) 2655 { 2656 my $Style = "param"; 2657 if($Param_Pos ne "" 2658 and $Pos==$Param_Pos) { 2659 $Style = "focus_p"; 2660 } 2661 elsif($ColorParams) { 2662 $Style = "color_p"; 2663 } 2664 $Part_Styled =~ s!(\W)$ParamName([\,\)]|\Z)!$1<span class=\'$Style\'>$ParamName</span>$2!ig; 2665 } 2666 $Part_Styled=~s/,(\w)/, $1/g; 2667 push(@Parts, $Part_Styled); 2668 } 2669 if(@Parts) 2670 { 2671 foreach my $Num (0 .. $#Parts) 2672 { 2673 if($Num==$#Parts) 2674 { # add ")" to the last parameter 2675 $Parts[$Num] = "<span class='nowrap'>".$Parts[$Num]." )</span>"; 2676 } 2677 elsif(length($Parts[$Num])<=45) { 2678 $Parts[$Num] = "<span class='nowrap'>".$Parts[$Num]."</span>"; 2679 } 2680 } 2681 $Signature = htmlSpecChars($Begin)."<span class='sym_p'>( ".join(" ", @Parts)."</span>".$End; 2682 } 2683 else { 2684 $Signature = htmlSpecChars($Begin)."<span class='sym_p'>( )</span>".$End; 2685 } 2686 if($Return and $ShowRetVal) { 2687 $Signature .= "<span class='sym_p nowrap'>  <b>:</b>  ".htmlSpecChars($Return)."</span>"; 2688 } 2689 $Signature=~s!\[\]![ ]!g; 2690 $Signature=~s!operator=!operator =!g; 2691 $Signature=~s!(\[in-charge\]|\[not-in-charge\]|\[in-charge-deleting\]|\[static\])!<span class='attr'>$1</span>!g; 2692 return $Signature; 2693} 2694 2695sub get_Signature_Parts($$) 2696{ 2697 my ($Signature, $Comma) = @_; 2698 my @Parts = (); 2699 my ($Bracket_Num, $Bracket2_Num) = (0, 0); 2700 my $Parameters = $Signature; 2701 my $ShortName = substr($Parameters, 0, find_center($Parameters, "(")); 2702 $Parameters=~s/\A\Q$ShortName\E\(//g; 2703 $Parameters=~s/\)(| const)(| \[static\])\Z//g; 2704 my $Part_Num = 0; 2705 foreach my $Pos (0 .. length($Parameters) - 1) 2706 { 2707 my $Symbol = substr($Parameters, $Pos, 1); 2708 $Bracket_Num += 1 if($Symbol eq "("); 2709 $Bracket_Num -= 1 if($Symbol eq ")"); 2710 $Bracket2_Num += 1 if($Symbol eq "<"); 2711 $Bracket2_Num -= 1 if($Symbol eq ">"); 2712 if($Symbol eq "," and $Bracket_Num==0 and $Bracket2_Num==0) 2713 { 2714 $Parts[$Part_Num] .= $Symbol if($Comma); 2715 $Part_Num += 1; 2716 } 2717 else 2718 { 2719 $Parts[$Part_Num] .= $Symbol; 2720 } 2721 } 2722 return @Parts; 2723} 2724 2725sub isAnon($) { 2726 return (($_[0]=~/\.\_\d+/) or ($_[0]=~/anon-/)); 2727} 2728 2729sub formatName($$) 2730{ # type name correction 2731 if(defined $Cache{"formatName"}{$_[1]}{$_[0]}) { 2732 return $Cache{"formatName"}{$_[1]}{$_[0]}; 2733 } 2734 2735 my $N = $_[0]; 2736 2737 if($_[1] ne "S") 2738 { 2739 $N=~s/\A[ ]+//g; 2740 $N=~s/[ ]+\Z//g; 2741 $N=~s/[ ]{2,}/ /g; 2742 } 2743 2744 $N=~s/[ ]*(\W)[ ]*/$1/g; # std::basic_string<char> const 2745 2746 $N=~s/\bvolatile const\b/const volatile/g; 2747 2748 $N=~s/\b(long long|short|long) unsigned\b/unsigned $1/g; 2749 $N=~s/\b(short|long) int\b/$1/g; 2750 2751 $N=~s/([\)\]])(const|volatile)\b/$1 $2/g; 2752 2753 while($N=~s/>>/> >/g) {}; 2754 2755 if($_[1] eq "S") 2756 { 2757 if(index($N, "operator")!=-1) { 2758 $N=~s/\b(operator[ ]*)> >/$1>>/; 2759 } 2760 } 2761 2762 return ($Cache{"formatName"}{$_[1]}{$_[0]} = $N); 2763} 2764 2765sub prepareInterfaces() 2766{ 2767 foreach my $InfoId (keys(%SymbolInfo)) 2768 { 2769 my $MnglName = $SymbolInfo{$InfoId}{"MnglName"}; 2770 %{$CompleteSignature{$MnglName}} = %{$SymbolInfo{$InfoId}}; 2771 delete($SymbolInfo{$InfoId}); 2772 } 2773 %SymbolInfo = (); 2774} 2775 2776sub setRegularities() 2777{ 2778 foreach my $Symbol (keys(%CompleteSignature)) 2779 { 2780 if(my $ClassId = $CompleteSignature{$Symbol}{"Class"}) 2781 { 2782 if(not $CompleteSignature{$Symbol}{"Destructor"} 2783 and ($Symbol!~/C2E/ or not $CompleteSignature{$Symbol}{"Constructor"})) { 2784 $Interface_Overloads{$CompleteSignature{$Symbol}{"NameSpace"}}{get_ShortType($ClassId)}{$CompleteSignature{$Symbol}{"ShortName"}}{$Symbol} = 1; 2785 } 2786 if($CompleteSignature{$Symbol}{"PureVirt"}) { 2787 $Class_PureMethod{$ClassId}{$Symbol} = 1; 2788 } 2789 else { 2790 $Class_Method{$ClassId}{$Symbol} = 1; 2791 } 2792 } 2793 2794 if(not $CompleteSignature{$Symbol}{"Private"}) 2795 { 2796 setOutParams_Simple($Symbol); 2797 setOutParams_Complex($Symbol); 2798 setRelationships($Symbol); 2799 } 2800 2801 if($CompleteSignature{$Symbol}{"Data"}) 2802 { 2803 if($Symbol=~/\A(_Z|\?)/) 2804 { 2805 my $Name = $CompleteSignature{$Symbol}{"ShortName"}; 2806 if(my $Class = $CompleteSignature{$Symbol}{"Class"}) { 2807 $Name = get_TypeName($Class)."::".$Name; 2808 } 2809 $GlobalDataNames{$Name} = 1; 2810 } 2811 else { 2812 $GlobalDataNames{$CompleteSignature{$Symbol}{"ShortName"}} = 1; 2813 } 2814 } 2815 else 2816 { 2817 if($Symbol=~/\A(_Z|\?)/) { 2818 $MethodNames{$CompleteSignature{$Symbol}{"ShortName"}} = 1; 2819 } 2820 else { 2821 $FuncNames{$CompleteSignature{$Symbol}{"ShortName"}} = 1; 2822 } 2823 } 2824 2825 if(my $Prefix = getPrefix($CompleteSignature{$Symbol}{"ShortName"})) { 2826 $Library_Prefixes{$Prefix} += 1; 2827 } 2828 } 2829 foreach my $NameSpace (keys(%Interface_Overloads)) 2830 { 2831 foreach my $ClassName (keys(%{$Interface_Overloads{$NameSpace}})) 2832 { 2833 foreach my $ShortName (keys(%{$Interface_Overloads{$NameSpace}{$ClassName}})) 2834 { 2835 if(keys(%{$Interface_Overloads{$NameSpace}{$ClassName}{$ShortName}})>1) 2836 { 2837 foreach my $Symbol (keys(%{$Interface_Overloads{$NameSpace}{$ClassName}{$ShortName}})) { 2838 $OverloadedInterface{$Symbol} = keys(%{$Interface_Overloads{$NameSpace}{$ClassName}{$ShortName}}); 2839 } 2840 } 2841 delete($Interface_Overloads{$NameSpace}{$ClassName}{$ShortName}); 2842 } 2843 } 2844 } 2845 2846 my %Struct_Mapping = (); 2847 2848 foreach my $TypeId (keys(%TypeInfo)) 2849 { 2850 my %Type = %{$TypeInfo{$TypeId}}; 2851 my $BaseTypeId = get_FoundationTypeId($TypeId); 2852 my $PLevel = get_PointerLevel($TypeId); 2853 $BaseType_PLevel_Type{$BaseTypeId}{$PLevel}{$TypeId} = 1; 2854 2855 if($Type{"Type"} eq "Struct") 2856 { 2857 2858 next if(not keys(%{$Type{"Memb"}})); 2859 my $FirstId = $Type{"Memb"}{0}{"type"}; 2860 if($Type{"Memb"}{0}{"name"}=~/parent/i 2861 and get_TypeType(get_FoundationTypeId($FirstId)) eq "Struct" 2862 and get_TypeName($FirstId)!~/gobject/i) { 2863 $Struct_Parent{$TypeId} = $FirstId; 2864 } 2865 my @Keys = (); 2866 foreach my $MembPos (sort {int($a)<=>int($b)} keys(%{$Type{"Memb"}})) { 2867 push(@Keys, $Type{"Memb"}{$MembPos}{"name"}.":".$Type{"Memb"}{$MembPos}{"type"}); 2868 } 2869 init_struct_mapping($TypeId, \%Struct_Mapping, \@Keys); 2870 } 2871 } 2872 2873 read_struct_mapping(\%Struct_Mapping); 2874} 2875 2876sub init_struct_mapping($$$) 2877{ 2878 my ($TypeId, $Ref, $KeysRef) = @_; 2879 my @Keys = @{$KeysRef}; 2880 if($#Keys>=1) 2881 { 2882 my $FirstKey = $Keys[0]; 2883 splice(@Keys, 0, 1); 2884 if(not defined $Ref->{$FirstKey}) { 2885 %{$Ref->{$FirstKey}} = (); 2886 } 2887 init_struct_mapping($TypeId, $Ref->{$FirstKey}, \@Keys); 2888 } 2889 elsif($#Keys==0) { 2890 $Ref->{$Keys[0]}{"Types"}{$TypeId} = 1; 2891 } 2892} 2893 2894sub read_struct_mapping($) 2895{ 2896 my $Ref = $_[0]; 2897 my %LevelTypes = (); 2898 @LevelTypes{keys(%{$Ref->{"Types"}})} = values(%{$Ref->{"Types"}}); 2899 foreach my $Key (keys(%{$Ref})) 2900 { 2901 next if($Key eq "Types"); 2902 foreach my $SubClassId (read_struct_mapping($Ref->{$Key})) 2903 { 2904 $LevelTypes{$SubClassId} = 1; 2905 foreach my $ParentId (keys(%{$Ref->{"Types"}})) { 2906 $Struct_SubClasses{$ParentId}{$SubClassId} = 1; 2907 } 2908 } 2909 } 2910 return keys(%LevelTypes); 2911} 2912 2913sub get_ShortType($) 2914{ 2915 my $TypeId = $_; 2916 my $TypeName = uncover_typedefs($TypeInfo{$TypeId}{"Name"}); 2917 if(my $NameSpace = $TypeInfo{$TypeId}{"NameSpace"}) { 2918 $TypeName=~s/\A$NameSpace\:\://g; 2919 } 2920 return $TypeName; 2921} 2922 2923sub setRelationships($) 2924{ 2925 my $Interface = $_[0]; 2926 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 2927 2928 if($Interface=~/\A(_Z|\?)/ and not $CompleteSignature{$Interface}{"Class"}) { 2929 $Func_ShortName_MangledName{$CompleteSignature{$Interface}{"ShortName"}}{$Interface}=1; 2930 } 2931 if(not $CompleteSignature{$Interface}{"PureVirt"}) 2932 { 2933 if($CompleteSignature{$Interface}{"Constructor"}) { 2934 $Class_Constructors{$CompleteSignature{$Interface}{"Class"}}{$Interface} = 1; 2935 } 2936 elsif($CompleteSignature{$Interface}{"Destructor"}) { 2937 $Class_Destructors{$CompleteSignature{$Interface}{"Class"}}{$Interface} = 1; 2938 } 2939 else 2940 { 2941 if(get_TypeName($CompleteSignature{$Interface}{"Return"}) ne "void") 2942 { 2943 my $DoNotUseReturn = 0; 2944 if(is_transit_function($ShortName)) 2945 { 2946 my $Return_FId = get_FoundationTypeId($CompleteSignature{$Interface}{"Return"}); 2947 foreach my $Pos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 2948 { 2949 next if($InterfaceSpecType{$Interface}{"SpecParam"}{$Pos}); 2950 my $Param_FId = get_FoundationTypeId($CompleteSignature{$Interface}{"Param"}{$Pos}{"type"}); 2951 if(($CompleteSignature{$Interface}{"Param"}{$Pos}{"type"} eq $CompleteSignature{$Interface}{"Return"}) 2952 or (get_TypeType($Return_FId)!~/\A(Intrinsic|Enum|Array)\Z/ and $Return_FId eq $Param_FId)) 2953 { 2954 $DoNotUseReturn = 1; 2955 last; 2956 } 2957 } 2958 } 2959 if(not $DoNotUseReturn) 2960 { 2961 $ReturnTypeId_Interface{$CompleteSignature{$Interface}{"Return"}}{$Interface}=1; 2962 my $Return_FId = get_FoundationTypeId($CompleteSignature{$Interface}{"Return"}); 2963 my $PLevel = get_PointerLevel($CompleteSignature{$Interface}{"Return"}); 2964 if(get_TypeType($Return_FId) ne "Intrinsic") { 2965 $BaseType_PLevel_Return{$Return_FId}{$PLevel}{$Interface}=1; 2966 } 2967 } 2968 } 2969 } 2970 } 2971 2972 $Header_Interface{$CompleteSignature{$Interface}{"Header"}}{$Interface} = 1; 2973 if(not $CompleteSignature{$Interface}{"Class"} and not $LibraryMallocFunc 2974 and $Symbol_Library{$Interface} and $Interface ne "malloc" 2975 and $ShortName!~/try|slice|trim|\d\Z/i and $ShortName=~/(\A|_|\d)(malloc|alloc)(\Z|_|\d)/i 2976 and keys(%{$CompleteSignature{$Interface}{"Param"}})==1 2977 and isIntegerType(get_TypeName($CompleteSignature{$Interface}{"Param"}{0}{"type"}))) { 2978 $LibraryMallocFunc = $Interface; 2979 } 2980 if(not $CompleteSignature{$Interface}{"Class"} and $Symbol_Library{$Interface} 2981 and $ShortName=~/(\A[a-z]*_)(init|initialize|initializer|install)\Z/i) { 2982 $LibraryInitFunc{$Interface} = 1; 2983 } 2984 elsif(not $CompleteSignature{$Interface}{"Class"} and $Symbol_Library{$Interface} 2985 and $ShortName=~/\A([a-z]*_)(exit|finalize|finish|clean|close|deinit|shutdown|cleanup|uninstall|end)\Z/i) { 2986 $LibraryExitFunc{$Interface} = 1; 2987 } 2988} 2989 2990sub setOutParams_Simple($) 2991{ 2992 my $Interface = $_[0]; 2993 my $ReturnType_Id = $CompleteSignature{$Interface}{"Return"}; 2994 my $ReturnType_Name_Short = get_TypeName($ReturnType_Id); 2995 while($ReturnType_Name_Short=~s/(\*|\&)([^<>()]+|)\Z/$2/g){}; 2996 my ($ParamName_Prev, $ParamTypeId_Prev) = (); 2997 foreach my $ParamPos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 2998 { # detecting out-parameters by name 2999 if($CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}=~/\Ap\d+\Z/ 3000 and (my $NewParamName = $AddIntParams{$Interface}{$ParamPos})) 3001 { # names from the external file 3002 $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"} = $NewParamName; 3003 } 3004 my $ParamName = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}; 3005 my $ParamTypeId = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"type"}; 3006 my $ParamPLevel = get_PointerLevel($ParamTypeId); 3007 my $ParamFTypeId = get_FoundationTypeId($ParamTypeId); 3008 my $ParamFTypeName = get_TypeName($ParamFTypeId); 3009 my $ParamTypeName = get_TypeName($ParamTypeId); 3010 3011 if($UserDefinedOutParam{$Interface}{$ParamPos+1} 3012 or $UserDefinedOutParam{$Interface}{$ParamName}) 3013 { # user defined by <out_params> section in the descriptor 3014 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3015 next; 3016 } 3017 3018 # particular accept 3019 if($ParamPLevel>=2 and isCharType($ParamFTypeName) 3020 and not is_const_type($ParamTypeName) and $ParamName!~/argv/i and $ParamName!~/\A(s|str|string)\Z/i) 3021 { # soup_form_decode_multipart ( SoupMessage* msg, char const* file_control_name, char** filename, char** content_type, SoupBuffer** file ) 3022 # direct_trim ( char** s ) 3023 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3024 next; 3025 } 3026 if($ParamPLevel>=2 and not is_const_type($ParamTypeName) and $ParamName=~/handle/i and $CompleteSignature{$Interface}{"ShortName"}=~/_init\Z/i) 3027 { # gnutls_cipher_init ( gnutls_cipher_hd_t* handle, gnutls_cipher_algorithm_t cipher, gnutls_datum_t const* key, gnutls_datum_t const* iv ) 3028 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3029 next; 3030 } 3031 if($ParamPLevel==1 and isNumericType($ParamFTypeName) 3032 and not is_const_type($ParamTypeName) and ($ParamName=~/((\A|_)(x|y|(lat|long|alt)itude)(\Z|_))|errnum|errcode|used|horizontal|vertical|width|height|error|length|count|time|status|state|min|max|weight|\An[_]*(row|col|axe|found|memb|key|space)|\An_/i or $ParamTypeName=~/bool/i 3033 or $ParamName=~/(\A|_)n(_|)(elem|item)/i or is_out_word($ParamName) or $ParamName=~/\Ais/i)) 3034 { # gail_misc_get_origins ( GtkWidget* widget, gint* x_window, gint* y_window, gint* x_toplevel, gint* y_toplevel ) 3035 # glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) 3036 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3037 next; 3038 } 3039 if(($ParamName=~/err/i and $ParamPLevel>=2 and $ParamTypeName=~/err/i) 3040 or ($ParamName=~/\A(error|err)(_|)(p|ptr)\Z/i and $ParamPLevel>=1)) 3041 { # g_app_info_add_supports_type ( GAppInfo* appinfo, char const* content_type, GError** error ) 3042 # rsvg_handle_new_from_data ( guint8 const* data, gsize data_len, GError** error ) 3043 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3044 next; 3045 } 3046 3047 # strong reject 3048 next if(get_TypeType(get_FoundationTypeId($ReturnType_Id))!~/\A(Intrinsic|Enum)\Z/ 3049 or $CompleteSignature{$Interface}{"ShortName"}=~/\Q$ReturnType_Name_Short\E/ 3050 or $CompleteSignature{$Interface}{"ShortName"}=~/$ParamName(_|)get(_|)\w+/i 3051 or $ReturnType_Name_Short=~/pointer|ptr/i); 3052 next if($ParamPLevel<=0); 3053 next if($ParamPLevel==1 and (isOpaque($ParamFTypeId) 3054 or get_TypeName($ParamFTypeId)=~/\A(((struct |)(_IO_FILE|__FILE|FILE))|void)\Z/)); 3055 next if(is_const_type($ParamTypeName) and $ParamPLevel<=2); 3056 next if($CompleteSignature{$Interface}{"ShortName"}=~/memcpy|already/i); 3057 3058 # allowed 3059 if((is_out_word($ParamName) and $CompleteSignature{$Interface}{"ShortName"}!~/free/i 3060 #! xmlC14NDocSaveTo (xmlDocPtr doc, xmlNodeSetPtr nodes, int exclusive, xmlChar** inclusive_ns_prefixes, int with_comments, xmlOutputBufferPtr buf) 3061 # XGetMotionEvents (Display* display, Window w, Time start, Time stop, int* nevents_return) 3062 3063 and ($ParamTypeName=~/\*/ or $ParamTypeName!~/(ptr|pointer|p\Z)/i) 3064 3065 # gsl_sf_bessel_il_scaled_array (int const lmax, double const x, double* result_array) 3066 and not grep(/\A(array)\Z/i, @{get_tokens($ParamName)}) 3067 3068 #! mysql_free_result ( MYSQL_RES* result ) 3069 and not is_out_word($ParamTypeName)) 3070 3071 # snd_card_get_name (int card, char** name) 3072 # FMOD_Channel_GetMode (FMOD_CHANNEL* channel, FMOD_MODE* mode) 3073 or $CompleteSignature{$Interface}{"ShortName"}=~/(get|create)[_]*[0-9a-z]*$ParamName\Z/i 3074 3075 # snd_config_get_ascii (snd_config_t const* config, char** value) 3076 or ($ParamPos==1 and $ParamName=~/value/i and $CompleteSignature{$Interface}{"ShortName"}=~/$ParamName_Prev[_]*get/i) 3077 3078 # poptDupArgv (int argc, char const** argv, int* argcPtr, char const*** argvPtr) 3079 or ($ParamName=~/ptr|pointer|(p\Z)/i and $ParamPLevel>=3)) 3080 { 3081 my $IsTransit = 0; 3082 foreach my $Pos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 3083 { 3084 my $OtherParamTypeId = $CompleteSignature{$Interface}{"Param"}{$Pos}{"type"}; 3085 my $OtherParamName = $CompleteSignature{$Interface}{"Param"}{$Pos}{"name"}; 3086 next if($OtherParamName eq $ParamName); 3087 my $OtherParamFTypeId = get_FoundationTypeId($OtherParamTypeId); 3088 if($ParamFTypeId eq $OtherParamFTypeId) 3089 { 3090 $IsTransit = 1; 3091 last; 3092 } 3093 } 3094 if($IsTransit or get_TypeType($ParamFTypeId)=~/\A(Intrinsic|Enum|Array)\Z/) 3095 { 3096 $OutParamInterface_Pos_NoUsing{$Interface}{$ParamPos}=1; 3097 $Interface_OutParam_NoUsing{$Interface}{$ParamName}=1; 3098 } 3099 else { 3100 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3101 } 3102 } 3103 ($ParamName_Prev, $ParamTypeId_Prev) = ($ParamName, $ParamTypeId); 3104 } 3105} 3106 3107sub setOutParams_Complex($) 3108{ # detect out-parameters by function name and parameter type 3109 my $Interface = $_[0]; 3110 my $Func_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 3111 my $ReturnType_Id = $CompleteSignature{$Interface}{"Return"}; 3112 my $ReturnType_Name_Short = get_TypeName($ReturnType_Id); 3113 while($ReturnType_Name_Short=~s/(\*|\&)([^<>()]+|)\Z/$2/g){}; 3114 return if(get_TypeType(get_FoundationTypeId($ReturnType_Id))!~/\A(Intrinsic|Enum)\Z/ 3115 or $Func_ShortName=~/\Q$ReturnType_Name_Short\E/); 3116 if(get_TypeName($ReturnType_Id) eq "void*" and $Func_ShortName=~/data/i) 3117 { # void* repo_sidedata_create ( Repo* repo, size_t size ) 3118 return; 3119 } 3120 return if($Func_ShortName!~/(new|create|open|top|update|start)/i and not is_alloc_func($Func_ShortName) 3121 and ($Func_ShortName!~/init/i or get_TypeName($ReturnType_Id) ne "void") and not $UserDefinedOutParam{$Interface}); 3122 return if($Func_ShortName=~/obsolete|createdup|updates/i); 3123 return if(not keys(%{$CompleteSignature{$Interface}{"Param"}})); 3124 return if($Func_ShortName=~/(already)/i); 3125 if(not detect_out_parameters($Interface, 1)) { 3126 detect_out_parameters($Interface, 0); 3127 } 3128} 3129 3130sub detect_out_parameters($$) 3131{ 3132 my ($Interface, $Strong) = @_; 3133 foreach my $ParamPos (sort{int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 3134 { 3135 my $ParamTypeId = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"type"}; 3136 my $ParamName = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}; 3137 if(isOutParam($ParamTypeId, $ParamPos, $Interface, $Strong)) 3138 { 3139 register_out_param($Interface, $ParamPos, $ParamName, $ParamTypeId); 3140 return 1; 3141 } 3142 } 3143 return 0; 3144} 3145 3146sub get_outparam_candidate($$) 3147{ 3148 my ($Interface, $Right) = @_; 3149 my $Func_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 3150 if($Right) 3151 { 3152 if($Func_ShortName=~/([a-z0-9]+)(_|)(new|open|init)\Z/i) { 3153 return $1; 3154 } 3155 } 3156 else 3157 { 3158 if($Func_ShortName=~/(new|open|init)(_|)([a-z0-9]+)/i) { 3159 return $3; 3160 } 3161 } 3162} 3163 3164sub isOutParam($$$$) 3165{ 3166 my ($Param_TypeId, $ParamPos, $Interface, $Strong) = @_; 3167 my $Param_Name = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}; 3168 my $PLevel = get_PointerLevel($Param_TypeId); 3169 my $TypeName = get_TypeName($Param_TypeId); 3170 my $Param_FTypeId = get_FoundationTypeId($Param_TypeId); 3171 my $Param_FTypeName = get_TypeName($Param_FTypeId); 3172 $Param_FTypeName=~s/\A(struct|union) //g; 3173 my $Param_FTypeType = get_TypeType($Param_FTypeId); 3174 return 0 if($PLevel<=0); 3175 return 0 if($PLevel==1 and isOpaque($Param_FTypeId)); 3176 return 0 if($Param_FTypeType!~/\A(Struct|Union|Class)\Z/); 3177 return 0 if(keys(%{$BaseType_PLevel_Return{$Param_FTypeId}{$PLevel}})); 3178 return 0 if(keys(%{$ReturnTypeId_Interface{$Param_TypeId}})); 3179 return 0 if(is_const_type($TypeName)); 3180 my $Func_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 3181 return 1 if($Func_ShortName=~/\A\Q$Param_FTypeName\E(_|)init/); 3182 if($Strong) 3183 { 3184 if(my $Candidate = get_outparam_candidate($Interface, 1)) { 3185 return ($Param_Name=~/\Q$Candidate\E/i); 3186 } 3187 } 3188 if(my $Candidate = get_outparam_candidate($Interface, 0)) { 3189 return 0 if($Param_Name!~/\Q$Candidate\E/i); 3190 } 3191 return 1 if(($Func_ShortName=~/(new|create|open|start)/i and $Func_ShortName!~/get|restart|set|test/) 3192 or is_alloc_func($Func_ShortName)); 3193 return 1 if($Func_ShortName=~/top/i and $PLevel==2); 3194 # snd_config_top 3195 return 1 if($UserDefinedOutParam{$Interface}{$Param_Name} 3196 or $UserDefinedOutParam{$Interface}{$ParamPos+1}); 3197 return 1 if($Func_ShortName=~/update/i and $Func_ShortName!~/add|append/i 3198 and $Func_ShortName=~/$Param_Name/i and $PLevel>=1); 3199 if($Func_ShortName=~/init/i) 3200 { 3201 if(keys(%{$CompleteSignature{$Interface}{"Param"}})==1 3202 or number_of_simple_params($Interface)==keys(%{$CompleteSignature{$Interface}{"Param"}})-1) { 3203 return 1; 3204 } 3205 } 3206 3207 return 0; 3208} 3209 3210sub number_of_simple_params($) 3211{ 3212 my $Interface = $_[0]; 3213 return 0 if(not $Interface); 3214 my $Count = 0; 3215 foreach my $Pos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 3216 { 3217 my $TypeId = $CompleteSignature{$Interface}{"Param"}{$Pos}{"type"}; 3218 my $PName = $CompleteSignature{$Interface}{"Param"}{$Pos}{"name"}; 3219 if(get_TypeType($TypeId)=~/\A(Intrinsic|Enum)\Z/ 3220 or isString($TypeId, $PName, $Interface)) { 3221 $Count+=1; 3222 } 3223 } 3224 return $Count; 3225} 3226 3227sub get_OutParamFamily($$) 3228{ 3229 my ($TypeId, $IncludeOuter) = @_; 3230 my $FTypeId = get_FoundationTypeId($TypeId); 3231 if(get_TypeType($FTypeId)=~/Struct|Union|Class/) 3232 { 3233 my @Types = ($IncludeOuter and ($TypeId ne $FTypeId))?($TypeId, $FTypeId):($FTypeId); 3234 while(my $ReducedTypeId = reduce_pointer_level($TypeId)) 3235 { 3236 push(@Types, $ReducedTypeId); 3237 $TypeId = $ReducedTypeId; 3238 } 3239 return @Types; 3240 } 3241 else 3242 { 3243 my @Types = ($IncludeOuter)?($TypeId):(); 3244 my $ReducedTypeId = reduce_pointer_level($TypeId); 3245 if(get_TypeType($ReducedTypeId) eq "Typedef") { 3246 push(@Types, $ReducedTypeId); 3247 } 3248 return @Types; 3249 } 3250 return (); 3251} 3252 3253sub is_alloc_func($) 3254{ 3255 my $FuncName = $_[0]; 3256 return ($FuncName=~/alloc/i and $FuncName!~/dealloc|realloc/i); 3257} 3258 3259sub markAbstractClasses() 3260{ 3261 foreach my $Interface (keys(%CompleteSignature)) 3262 { 3263 if($CompleteSignature{$Interface}{"PureVirt"}) { 3264 markAbstractSubClasses($CompleteSignature{$Interface}{"Class"}, $Interface); 3265 } 3266 } 3267} 3268 3269sub markAbstractSubClasses($$) 3270{ 3271 my ($ClassId, $Interface) = @_; 3272 return if(not $ClassId or not $Interface); 3273 my $TargetSuffix = get_symbol_suffix($Interface); 3274 my $TargetShortName = $CompleteSignature{$Interface}{"ShortName"}; 3275 foreach my $InterfaceCandidate (keys(%{$Class_Method{$ClassId}})) 3276 { 3277 if($TargetSuffix eq get_symbol_suffix($InterfaceCandidate)) 3278 { 3279 if($CompleteSignature{$Interface}{"Constructor"}) 3280 { 3281 if($CompleteSignature{$InterfaceCandidate}{"Constructor"}) { 3282 return; 3283 } 3284 } 3285 elsif($CompleteSignature{$Interface}{"Destructor"}) 3286 { 3287 if($CompleteSignature{$InterfaceCandidate}{"Destructor"}) { 3288 return; 3289 } 3290 } 3291 else 3292 { 3293 if($TargetShortName eq $CompleteSignature{$InterfaceCandidate}{"ShortName"}) { 3294 return; 3295 } 3296 } 3297 } 3298 } 3299 $Class_PureVirtFunc{get_TypeName($ClassId)}{$Interface} = 1; 3300 foreach my $SubClass_Id (keys(%{$Class_SubClasses{$ClassId}})) { 3301 markAbstractSubClasses($SubClass_Id, $Interface); 3302 } 3303} 3304 3305sub cleanName($) 3306{ 3307 my $Name = $_[0]; 3308 return "" if(not $Name); 3309 foreach my $Token (sort keys(%Operator_Indication)) 3310 { 3311 my $Token_Translate = $Operator_Indication{$Token}; 3312 $Name=~s/\Q$Token_Translate\E/\_$Token\_/g; 3313 } 3314 $Name=~s/\,/_/g; 3315 $Name=~s/\./_p_/g; 3316 $Name=~s/\:/_/g; 3317 $Name=~s/\]/_rb_/g; 3318 $Name=~s/\[/_lb_/g; 3319 $Name=~s/\(/_/g; 3320 $Name=~s/\)/_/g; 3321 $Name=~s/ /_/g; 3322 while($Name=~/__/) { 3323 $Name=~s/__/_/g; 3324 } 3325 $Name=~s/\_\Z//; 3326 return $Name; 3327} 3328 3329sub getTestName($) 3330{ 3331 my $Interface = $_[0]; 3332 $Interface=~s/\?//g; 3333 return $Interface; 3334} 3335 3336sub getTestPath($) 3337{ 3338 my $Interface = $_[0]; 3339 my $TestPath = ""; 3340 if($Interface_LibGroup{$Interface}) { 3341 $TestPath = $TEST_SUITE_PATH."/groups/".cleanGroup($Interface_LibGroup{$Interface})."/".getTestName($Interface); 3342 } 3343 else 3344 { 3345 my $ClassName = get_TypeName($CompleteSignature{$Interface}{"Class"}); 3346 if($OSgroup eq "windows") { 3347 $ClassName = cleanName($ClassName); 3348 } 3349 my $Header = $CompleteSignature{$Interface}{"Header"}; 3350 $Header=~s/(\.\w+)\Z//g; 3351 $TestPath = $TEST_SUITE_PATH."/groups/".get_filename($Header)."/".(($ClassName)?"classes/".get_type_short_name($ClassName):"functions")."/".getTestName($Interface); 3352 } 3353 return $TestPath; 3354} 3355 3356sub getLibGroupPath($$$) 3357{ 3358 my ($C1, $C2, $TwoComponets) = @_; 3359 return () if(not $C1); 3360 $C1 = cleanGroup($C1); 3361 if($TwoComponets) 3362 { 3363 if($C2) { 3364 return ($TEST_SUITE_PATH."/$TargetLibraryName-t2c/", $C1, $C2); 3365 } 3366 else { 3367 return ($TEST_SUITE_PATH."/$TargetLibraryName-t2c/", $C1, "functions"); 3368 } 3369 } 3370 else { 3371 return ($TEST_SUITE_PATH."/$TargetLibraryName-t2c/", "", $C1); 3372 } 3373} 3374 3375sub getLibGroupName($$) 3376{ 3377 my ($C1, $C2) = @_; 3378 return "" if(not $C1); 3379 if($C2) { 3380 return $C2; 3381 } 3382 else { 3383 return $C1; 3384 } 3385} 3386 3387sub cleanGroup($) 3388{ 3389 my $Name = $_[0]; 3390 $Name=~s/(\.\w+)\Z//g; 3391 $Name=~s/( |-)/_/g; 3392 $Name=~s/\([^()]+\)//g; 3393 $Name=~s/[_]{2,}/_/g; 3394 return $Name; 3395} 3396 3397sub find_center($$) 3398{ 3399 my ($Sign, $Target) = @_; 3400 my %B = ( "("=>0, "<"=>0, ")"=>0, ">"=>0 ); 3401 my $Center = 0; 3402 if($Sign=~s/(operator([^\w\s\(\)]+|\(\)))//g) 3403 { # operators 3404 $Center+=length($1); 3405 } 3406 foreach my $Pos (0 .. length($Sign)-1) 3407 { 3408 my $S = substr($Sign, $Pos, 1); 3409 if($S eq $Target) 3410 { 3411 if($B{"("}==$B{")"} 3412 and $B{"<"}==$B{">"}) { 3413 return $Center; 3414 } 3415 } 3416 if(defined $B{$S}) { 3417 $B{$S}+=1; 3418 } 3419 $Center+=1; 3420 } 3421 return 0; 3422} 3423 3424sub skipSymbol($) 3425{ 3426 my $Symbol = $_[0]; 3427 return 1 if($SkipInterfaces{$Symbol}); 3428 foreach my $SkipPattern (keys(%SkipInterfaces_Pattern)) { 3429 return 1 if($Symbol=~/$SkipPattern/); 3430 } 3431 return 0; 3432} 3433 3434sub symbolFilter($) 3435{ 3436 my $Symbol = $_[0]; 3437 3438 return 0 if(skipSymbol($Symbol)); 3439 return 0 if(index($Symbol, "_aux_")==0); 3440 3441 return 0 if(not $CompleteSignature{$Symbol}{"Header"}); 3442 return 0 if($CompleteSignature{$Symbol}{"Private"}); 3443 return 0 if($CompleteSignature{$Symbol}{"Data"}); 3444 3445 my $ClassId = $CompleteSignature{$Symbol}{"Class"}; 3446 3447 if(not $TargetInterfaceName 3448 and not keys(%InterfacesList)) 3449 { 3450 return 0 if($Symbol=~/\A(_ZS|_ZNS|_ZNKS)/); # stdc++ symbols 3451 if(not defined $KeepInternal) 3452 { # --keep-internal 3453 if(index($Symbol, "__")==0) 3454 { # __argz_count 3455 return 0; 3456 } 3457 if(index($CompleteSignature{$Symbol}{"ShortName"}, "__")==0) 3458 { 3459 return 0; 3460 } 3461 if($ClassId) 3462 { 3463 if(my $NameSpace = $TypeInfo{$ClassId}{"NameSpace"}) 3464 { 3465 if(my $NSId = $TName_Tid{$NameSpace}) 3466 { 3467 if($TypeInfo{$NSId}{"Type"}=~/Struct|Class/) 3468 { # internal classes 3469 return 0; 3470 } 3471 } 3472 3473 } 3474 } 3475 } 3476 return 0 if($CompleteSignature{$Symbol}{"Weak"}); 3477 } 3478 if(index($Symbol, "_ZN9__gnu_cxx")==0) { 3479 return 0; 3480 } 3481 if($CompleteSignature{$Symbol}{"Constructor"}) { 3482 return ( not ($Symbol=~/C1E/ and ($CompleteSignature{$Symbol}{"Protected"} or isAbstractClass($ClassId))) ); 3483 } 3484 elsif($CompleteSignature{$Symbol}{"Destructor"}) { 3485 return ( not ($Symbol=~/D0E|D1E/ and ($CompleteSignature{$Symbol}{"Protected"} or isAbstractClass($ClassId))) ); 3486 } 3487 return 1; 3488} 3489 3490sub addHeaders($$) 3491{ 3492 my ($NewHeaders, $OldHeaders) = @_; 3493 my (%Old, @Before, @After) = (); 3494 if($OldHeaders) 3495 { 3496 foreach (@{$OldHeaders}) 3497 { 3498 if($_) 3499 { 3500 $Old{$_} = 1; 3501 push(@After, $_); 3502 } 3503 } 3504 } 3505 if($NewHeaders) 3506 { 3507 foreach (@{$NewHeaders}) 3508 { 3509 if($_) 3510 { 3511 if(not defined $Old{$_}) { 3512 push(@Before, $_); 3513 } 3514 } 3515 } 3516 } 3517 my @Result = (@Before, @After); 3518 return \@Result; 3519} 3520 3521sub getTypeHeaders($) 3522{ 3523 my $TypeId = $_[0]; 3524 return [] if(not $TypeId); 3525 my %Type = delete_quals($TypeId); 3526 my $Headers = [$TypeInfo{$Type{"Tid"}}{"Header"}]; 3527 if(defined $Type{"TParam"}) 3528 { # template parameters 3529 foreach my $Pos (sort {int($a)<=>int($b)} keys(%{$Type{"TParam"}})) 3530 { 3531 if(my $Tid = $TName_Tid{$Type{"TParam"}{$Pos}}) { 3532 $Headers = addHeaders(getTypeHeaders($Tid), $Headers); 3533 } 3534 } 3535 } 3536 if(my $NS = $Type{"NameSpaceClassId"}) { 3537 $Headers = addHeaders(getTypeHeaders($NS), $Headers); 3538 } 3539 return $Headers; 3540} 3541 3542sub get_TypeName($) 3543{ 3544 my $TypeId = $_[0]; 3545 return $TypeInfo{$TypeId}{"Name"}; 3546} 3547 3548sub get_TypeType($) 3549{ 3550 my $TypeId = $_[0]; 3551 return $TypeInfo{$TypeId}{"Type"}; 3552} 3553 3554sub get_TypeAttr($$) 3555{ 3556 my ($TypeId, $Attr) = @_; 3557 return $TypeInfo{$TypeId}{$Attr}; 3558} 3559 3560sub isNotInCharge($) 3561{ 3562 my $Interface = $_[0]; 3563 return ($CompleteSignature{$Interface}{"Constructor"} 3564 and $Interface=~/C2E/); 3565} 3566 3567sub isInCharge($) 3568{ 3569 my $Interface = $_[0]; 3570 return ($CompleteSignature{$Interface}{"Constructor"} 3571 and $Interface=~/C1E/); 3572} 3573 3574sub replace_c2c1($) 3575{ 3576 my $Interface = $_[0]; 3577 if($CompleteSignature{$Interface}{"Constructor"}) { 3578 $Interface=~s/C2E/C1E/; 3579 } 3580 return $Interface; 3581} 3582 3583sub getSubClassName($) 3584{ 3585 my $ClassName = $_[0]; 3586 return getSubClassBaseName($ClassName)."_SubClass"; 3587} 3588 3589sub getSubClassBaseName($) 3590{ 3591 my $ClassName = $_[0]; 3592 $ClassName=~s/\:\:|<|>|\(|\)|\[|\]|\ |,|\*/_/g; 3593 $ClassName=~s/[_][_]+/_/g; 3594 return $ClassName; 3595} 3596 3597sub getNumOfParams($) 3598{ 3599 my $Interface = $_[0]; 3600 my @Params = keys(%{$CompleteSignature{$Interface}{"Param"}}); 3601 return ($#Params + 1); 3602} 3603 3604sub sort_byCriteria($$) 3605{ 3606 my ($Interfaces, $Criteria) = @_; 3607 my (@NewInterfaces1, @NewInterfaces2) = (); 3608 foreach my $Interface (@{$Interfaces}) 3609 { 3610 if(compare_byCriteria($Interface, $Criteria)) { 3611 push(@NewInterfaces1, $Interface); 3612 } 3613 else { 3614 push(@NewInterfaces2, $Interface); 3615 } 3616 } 3617 @{$Interfaces} = (@NewInterfaces1, @NewInterfaces2); 3618} 3619 3620sub get_int_prefix($) 3621{ 3622 if($_[0]=~/\A([a-z0-9]+)_[a-z0-9]/i) { 3623 return $1; 3624 } 3625 return ""; 3626} 3627 3628sub sort_byLibrary($$) 3629{ 3630 my ($Interfaces, $Library) = @_; 3631 return if(not $Library); 3632 my $LibPrefix = $SoLib_IntPrefix{$Library}; 3633 my (@NewInterfaces1, @NewInterfaces2, @NewInterfaces3) = (); 3634 foreach my $Interface (@{$Interfaces}) 3635 { 3636 my $IntPrefix = get_int_prefix($Interface); 3637 if(get_filename($Symbol_Library{$Interface}) eq $Library 3638 or get_filename($DepSymbol_Library{$Interface}) eq $Library) { 3639 push(@NewInterfaces1, $Interface); 3640 } 3641 elsif(not $Symbol_Library{$Interface} 3642 and not $DepSymbol_Library{$Interface}) { 3643 push(@NewInterfaces1, $Interface); 3644 } 3645 elsif($Interface=~/environment/i) 3646 { # functions to set evironment should NOT be sorted 3647 push(@NewInterfaces1, $Interface); 3648 } 3649 elsif($LibPrefix and ($LibPrefix eq $IntPrefix)) { 3650 push(@NewInterfaces2, $Interface); 3651 } 3652 else { 3653 push(@NewInterfaces3, $Interface); 3654 } 3655 } 3656 @{$Interfaces} = (@NewInterfaces1, @NewInterfaces2, @NewInterfaces3); 3657} 3658 3659sub get_tokens($) 3660{ 3661 my $Word = $_[0]; 3662 return $Cache{"get_tokens"}{$Word} if(defined $Cache{"get_tokens"}{$Word}); 3663 my @Tokens = (); 3664 if($Word=~/\s+|[_]+/) 3665 { 3666 foreach my $Elem (split(/[_:\s]+/, $Word)) 3667 { 3668 foreach my $SubElem (@{get_tokens($Elem)}) { 3669 push(@Tokens, $SubElem); 3670 } 3671 } 3672 } 3673 else 3674 { 3675 my $WCopy = $Word; 3676 while($WCopy=~s/([A-Z]*[a-z]+|\d+)//) { 3677 push(@Tokens, lc($1)); 3678 } 3679 $WCopy=$Word; 3680 while($WCopy=~s/([A-Z]{2,})//) { 3681 push(@Tokens, lc($1)); 3682 } 3683 $WCopy=$Word; 3684 while($WCopy=~s/([A-Z][a-z]+)([A-Z]|\Z)/$2/) { 3685 push(@Tokens, lc($1)); 3686 } 3687 } 3688 @Tokens = unique_array(@Tokens); 3689 $Cache{"get_tokens"}{$Word} = \@Tokens; 3690 return \@Tokens; 3691} 3692 3693sub unique_array(@) 3694{ 3695 my %seen = (); 3696 my @uniq = (); 3697 foreach my $item (@_) 3698 { 3699 unless ($seen{$item}) 3700 { # if we get here, we have not seen it before 3701 $seen{$item} = 1; 3702 push(@uniq, $item); 3703 } 3704 } 3705 return @uniq; 3706} 3707 3708sub sort_byName($$$) 3709{ 3710 my ($Words, $KeyWords, $Type) = @_; 3711 my %Word_Coincidence = (); 3712 foreach my $Word (@{$Words}) 3713 { 3714 my $TargetWord = $Word; 3715 if($Word=~/\A(_Z|\?)/) { 3716 $TargetWord = $CompleteSignature{$Word}{"ShortName"}." ".get_TypeName($CompleteSignature{$Word}{"Class"}); 3717 } 3718 $Word_Coincidence{$Word} = get_word_coinsidence($TargetWord, $KeyWords); 3719 } 3720 @{$Words} = sort {$Word_Coincidence{$b} <=> $Word_Coincidence{$a}} @{$Words}; 3721 if($Type eq "Constants") 3722 { 3723 my @Words_With_Tokens = (); 3724 foreach my $Word (@{$Words}) 3725 { 3726 if($Word_Coincidence{$Word}>0) { 3727 push(@Words_With_Tokens, $Word); 3728 } 3729 } 3730 @{$Words} = @Words_With_Tokens; 3731 } 3732} 3733 3734sub sort_FileOpen($) 3735{ 3736 my @Interfaces = @{$_[0]}; 3737 my (@FileOpen, @Other) = (); 3738 foreach my $Interface (sort {length($a) <=> length($b)} @Interfaces) 3739 { 3740 if($CompleteSignature{$Interface}{"ShortName"}=~/fopen/i) { 3741 push(@FileOpen, $Interface); 3742 } 3743 else { 3744 push(@Other, $Interface); 3745 } 3746 } 3747 @{$_[0]} = (@FileOpen, @Other); 3748} 3749 3750sub get_word_coinsidence($$) 3751{ 3752 my ($Word, $KeyWords) = @_; 3753 my @WordTokens1 = @{get_tokens($Word)}; 3754 return 0 if($#WordTokens1==-1); 3755 my %WordTokens_Inc = (); 3756 my $WordTokens_Num = 0; 3757 foreach my $Token (@WordTokens1) 3758 { 3759 next if($Token=~/\A(get|create|new|insert)\Z/); 3760 $WordTokens_Inc{$Token} = ++$WordTokens_Num; 3761 } 3762 my @WordTokens2 = @{get_tokens($KeyWords)}; 3763 return 0 if($#WordTokens2==-1); 3764 my $Weight=$#WordTokens2+2; 3765 my $StartWeight = $Weight; 3766 my $WordCoincidence = 0; 3767 foreach my $Token (@WordTokens2) 3768 { 3769 next if($Token=~/\A(get|create|new|insert)\Z/); 3770 if(defined $WordTokens_Inc{$Token} or defined $WordTokens_Inc{$ShortTokens{$Token}}) 3771 { 3772 if($WordTokens_Inc{$Token}==1 3773 and $Library_Prefixes{$Token}+$Library_Prefixes{$Token."_"}>=$LIBRARY_PREFIX_MAJORITY) 3774 { # first token is usually a library prefix 3775 $WordCoincidence+=$Weight; 3776 } 3777 else { 3778 $WordCoincidence+=$Weight-$WordTokens_Num/($StartWeight+$WordTokens_Num); 3779 } 3780 } 3781 $Weight-=1; 3782 } 3783 return $WordCoincidence*100/($#WordTokens2+1); 3784} 3785 3786sub compare_byCriteria($$) 3787{ 3788 my ($Interface, $Criteria) = @_; 3789 if($Criteria eq "DeleteSmth") { 3790 return $CompleteSignature{$Interface}{"ShortName"}!~/delete|remove|destroy|cancel/i; 3791 } 3792 elsif($Criteria eq "InLine") { 3793 return $CompleteSignature{$Interface}{"InLine"}; 3794 } 3795 elsif($Criteria eq "Function") { 3796 return $CompleteSignature{$Interface}{"Type"} eq "Function"; 3797 } 3798 elsif($Criteria eq "WithParams") { 3799 return getNumOfParams($Interface); 3800 } 3801 elsif($Criteria eq "WithoutParams") { 3802 return getNumOfParams($Interface)==0; 3803 } 3804 elsif($Criteria eq "Public") { 3805 return (not $CompleteSignature{$Interface}{"Protected"}); 3806 } 3807 elsif($Criteria eq "Default") { 3808 return ($Interface=~/default/i); 3809 } 3810 elsif($Criteria eq "VaList") { 3811 return ($Interface!~/valist/i); 3812 } 3813 elsif($Criteria eq "NotInCharge") { 3814 return (not isNotInCharge($Interface)); 3815 } 3816 elsif($Criteria eq "Class") { 3817 return (get_TypeName($CompleteSignature{$Interface}{"Class"}) ne "QApplication"); 3818 } 3819 elsif($Criteria eq "Data") { 3820 return (not $CompleteSignature{$Interface}{"Data"}); 3821 } 3822 elsif($Criteria eq "FirstParam_Intrinsic") 3823 { 3824 if(defined $CompleteSignature{$Interface}{"Param"} 3825 and defined $CompleteSignature{$Interface}{"Param"}{"0"}) 3826 { 3827 my $FirstParamType_Id = $CompleteSignature{$Interface}{"Param"}{"0"}{"type"}; 3828 return (get_TypeType(get_FoundationTypeId($FirstParamType_Id)) eq "Intrinsic"); 3829 } 3830 else { 3831 return 0; 3832 } 3833 } 3834 elsif($Criteria eq "FirstParam_Enum") 3835 { 3836 if(defined $CompleteSignature{$Interface}{"Param"} 3837 and defined $CompleteSignature{$Interface}{"Param"}{"0"}) 3838 { 3839 my $FirstParamType_Id = $CompleteSignature{$Interface}{"Param"}{"0"}{"type"}; 3840 return (get_TypeType(get_FoundationTypeId($FirstParamType_Id)) eq "Enum"); 3841 } 3842 else { 3843 return 0; 3844 } 3845 } 3846 elsif($Criteria eq "FirstParam_PKc") 3847 { 3848 if(defined $CompleteSignature{$Interface}{"Param"} 3849 and defined $CompleteSignature{$Interface}{"Param"}{"0"}) 3850 { 3851 my $FirstParamType_Id = $CompleteSignature{$Interface}{"Param"}{"0"}{"type"}; 3852 return (get_TypeName($FirstParamType_Id) eq "char const*"); 3853 } 3854 else { 3855 return 0; 3856 } 3857 } 3858 elsif($Criteria eq "FirstParam_char") 3859 { 3860 if(defined $CompleteSignature{$Interface}{"Param"} 3861 and defined $CompleteSignature{$Interface}{"Param"}{"0"}) 3862 { 3863 my $FirstParamType_Id = $CompleteSignature{$Interface}{"Param"}{"0"}{"type"}; 3864 return (get_TypeName($FirstParamType_Id) eq "char"); 3865 } 3866 else { 3867 return 0; 3868 } 3869 } 3870 elsif($Criteria eq "Operator") { 3871 return ($CompleteSignature{$Interface}{"ShortName"}!~/operator[^a-z]/i); 3872 } 3873 elsif($Criteria eq "Library") { 3874 return ($Symbol_Library{$Interface} or $Library_Class{$CompleteSignature{$Interface}{"Class"}}); 3875 } 3876 elsif($Criteria eq "Internal") { 3877 return ($CompleteSignature{$Interface}{"ShortName"}!~/\A_/); 3878 } 3879 elsif($Criteria eq "Internal") { 3880 return ($CompleteSignature{$Interface}{"ShortName"}!~/debug/i); 3881 } 3882 elsif($Criteria eq "FileManipulating") 3883 { 3884 return 0 if($CompleteSignature{$Interface}{"ShortName"}=~/fopen|file/); 3885 foreach my $ParamPos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 3886 { 3887 my $ParamTypeId = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"type"}; 3888 my $ParamName = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"name"}; 3889 if(isString($ParamTypeId, $ParamName, $Interface)) 3890 { 3891 return 0 if(isStr_FileName($ParamPos, $ParamName, $CompleteSignature{$Interface}{"ShortName"}) 3892 or isStr_Dir($ParamName, $CompleteSignature{$Interface}{"ShortName"})); 3893 } 3894 else { 3895 return 0 if(isFD($ParamTypeId, $ParamName)); 3896 } 3897 } 3898 return 1; 3899 } 3900 else { 3901 return 1; 3902 } 3903} 3904 3905sub sort_byRecurParams($) 3906{ 3907 my @Interfaces = @{$_[0]}; 3908 my (@Other, @WithRecurParams) = (); 3909 foreach my $Interface (@Interfaces) 3910 { 3911 my $WithRecur = 0; 3912 foreach my $ParamPos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 3913 { 3914 my $ParamType_Id = $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"type"}; 3915 if(isCyclical(\@RecurTypeId, get_TypeStackId($ParamType_Id))) { 3916 $WithRecur=1; 3917 last; 3918 } 3919 } 3920 if($WithRecur) { 3921 push(@WithRecurParams, $Interface); 3922 } 3923 else 3924 { 3925 if($CompleteSignature{$Interface}{"ShortName"}!~/copy|duplicate/i) { 3926 push(@Other, $Interface); 3927 } 3928 } 3929 } 3930 @{$_[0]} = (@Other, @WithRecurParams); 3931 return $#WithRecurParams; 3932} 3933 3934sub sort_LibMainFunc($) 3935{ 3936 my @Interfaces = @{$_[0]}; 3937 my (@First, @Other) = (); 3938 foreach my $Interface (@Interfaces) 3939 { 3940 my $ShortName = cut_NamePrefix($CompleteSignature{$Interface}{"ShortName"}); 3941 if($ShortName=~/\A(create|default|get|new|init)\Z/i) { 3942 push(@First, $Interface); 3943 } 3944 else { 3945 push(@Other, $Interface); 3946 } 3947 } 3948 @{$_[0]} = (@First, @Other); 3949} 3950 3951sub sort_CreateParam($$) 3952{ 3953 my @Interfaces = @{$_[0]}; 3954 my $KeyWords = $_[1]; 3955 foreach my $Prefix (keys(%Library_Prefixes)) 3956 { 3957 if($Library_Prefixes{$Prefix}>=$LIBRARY_PREFIX_MAJORITY) { 3958 $KeyWords=~s/(\A| )$Prefix/$1/g; 3959 } 3960 } 3961 $KeyWords=~s/(\A|_)(new|get|create|default|alloc|init)(_|\Z)//g; 3962 my (@First, @Other) = (); 3963 foreach my $Interface (@Interfaces) 3964 { 3965 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 3966 if($ShortName=~/create|default|get|new|init/i 3967 and get_word_coinsidence($ShortName, $KeyWords)>0) { 3968 push(@First, $Interface); 3969 } 3970 else { 3971 push(@Other, $Interface); 3972 } 3973 } 3974 @{$_[0]} = (@First, @Other); 3975} 3976 3977sub grep_token($$) 3978{ 3979 my ($Word, $Token) = @_; 3980 return grep(/\A($Token)\Z/i, @{get_tokens($Word)}); 3981} 3982 3983sub cut_NamePrefix($) 3984{ 3985 my $Name = $_[0]; 3986 return "" if(not $Name); 3987 if(my $Prefix = getPrefix($Name)) 3988 { 3989 if($Library_Prefixes{$Prefix}>=$LIBRARY_PREFIX_MAJORITY) { 3990 $Name=~s/\A\Q$Prefix\E//; 3991 } 3992 } 3993 return $Name; 3994} 3995 3996sub sort_GetCreate($) 3997{ 3998 my @Interfaces = @{$_[0]}; 3999 my (@Open, @Root, @Create, @Default, @New, @Alloc, @Init, @Get, @Other, @Copy, @Wait) = (); 4000 foreach my $Interface (@Interfaces) 4001 { 4002 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 4003 if(grep_token($ShortName, "open")) { 4004 push(@Open, $Interface); 4005 } 4006 elsif(grep_token($ShortName, "root") 4007 and grep_token($ShortName, "default")) { 4008 push(@Root, $Interface); 4009 } 4010 elsif(grep_token($ShortName, "create")) { 4011 push(@Create, $Interface); 4012 } 4013 elsif(grep_token($ShortName, "default") 4014 and not grep_token($ShortName, "get")) { 4015 push(@Default, $Interface); 4016 } 4017 elsif(grep_token($ShortName, "new")) { 4018 push(@New, $Interface); 4019 } 4020 elsif(is_alloc_func($ShortName)) { 4021 push(@Alloc, $Interface); 4022 } 4023 elsif(grep_token($ShortName, "init")) { 4024 push(@Init, $Interface); 4025 } 4026 elsif(grep_token($ShortName, "get")) { 4027 push(@Get, $Interface); 4028 } 4029 elsif(grep_token($ShortName, "copy")) { 4030 push(@Copy, $Interface); 4031 } 4032 elsif(grep_token($ShortName, "wait")) { 4033 push(@Wait, $Interface); 4034 } 4035 else { 4036 push(@Other, $Interface); 4037 } 4038 } 4039 my @PrimaryGroup = (@Open, @Root, @Create, @Default); 4040 sort_byCriteria(\@PrimaryGroup, "WithoutParams"); 4041 @{$_[0]} = (@PrimaryGroup, @New, @Alloc, @Init, @Get, @Other, @Copy, @Wait); 4042} 4043 4044sub get_CompatibleInterfaces($$$) 4045{ 4046 my ($TypeId, $Method, $KeyWords) = @_; 4047 return () if(not $TypeId or not $Method); 4048 my @Ints = compatible_interfaces($TypeId, $Method, $KeyWords); 4049 sort_byRecurParams(\@Ints) if(get_TypeName($TypeId)!~/time_t/); 4050 return @Ints; 4051} 4052 4053sub compatible_interfaces($$$) 4054{ 4055 my ($TypeId, $Method, $KeyWords) = @_; 4056 return () if(not $TypeId or not $Method); 4057 if(defined $Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords} 4058 and not defined $RandomCode and not defined $AuxType{$TypeId}) { 4059 return @{$Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords}}; 4060 } 4061 my @Symbols = (); 4062 if($Method eq "Construct") 4063 { 4064 foreach my $Constructor (keys(%{$Class_Constructors{$TypeId}})) { 4065 @Symbols = (@Symbols, $Constructor); 4066 } 4067 } 4068 elsif($Method eq "Return") 4069 { 4070 foreach my $Interface (keys(%{$ReturnTypeId_Interface{$TypeId}})) 4071 { 4072 next if($CompleteSignature{$Interface}{"PureVirt"}); 4073 @Symbols = (@Symbols, $Interface); 4074 } 4075 } 4076 elsif($Method eq "OutParam") 4077 { 4078 foreach my $Interface (keys(%{$OutParam_Interface{$TypeId}})) 4079 { 4080 next if($CompleteSignature{$Interface}{"Protected"}); 4081 next if($CompleteSignature{$Interface}{"PureVirt"}); 4082 @Symbols = (@Symbols, $Interface); 4083 } 4084 } 4085 elsif($Method eq "OnlyReturn") 4086 { 4087 foreach my $Interface (keys(%{$ReturnTypeId_Interface{$TypeId}})) 4088 { 4089 next if($CompleteSignature{$Interface}{"PureVirt"}); 4090 next if($CompleteSignature{$Interface}{"Data"}); 4091 @Symbols = (@Symbols, $Interface); 4092 } 4093 } 4094 elsif($Method eq "OnlyData") 4095 { 4096 foreach my $Interface (keys(%{$ReturnTypeId_Interface{$TypeId}})) 4097 { 4098 next if(not $CompleteSignature{$Interface}{"Data"}); 4099 @Symbols = (@Symbols, $Interface); 4100 } 4101 } 4102 else 4103 { 4104 @{$Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords}} = (); 4105 return (); 4106 } 4107 4108 my @CompatibleInterfaces = (); 4109 4110 foreach my $Symbol (@Symbols) 4111 { 4112 next if(skipSymbol($Symbol)); 4113 next if($CompleteSignature{$Symbol}{"Private"}); 4114 4115 push(@CompatibleInterfaces, $Symbol); 4116 } 4117 4118 if($#CompatibleInterfaces==-1) 4119 { 4120 @{$Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords}} = (); 4121 return (); 4122 } 4123 elsif($#CompatibleInterfaces==0) 4124 { 4125 @{$Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords}} = @CompatibleInterfaces; 4126 return @CompatibleInterfaces; 4127 } 4128 # sort by name 4129 @CompatibleInterfaces = sort @CompatibleInterfaces; 4130 @CompatibleInterfaces = sort {$CompleteSignature{$a}{"ShortName"} cmp $CompleteSignature{$b}{"ShortName"}} (@CompatibleInterfaces); 4131 @CompatibleInterfaces = sort {length($CompleteSignature{$a}{"ShortName"}) <=> length($CompleteSignature{$b}{"ShortName"})} (@CompatibleInterfaces); 4132 # sort by number of parameters 4133 if(defined $MinimumCode) { 4134 @CompatibleInterfaces = sort {int(keys(%{$CompleteSignature{$a}{"Param"}}))<=>int(keys(%{$CompleteSignature{$b}{"Param"}}))} (@CompatibleInterfaces); 4135 } 4136 elsif(defined $MaximumCode) { 4137 @CompatibleInterfaces = sort {int(keys(%{$CompleteSignature{$b}{"Param"}}))<=>int(keys(%{$CompleteSignature{$a}{"Param"}}))} (@CompatibleInterfaces); 4138 } 4139 else 4140 { 4141 sort_byCriteria(\@CompatibleInterfaces, "FirstParam_Intrinsic"); 4142 sort_byCriteria(\@CompatibleInterfaces, "FirstParam_char"); 4143 sort_byCriteria(\@CompatibleInterfaces, "FirstParam_PKc"); 4144 sort_byCriteria(\@CompatibleInterfaces, "FirstParam_Enum") if(get_TypeName($TypeId)!~/char|string/i or $Method ne "Construct"); 4145 @CompatibleInterfaces = sort {int(keys(%{$CompleteSignature{$a}{"Param"}}))<=>int(keys(%{$CompleteSignature{$b}{"Param"}}))} (@CompatibleInterfaces); 4146 @CompatibleInterfaces = sort {$b=~/virtual/i <=> $a=~/virtual/i} (@CompatibleInterfaces); 4147 sort_byCriteria(\@CompatibleInterfaces, "WithoutParams"); 4148 sort_byCriteria(\@CompatibleInterfaces, "WithParams") if($Method eq "Construct"); 4149 } 4150 sort_byCriteria(\@CompatibleInterfaces, "Operator"); 4151 sort_byCriteria(\@CompatibleInterfaces, "FileManipulating"); 4152 if($Method ne "Construct") 4153 { 4154 sort_byCriteria(\@CompatibleInterfaces, "Class"); 4155 sort_CreateParam(\@CompatibleInterfaces, $KeyWords); 4156 sort_GetCreate(\@CompatibleInterfaces); 4157 sort_byName(\@CompatibleInterfaces, $KeyWords, "Interfaces"); 4158 sort_FileOpen(\@CompatibleInterfaces) if(get_TypeName(get_FoundationTypeId($TypeId))=~/\A(struct |)(_IO_FILE|__FILE|FILE|_iobuf)\Z/); 4159 sort_LibMainFunc(\@CompatibleInterfaces); 4160 sort_byCriteria(\@CompatibleInterfaces, "Data"); 4161 sort_byCriteria(\@CompatibleInterfaces, "Function"); 4162 sort_byCriteria(\@CompatibleInterfaces, "Library"); 4163 sort_byCriteria(\@CompatibleInterfaces, "Internal"); 4164 sort_byCriteria(\@CompatibleInterfaces, "Debug"); 4165 if(get_TypeName($TypeId) ne "GType" 4166 and (my $Lib = get_TypeLib($TypeId)) ne "unknown") { 4167 sort_byLibrary(\@CompatibleInterfaces, $Lib); 4168 } 4169 } 4170 if(defined $RandomCode) { 4171 @CompatibleInterfaces = mix_array(@CompatibleInterfaces); 4172 } 4173 sort_byCriteria(\@CompatibleInterfaces, "Public"); 4174 sort_byCriteria(\@CompatibleInterfaces, "NotInCharge") if($Method eq "Construct"); 4175 @{$Cache{"compatible_interfaces"}{$TypeId}{$Method}{$KeyWords}} = @CompatibleInterfaces if(not defined $RandomCode); 4176 return @CompatibleInterfaces; 4177} 4178 4179sub mix_array(@) 4180{ 4181 my @Array = @_; 4182 return sort {2 * rand($#Array) - $#Array} @_; 4183} 4184 4185sub getSomeConstructor($) 4186{ 4187 my $ClassId = $_[0]; 4188 my @Constructors = get_CompatibleInterfaces($ClassId, "Construct", ""); 4189 return $Constructors[0]; 4190} 4191 4192sub getTypeParString($) 4193{ 4194 my $Interface = $_[0]; 4195 my $NumOfParams = getNumOfParams($Interface); 4196 if($NumOfParams == 0) { 4197 return ("()", "()", "()"); 4198 } 4199 else 4200 { 4201 my (@TypeParList, @ParList, @TypeList) = (); 4202 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 4203 { 4204 next if(apply_default_value($Interface, $Param_Pos) and not $CompleteSignature{$Interface}{"PureVirt"}); 4205 my $ParamName = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"name"}; 4206 $ParamName = "p".($Param_Pos + 1) if(not $ParamName); 4207 my $TypeId = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"type"}; 4208 my %Type = get_Type($TypeId); 4209 next if($Type{"Name"} eq "..."); 4210 push(@ParList, $ParamName); 4211 push(@TypeList, $Type{"Name"}); 4212 push(@TypeParList, create_member_decl($Type{"Name"}, $ParamName)); 4213 } 4214 my $TypeParString .= "(".create_list(\@TypeParList, " ").")"; 4215 my $ParString .= "(".create_list(\@ParList, " ").")"; 4216 my $TypeString .= "(".create_list(\@TypeList, " ").")"; 4217 return ($TypeParString, $ParString, $TypeString); 4218 } 4219} 4220 4221sub getValueClass($) 4222{ 4223 my $Value = $_[0]; 4224 $Value=~/([^()"]+)\(.*\)[^()]*/; 4225 my $ValueClass = $1; 4226 $ValueClass=~s/[ ]+\Z//g; 4227 if(get_TypeIdByName($ValueClass)) { 4228 return $ValueClass; 4229 } 4230 return ""; 4231} 4232 4233sub get_FoundationType($) 4234{ 4235 my $TypeId = $_[0]; 4236 return "" if(not $TypeId); 4237 if(defined $Cache{"get_FoundationType"}{$TypeId} 4238 and not defined $AuxType{$TypeId}) { 4239 return %{$Cache{"get_FoundationType"}{$TypeId}}; 4240 } 4241 return "" if(not $TypeInfo{$TypeId}); 4242 my %Type = %{$TypeInfo{$TypeId}}; 4243 return %Type if(not $Type{"BaseType"}); 4244 4245 return %Type if($Type{"Type"} eq "Array"); 4246 4247 %Type = get_FoundationType($Type{"BaseType"}); 4248 $Cache{"get_FoundationType"}{$TypeId} = \%Type; 4249 return %Type; 4250} 4251 4252sub get_BaseType($) 4253{ 4254 my $TypeId = $_[0]; 4255 return "" if(not $TypeId); 4256 if(defined $Cache{"get_BaseType"}{$TypeId} 4257 and not defined $AuxType{$TypeId}) { 4258 return %{$Cache{"get_BaseType"}{$TypeId}}; 4259 } 4260 return "" if(not $TypeInfo{$TypeId}); 4261 my %Type = %{$TypeInfo{$TypeId}}; 4262 return %Type if(not $Type{"BaseType"}); 4263 %Type = get_BaseType($Type{"BaseType"}); 4264 $Cache{"get_BaseType"}{$TypeId} = \%Type; 4265 return %Type; 4266} 4267 4268sub get_FoundationTypeId($) 4269{ 4270 my $TypeId = $_[0]; 4271 if(defined $Cache{"get_FoundationTypeId"}{$TypeId} 4272 and not defined $AuxType{$TypeId}) { 4273 return $Cache{"get_FoundationTypeId"}{$TypeId}; 4274 } 4275 my %BaseType = get_FoundationType($TypeId); 4276 return ($Cache{"get_FoundationTypeId"}{$TypeId} = $BaseType{"Tid"}); 4277} 4278 4279sub create_SubClass($) 4280{ 4281 my $ClassId = $_[0]; 4282 return () if(not $ClassId); 4283 my ($Declaration, $Headers, $Code); 4284 foreach my $Constructor (keys(%{$UsedConstructors{$ClassId}})) 4285 { 4286 if(isNotInCharge($Constructor) 4287 and my $InChargeConstructor = replace_c2c1($Constructor)) 4288 { 4289 if($CompleteSignature{$InChargeConstructor}) 4290 { 4291 $UsedConstructors{$ClassId}{$Constructor} = 0; 4292 $UsedConstructors{$ClassId}{$InChargeConstructor} = 1; 4293 } 4294 } 4295 } 4296 $Headers = addHeaders(getTypeHeaders($ClassId), $Headers); 4297 my $ClassName = ($Class_SubClassTypedef{$ClassId})?get_TypeName($Class_SubClassTypedef{$ClassId}):get_TypeName($ClassId); 4298 my $ClassNameChild = getSubClassName($ClassName); 4299 $Declaration .= "class $ClassNameChild".": public $ClassName\n{\n"; 4300 $Declaration .= "public:\n"; 4301 if(not keys(%{$UsedConstructors{$ClassId}})) 4302 { 4303 if(my $SomeConstructor = getSomeConstructor($ClassId)) { 4304 $UsedConstructors{$ClassId}{$SomeConstructor} = 1; 4305 } 4306 } 4307 if(defined $UsedConstructors{$ClassId} 4308 and keys(%{$UsedConstructors{$ClassId}})) 4309 { 4310 foreach my $Constructor (sort keys(%{$UsedConstructors{$ClassId}})) 4311 { 4312 next if(not $Constructor); 4313 my $PreviousBlock = $CurrentBlock; 4314 $CurrentBlock = $Constructor; 4315 if($UsedConstructors{$ClassId}{$Constructor}) 4316 { 4317 my ($TypeParString, $ParString, $TypeString) = getTypeParString($Constructor); 4318 $TypeParString = alignCode($TypeParString, " ", 1); 4319 $ParString = alignCode($ParString, " ", 1); 4320 $Declaration .= " $ClassNameChild"."$TypeParString\:$ClassName"."$ParString\{\}\n\n"; 4321 foreach my $Param_Pos (sort {int($b)<=>int($a)} keys(%{$CompleteSignature{$Constructor}{"Param"}})) 4322 { 4323 my $Param_TypeId = $CompleteSignature{$Constructor}{"Param"}{$Param_Pos}{"type"}; 4324 my $Param_Name = $CompleteSignature{$Constructor}{"Param"}{$Param_Pos}{"name"}; 4325 $Param_Name = "p".($Param_Pos + 1) if(not $Param_Name); 4326 $ValueCollection{$CurrentBlock}{$Param_Name} = $Param_TypeId; 4327 $Block_Param{$CurrentBlock}{$Param_Name} = $Param_TypeId; 4328 $Block_Variable{$CurrentBlock}{$Param_Name} = 1; 4329 } 4330 } 4331 $CurrentBlock = $PreviousBlock; 4332 } 4333 } 4334 else { 4335 $Declaration .= " ".$ClassNameChild."();\n"; 4336 } 4337 if(defined $Class_PureVirtFunc{$ClassName}) 4338 { 4339 my %RedefinedTwice = (); 4340 my @PureVirtuals = keys(%{$Class_PureVirtFunc{$ClassName}}); 4341 @PureVirtuals = sort {lc($CompleteSignature{$a}{"ShortName"}) cmp lc($CompleteSignature{$b}{"ShortName"})} @PureVirtuals; 4342 @PureVirtuals = sort {defined $Class_PureMethod{$ClassId}{$b} cmp defined $Class_PureMethod{$ClassId}{$a}} @PureVirtuals; 4343 foreach my $PureVirtualMethod (@PureVirtuals) 4344 { 4345 my $PreviousBlock = $CurrentBlock; 4346 $CurrentBlock = $PureVirtualMethod; 4347 delete($ValueCollection{$CurrentBlock}); 4348 delete($Block_Variable{$CurrentBlock}); 4349 my $ReturnTypeId = $CompleteSignature{$PureVirtualMethod}{"Return"}; 4350 my $ReturnTypeName = get_TypeName($ReturnTypeId); 4351 my ($TypeParString, $ParString, $TypeString) = getTypeParString($PureVirtualMethod); 4352 $TypeParString = alignCode($TypeParString, " ", 1); 4353 my ($PureVirtualMethodName, $ShortName) = ("", ""); 4354 if($CompleteSignature{$PureVirtualMethod}{"Constructor"}) 4355 { 4356 $ShortName = $ClassNameChild; 4357 $PureVirtualMethodName = " ".$ShortName.$TypeParString; 4358 } 4359 if($CompleteSignature{$PureVirtualMethod}{"Destructor"}) 4360 { 4361 $ShortName = "~".$ClassNameChild; 4362 $PureVirtualMethodName = " ".$ShortName.$TypeParString; 4363 } 4364 else 4365 { 4366 $ShortName = $CompleteSignature{$PureVirtualMethod}{"ShortName"}; 4367 $PureVirtualMethodName = " ".$ReturnTypeName." ".$ShortName.$TypeParString; 4368 } 4369 if($CompleteSignature{$PureVirtualMethod}{"Throw"}) { 4370 $PureVirtualMethodName .= " throw()"; 4371 } 4372 my $Const = ($PureVirtualMethod=~/\A_ZNK/)?" const":""; 4373 if($RedefinedTwice{$ShortName.$TypeString.$Const}) 4374 { # skip pure methods from the base with the same signature 4375 next; 4376 } 4377 $RedefinedTwice{$ShortName.$TypeString.$Const} = 1; 4378 $Declaration .= "\n" if($PureVirtualMethodName=~/\n/); 4379 foreach my $Param_Pos (sort {int($b)<=>int($a)} keys(%{$CompleteSignature{$PureVirtualMethod}{"Param"}})) 4380 { 4381 my $Param_TypeId = $CompleteSignature{$PureVirtualMethod}{"Param"}{$Param_Pos}{"type"}; 4382 my $Param_Name = $CompleteSignature{$PureVirtualMethod}{"Param"}{$Param_Pos}{"name"}; 4383 $Param_Name = "p".($Param_Pos + 1) if(not $Param_Name); 4384 $ValueCollection{$CurrentBlock}{$Param_Name} = $Param_TypeId; 4385 $Block_Param{$CurrentBlock}{$Param_Name} = $Param_TypeId; 4386 $Block_Variable{$CurrentBlock}{$Param_Name} = 1; 4387 } 4388 if(get_TypeName($ReturnTypeId) eq "void" 4389 or $CompleteSignature{$PureVirtualMethod}{"Constructor"} 4390 or $CompleteSignature{$PureVirtualMethod}{"Destructor"}) { 4391 $Declaration .= $PureVirtualMethodName.$Const."\{\}\n\n"; 4392 } 4393 elsif(get_TypeName($ReturnTypeId) eq get_TypeName($ClassId)."*") 4394 { # clone, copy, etc. 4395 $Declaration .= $PureVirtualMethodName.$Const."\{\n return (".get_TypeName($ReturnTypeId).")this;\n \}\n\n"; 4396 } 4397 else 4398 { 4399 $Declaration .= $PureVirtualMethodName.$Const." {\n"; 4400 my $ReturnTypeHeaders = getTypeHeaders($ReturnTypeId); 4401 push(@RecurInterface, $PureVirtualMethod); 4402 my %Param_Init = initializeParameter(( 4403 "ParamName" => "retval", 4404 "AccessToParam" => {"obj"=>"no object"}, 4405 "TypeId" => $ReturnTypeId, 4406 "Key" => "_ret", 4407 "InLine" => 1, 4408 "Value" => "no value", 4409 "CreateChild" => 0, 4410 "SpecType" => 0, 4411 "Usage" => "Common", 4412 "RetVal" => 1)); 4413 pop(@RecurInterface); 4414 $Code .= $Param_Init{"Code"}; 4415 $Headers = addHeaders($Param_Init{"Headers"}, $Headers); 4416 $Headers = addHeaders($ReturnTypeHeaders, $Headers); 4417 $Param_Init{"Init"} = alignCode($Param_Init{"Init"}, " ", 0); 4418 $Param_Init{"Call"} = alignCode($Param_Init{"Call"}, " ", 1); 4419 $Declaration .= $Param_Init{"Init"}." return ".$Param_Init{"Call"}.";\n }\n\n"; 4420 } 4421 $CurrentBlock = $PreviousBlock; 4422 } 4423 } 4424 if(defined $UsedProtectedMethods{$ClassId}) 4425 { 4426 foreach my $ProtectedMethod (sort {lc($CompleteSignature{$a}{"ShortName"}) cmp lc($CompleteSignature{$b}{"ShortName"})} keys(%{$UsedProtectedMethods{$ClassId}})) 4427 { 4428 my $ReturnType_Id = $CompleteSignature{$ProtectedMethod}{"Return"}; 4429 my $ReturnType_Name = get_TypeName($ReturnType_Id); 4430 my $ReturnType_PointerLevel = get_PointerLevel($ReturnType_Id); 4431 my $ReturnFType_Id = get_FoundationTypeId($ReturnType_Id); 4432 my $ReturnFType_Name = get_TypeName($ReturnFType_Id); 4433 my $Break = ((length($ReturnType_Name)>20)?"\n":" "); 4434 my $ShortName = $CompleteSignature{$ProtectedMethod}{"ShortName"}; 4435 my $ShortNameAdv = $ShortName."_Wrapper"; 4436 $ShortNameAdv = cleanName($ShortNameAdv); 4437 $Declaration .= " ".$ReturnType_Name." ".$ShortNameAdv."() {\n"; 4438 if($Wrappers{$ProtectedMethod}{"Init"}) { 4439 $Declaration .= alignCode($Wrappers{$ProtectedMethod}{"Init"}, " ", 0); 4440 } 4441 $Declaration .= alignCode($Wrappers{$ProtectedMethod}{"PreCondition"}, " ", 0); 4442 my $FuncCall = "this->".alignCode($ShortName.$Wrappers{$ProtectedMethod}{"Parameters_Call"}, " ", 1); 4443 if($Wrappers{$ProtectedMethod}{"PostCondition"} or $Wrappers{$ProtectedMethod}{"FinalCode"}) 4444 { 4445 my $PostCode = alignCode($Wrappers{$ProtectedMethod}{"PostCondition"}, " ", 0).alignCode($Wrappers{$ProtectedMethod}{"FinalCode"}, " ", 0); 4446 # FIXME: destructors 4447 if($ReturnFType_Name eq "void" and $ReturnType_PointerLevel==0) { 4448 $Declaration .= " $FuncCall;\n".$PostCode; 4449 } 4450 else 4451 { 4452 my $RetVal = select_var_name("retval", ""); 4453 my ($InitializedEType_Id, $Ret_Declarations, $Ret_Headers) = get_ExtTypeId($RetVal, $ReturnType_Id); 4454 $Code .= $Ret_Declarations; 4455 $Headers = addHeaders($Ret_Headers, $Headers); 4456 my $InitializedType_Name = get_TypeName($InitializedEType_Id); 4457 if($InitializedType_Name eq $ReturnType_Name) { 4458 $Declaration .= " ".$InitializedType_Name.$Break.$RetVal." = $FuncCall;\n".$PostCode; 4459 } 4460 else { 4461 $Declaration .= " ".$InitializedType_Name.$Break.$RetVal." = ($InitializedType_Name)$FuncCall;\n".$PostCode; 4462 } 4463 $Block_Variable{$ProtectedMethod}{$RetVal} = 1; 4464 $Declaration .= " return $RetVal;\n"; 4465 } 4466 } 4467 else 4468 { 4469 if($ReturnFType_Name eq "void" and $ReturnType_PointerLevel==0) { 4470 $Declaration .= " $FuncCall;\n"; 4471 } 4472 else { 4473 $Declaration .= " return $FuncCall;\n"; 4474 } 4475 } 4476 $Code .= $Wrappers{$ProtectedMethod}{"Code"}; 4477 $Declaration .= " }\n\n"; 4478 foreach my $ClassId (keys(%{$Wrappers_SubClasses{$ProtectedMethod}})) { 4479 $Create_SubClass{$ClassId} = 1; 4480 } 4481 } 4482 } 4483 $Declaration .= "};//$ClassNameChild\n\n"; 4484 return ($Code.$Declaration, $Headers); 4485} 4486 4487sub create_SubClasses(@) 4488{ 4489 my ($Code, $Headers) = ("", []); 4490 foreach my $ClassId (sort @_) 4491 { 4492 my (%Before, %After, %New) = (); 4493 next if(not $ClassId or $SubClass_Created{$ClassId}); 4494 %Create_SubClass = (); 4495 push(@RecurTypeId, $ClassId); 4496 my ($Code_SubClass, $Headers_SubClass) = create_SubClass($ClassId); 4497 $SubClass_Created{$ClassId} = 1; 4498 if(keys(%Create_SubClass)) 4499 { 4500 my ($Code_Depend, $Headers_Depend) = create_SubClasses(keys(%Create_SubClass)); 4501 $Code_SubClass = $Code_Depend.$Code_SubClass; 4502 $Headers_SubClass = addHeaders($Headers_Depend, $Headers_SubClass); 4503 } 4504 pop(@RecurTypeId); 4505 $Code .= $Code_SubClass; 4506 $Headers = addHeaders($Headers_SubClass, $Headers); 4507 } 4508 return ($Code, $Headers); 4509} 4510 4511sub save_state() 4512{ 4513 my %Saved_State = (); 4514 foreach (keys(%IntSubClass)) 4515 { 4516 @{$Saved_State{"IntSubClass"}{$_}}{keys(%{$IntSubClass{$_}})} = values %{$IntSubClass{$_}}; 4517 } 4518 foreach (keys(%Wrappers)) 4519 { 4520 @{$Saved_State{"Wrappers"}{$_}}{keys(%{$Wrappers{$_}})} = values %{$Wrappers{$_}}; 4521 } 4522 foreach (keys(%Wrappers_SubClasses)) 4523 { 4524 @{$Saved_State{"Wrappers_SubClasses"}{$_}}{keys(%{$Wrappers_SubClasses{$_}})} = values %{$Wrappers_SubClasses{$_}}; 4525 } 4526 foreach (keys(%ValueCollection)) 4527 { 4528 @{$Saved_State{"ValueCollection"}{$_}}{keys(%{$ValueCollection{$_}})} = values %{$ValueCollection{$_}}; 4529 } 4530 foreach (keys(%Block_Variable)) 4531 { 4532 @{$Saved_State{"Block_Variable"}{$_}}{keys(%{$Block_Variable{$_}})} = values %{$Block_Variable{$_}}; 4533 } 4534 foreach (keys(%UseVarEveryWhere)) 4535 { 4536 @{$Saved_State{"UseVarEveryWhere"}{$_}}{keys(%{$UseVarEveryWhere{$_}})} = values %{$UseVarEveryWhere{$_}}; 4537 } 4538 foreach (keys(%OpenStreams)) 4539 { 4540 @{$Saved_State{"OpenStreams"}{$_}}{keys(%{$OpenStreams{$_}})} = values %{$OpenStreams{$_}}; 4541 } 4542 foreach (keys(%Block_Param)) 4543 { 4544 @{$Saved_State{"Block_Param"}{$_}}{keys(%{$Block_Param{$_}})} = values %{$Block_Param{$_}}; 4545 } 4546 foreach (keys(%UsedConstructors)) 4547 { 4548 @{$Saved_State{"UsedConstructors"}{$_}}{keys(%{$UsedConstructors{$_}})} = values %{$UsedConstructors{$_}}; 4549 } 4550 foreach (keys(%UsedProtectedMethods)) 4551 { 4552 @{$Saved_State{"UsedProtectedMethods"}{$_}}{keys(%{$UsedProtectedMethods{$_}})} = values %{$UsedProtectedMethods{$_}}; 4553 } 4554 foreach (keys(%IntSpecType)) 4555 { 4556 @{$Saved_State{"IntSpecType"}{$_}}{keys(%{$IntSpecType{$_}})} = values %{$IntSpecType{$_}}; 4557 } 4558 foreach (keys(%RequirementsCatalog)) 4559 { 4560 @{$Saved_State{"RequirementsCatalog"}{$_}}{keys(%{$RequirementsCatalog{$_}})} = values %{$RequirementsCatalog{$_}}; 4561 } 4562 @{$Saved_State{"Template2Code_Defines"}}{keys(%Template2Code_Defines)} = values %Template2Code_Defines; 4563 @{$Saved_State{"TraceFunc"}}{keys(%TraceFunc)} = values %TraceFunc; 4564 $Saved_State{"MaxTypeId"} = $MaxTypeId; 4565 @{$Saved_State{"IntrinsicNum"}}{keys(%IntrinsicNum)} = values %IntrinsicNum; 4566 @{$Saved_State{"AuxHeaders"}}{keys(%AuxHeaders)} = values %AuxHeaders; 4567 @{$Saved_State{"Class_SubClassTypedef"}}{keys(%Class_SubClassTypedef)} = values %Class_SubClassTypedef; 4568 @{$Saved_State{"SubClass_Instance"}}{keys(%SubClass_Instance)} = values %SubClass_Instance; 4569 @{$Saved_State{"SubClass_ObjInstance"}}{keys(%SubClass_ObjInstance)} = values %SubClass_ObjInstance; 4570 @{$Saved_State{"SpecEnv"}}{keys(%SpecEnv)} = values %SpecEnv; 4571 @{$Saved_State{"Block_InsNum"}}{keys(%Block_InsNum)} = values %Block_InsNum; 4572 @{$Saved_State{"AuxType"}}{keys %AuxType} = values %AuxType; 4573 @{$Saved_State{"AuxFunc"}}{keys %AuxFunc} = values %AuxFunc; 4574 @{$Saved_State{"Create_SubClass"}}{keys %Create_SubClass} = values %Create_SubClass; 4575 @{$Saved_State{"SpecCode"}}{keys %SpecCode} = values %SpecCode; 4576 @{$Saved_State{"SpecLibs"}}{keys %SpecLibs} = values %SpecLibs; 4577 @{$Saved_State{"UsedInterfaces"}}{keys %UsedInterfaces} = values %UsedInterfaces; 4578 @{$Saved_State{"ConstraintNum"}}{keys %ConstraintNum} = values %ConstraintNum; 4579 return \%Saved_State; 4580} 4581 4582sub restore_state($) 4583{ 4584 restore_state_I($_[0], 0); 4585} 4586 4587sub restore_local_state($) 4588{ 4589 restore_state_I($_[0], 1); 4590} 4591 4592sub restore_state_I($$) 4593{ 4594 my ($Saved_State, $Local) = @_; 4595 if(not $Local) 4596 { 4597 foreach my $AuxType_Id (keys(%AuxType)) 4598 { 4599 if(my $OldName = $TypeInfo{$AuxType_Id}{"Name_Old"}) 4600 { 4601 $TypeInfo{$AuxType_Id}{"Name"} = $OldName; 4602 } 4603 } 4604 if(not $Saved_State) 4605 { # restore aux types 4606 foreach my $AuxType_Id (sort {int($a)<=>int($b)} keys(%AuxType)) 4607 { 4608 if(not $TypeInfo{$AuxType_Id}{"Name_Old"}) 4609 { 4610 delete($TypeInfo{$AuxType_Id}); 4611 } 4612 delete($TName_Tid{$AuxType{$AuxType_Id}}); 4613 delete($AuxType{$AuxType_Id}); 4614 } 4615 $MaxTypeId = $MaxTypeId_Start; 4616 } 4617 elsif($Saved_State->{"MaxTypeId"}) 4618 { 4619 foreach my $AuxType_Id (sort {int($a)<=>int($b)} keys(%AuxType)) 4620 { 4621 if($AuxType_Id<=$MaxTypeId and $AuxType_Id>$Saved_State->{"MaxTypeId"}) 4622 { 4623 if(not $TypeInfo{$AuxType_Id}{"Name_Old"}) 4624 { 4625 delete($TypeInfo{$AuxType_Id}); 4626 } 4627 delete($TName_Tid{$AuxType{$AuxType_Id}}); 4628 delete($AuxType{$AuxType_Id}); 4629 } 4630 } 4631 } 4632 } 4633 (%Block_Variable, %UseVarEveryWhere, %OpenStreams, %SpecEnv, %Block_InsNum, 4634 %ValueCollection, %IntrinsicNum, %ConstraintNum, %SubClass_Instance, 4635 %SubClass_ObjInstance, %Block_Param,%Class_SubClassTypedef, %AuxHeaders, %Template2Code_Defines) = (); 4636 if(not $Local) 4637 { 4638 (%Wrappers, %Wrappers_SubClasses, %IntSubClass, %AuxType, %AuxFunc, 4639 %UsedConstructors, %UsedProtectedMethods, %Create_SubClass, %SpecCode, 4640 %SpecLibs, %UsedInterfaces, %IntSpecType, %RequirementsCatalog, %TraceFunc) = (); 4641 } 4642 if(not $Saved_State) 4643 { # initializing 4644 %IntrinsicNum=( 4645 "Char"=>64, 4646 "Int"=>0, 4647 "Str"=>0, 4648 "Float"=>0); 4649 return; 4650 } 4651 foreach (keys(%{$Saved_State->{"Block_Variable"}})) 4652 { 4653 @{$Block_Variable{$_}}{keys(%{$Saved_State->{"Block_Variable"}{$_}})} = values %{$Saved_State->{"Block_Variable"}{$_}}; 4654 } 4655 foreach (keys(%{$Saved_State->{"UseVarEveryWhere"}})) 4656 { 4657 @{$UseVarEveryWhere{$_}}{keys(%{$Saved_State->{"UseVarEveryWhere"}{$_}})} = values %{$Saved_State->{"UseVarEveryWhere"}{$_}}; 4658 } 4659 foreach (keys(%{$Saved_State->{"OpenStreams"}})) 4660 { 4661 @{$OpenStreams{$_}}{keys(%{$Saved_State->{"OpenStreams"}{$_}})} = values %{$Saved_State->{"OpenStreams"}{$_}}; 4662 } 4663 @SpecEnv{keys(%{$Saved_State->{"SpecEnv"}})} = values %{$Saved_State->{"SpecEnv"}}; 4664 @Block_InsNum{keys(%{$Saved_State->{"Block_InsNum"}})} = values %{$Saved_State->{"Block_InsNum"}}; 4665 foreach (keys(%{$Saved_State->{"ValueCollection"}})) 4666 { 4667 @{$ValueCollection{$_}}{keys(%{$Saved_State->{"ValueCollection"}{$_}})} = values %{$Saved_State->{"ValueCollection"}{$_}}; 4668 } 4669 @Template2Code_Defines{keys(%{$Saved_State->{"Template2Code_Defines"}})} = values %{$Saved_State->{"Template2Code_Defines"}}; 4670 @IntrinsicNum{keys(%{$Saved_State->{"IntrinsicNum"}})} = values %{$Saved_State->{"IntrinsicNum"}}; 4671 @ConstraintNum{keys(%{$Saved_State->{"ConstraintNum"}})} = values %{$Saved_State->{"ConstraintNum"}}; 4672 @SubClass_Instance{keys(%{$Saved_State->{"SubClass_Instance"}})} = values %{$Saved_State->{"SubClass_Instance"}}; 4673 @SubClass_ObjInstance{keys(%{$Saved_State->{"SubClass_ObjInstance"}})} = values %{$Saved_State->{"SubClass_ObjInstance"}}; 4674 foreach (keys(%{$Saved_State->{"Block_Param"}})) 4675 { 4676 @{$Block_Param{$_}}{keys(%{$Saved_State->{"Block_Param"}{$_}})} = values %{$Saved_State->{"Block_Param"}{$_}}; 4677 } 4678 @Class_SubClassTypedef{keys(%{$Saved_State->{"Class_SubClassTypedef"}})} = values %{$Saved_State->{"Class_SubClassTypedef"}}; 4679 @AuxHeaders{keys(%{$Saved_State->{"AuxHeaders"}})} = values %{$Saved_State->{"AuxHeaders"}}; 4680 if(not $Local) 4681 { 4682 foreach my $AuxType_Id (sort {int($a)<=>int($b)} keys(%{$Saved_State->{"AuxType"}})) 4683 { 4684 $TypeInfo{$AuxType_Id}{"Name"} = $Saved_State->{"AuxType"}{$AuxType_Id}; 4685 $TName_Tid{$Saved_State->{"AuxType"}{$AuxType_Id}} = $AuxType_Id; 4686 } 4687 foreach (keys(%{$Saved_State->{"IntSubClass"}})) 4688 { 4689 @{$IntSubClass{$_}}{keys(%{$Saved_State->{"IntSubClass"}{$_}})} = values %{$Saved_State->{"IntSubClass"}{$_}}; 4690 } 4691 foreach (keys(%{$Saved_State->{"Wrappers"}})) 4692 { 4693 @{$Wrappers{$_}}{keys(%{$Saved_State->{"Wrappers"}{$_}})} = values %{$Saved_State->{"Wrappers"}{$_}}; 4694 } 4695 foreach (keys(%{$Saved_State->{"Wrappers_SubClasses"}})) 4696 { 4697 @{$Wrappers_SubClasses{$_}}{keys(%{$Saved_State->{"Wrappers_SubClasses"}{$_}})} = values %{$Saved_State->{"Wrappers_SubClasses"}{$_}}; 4698 } 4699 foreach (keys(%{$Saved_State->{"UsedConstructors"}})) 4700 { 4701 @{$UsedConstructors{$_}}{keys(%{$Saved_State->{"UsedConstructors"}{$_}})} = values %{$Saved_State->{"UsedConstructors"}{$_}}; 4702 } 4703 foreach (keys(%{$Saved_State->{"UsedProtectedMethods"}})) 4704 { 4705 @{$UsedProtectedMethods{$_}}{keys(%{$Saved_State->{"UsedProtectedMethods"}{$_}})} = values %{$Saved_State->{"UsedProtectedMethods"}{$_}}; 4706 } 4707 foreach (keys(%{$Saved_State->{"IntSpecType"}})) 4708 { 4709 @{$IntSpecType{$_}}{keys(%{$Saved_State->{"IntSpecType"}{$_}})} = values %{$Saved_State->{"IntSpecType"}{$_}}; 4710 } 4711 foreach (keys(%{$Saved_State->{"RequirementsCatalog"}})) 4712 { 4713 @{$RequirementsCatalog{$_}}{keys(%{$Saved_State->{"RequirementsCatalog"}{$_}})} = values %{$Saved_State->{"RequirementsCatalog"}{$_}}; 4714 } 4715 $MaxTypeId = $Saved_State->{"MaxTypeId"}; 4716 @AuxType{keys(%{$Saved_State->{"AuxType"}})} = values %{$Saved_State->{"AuxType"}}; 4717 @TraceFunc{keys(%{$Saved_State->{"TraceFunc"}})} = values %{$Saved_State->{"TraceFunc"}}; 4718 @AuxFunc{keys(%{$Saved_State->{"AuxFunc"}})} = values %{$Saved_State->{"AuxFunc"}}; 4719 @Create_SubClass{keys(%{$Saved_State->{"Create_SubClass"}})} = values %{$Saved_State->{"Create_SubClass"}}; 4720 @SpecCode{keys(%{$Saved_State->{"SpecCode"}})} = values %{$Saved_State->{"SpecCode"}}; 4721 @SpecLibs{keys(%{$Saved_State->{"SpecLibs"}})} = values %{$Saved_State->{"SpecLibs"}}; 4722 @UsedInterfaces{keys(%{$Saved_State->{"UsedInterfaces"}})} = values %{$Saved_State->{"UsedInterfaces"}}; 4723 @IntSpecType{keys(%{$Saved_State->{"IntSpecType"}})} = values %{$Saved_State->{"IntSpecType"}}; 4724 } 4725} 4726 4727sub isAbstractClass($) 4728{ 4729 my $ClassId = $_[0]; 4730 return (keys(%{$Class_PureVirtFunc{get_TypeName($ClassId)}}) > 0); 4731} 4732 4733sub needToInherit($) 4734{ 4735 my $Interface = $_[0]; 4736 return ($CompleteSignature{$Interface}{"Class"} and (isAbstractClass($CompleteSignature{$Interface}{"Class"}) or isNotInCharge($Interface) or ($CompleteSignature{$Interface}{"Protected"}))); 4737} 4738 4739sub parseCode($$) 4740{ 4741 my ($Code, $Mode) = @_; 4742 my $Global_State = save_state(); 4743 my %ParsedCode = parseCode_m($Code, $Mode); 4744 if(not $ParsedCode{"IsCorrect"}) 4745 { 4746 restore_state($Global_State); 4747 return (); 4748 } 4749 else { 4750 return %ParsedCode; 4751 } 4752} 4753 4754sub get_TypeIdByName($) 4755{ 4756 my $TypeName = $_[0]; 4757 if(my $ExactId = $TName_Tid{formatName($TypeName, "T")}) { 4758 return $ExactId; 4759 } 4760 else { 4761 return $TName_Tid{remove_quals(formatName($TypeName, "T"))}; 4762 } 4763} 4764 4765sub callInterfaceParameters(@) 4766{ 4767 my %Init_Desc = @_; 4768 my $Interface = $Init_Desc{"Interface"}; 4769 return () if(not $Interface); 4770 return () if($SkipInterfaces{$Interface}); 4771 foreach my $SkipPattern (keys(%SkipInterfaces_Pattern)) { 4772 return () if($Interface=~/$SkipPattern/); 4773 } 4774 if(defined $MakeIsolated and $Symbol_Library{$Interface} 4775 and keys(%InterfacesList) and not $InterfacesList{$Interface}) { 4776 return (); 4777 } 4778 my $Global_State = save_state(); 4779 return () if(isCyclical(\@RecurInterface, $Interface)); 4780 push(@RecurInterface, $Interface); 4781 my $PreviousBlock = $CurrentBlock; 4782 if($CompleteSignature{$Interface}{"Protected"} 4783 and not $CompleteSignature{$Interface}{"Constructor"}) { 4784 $CurrentBlock = $Interface; 4785 } 4786 $NodeInterface = $Interface; 4787 $UsedInterfaces{$NodeInterface} = 1; 4788 my %Params_Init = callInterfaceParameters_m(%Init_Desc); 4789 $CurrentBlock = $PreviousBlock; 4790 if(not $Params_Init{"IsCorrect"}) 4791 { 4792 pop(@RecurInterface); 4793 restore_state($Global_State); 4794 if($Debug) { 4795 $DebugInfo{"Init_InterfaceParams"}{$Interface} = 1; 4796 } 4797 return (); 4798 } 4799 pop(@RecurInterface); 4800 if($InterfaceSpecType{$Interface}{"SpecEnv"}) { 4801 $SpecEnv{$InterfaceSpecType{$Interface}{"SpecEnv"}} = 1; 4802 } 4803 $Params_Init{"ReturnTypeId"} = $CompleteSignature{$Interface}{"Return"}; 4804 return %Params_Init; 4805} 4806 4807sub detectInLineParams($) 4808{ 4809 my $Interface = $_[0]; 4810 my ($SpecAttributes, %Param_SpecAttributes, %InLineParam) = (); 4811 foreach my $Param_Pos (keys(%{$InterfaceSpecType{$Interface}{"SpecParam"}})) 4812 { 4813 my $SpecType_Id = $InterfaceSpecType{$Interface}{"SpecParam"}{$Param_Pos}; 4814 my %SpecType = %{$SpecType{$SpecType_Id}}; 4815 $Param_SpecAttributes{$Param_Pos} = $SpecType{"Value"}.$SpecType{"PreCondition"}.$SpecType{"PostCondition"}.$SpecType{"InitCode"}.$SpecType{"DeclCode"}.$SpecType{"FinalCode"}; 4816 $SpecAttributes .= $Param_SpecAttributes{$Param_Pos}; 4817 } 4818 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 4819 { 4820 my $Param_Num = $Param_Pos + 1; 4821 if($SpecAttributes=~/\$$Param_Num(\W|\Z)/ 4822 or $Param_SpecAttributes{$Param_Pos}=~/\$0(\W|\Z)/) { 4823 $InLineParam{$Param_Num} = 0; 4824 } 4825 else { 4826 $InLineParam{$Param_Num} = 1; 4827 } 4828 } 4829 return %InLineParam; 4830} 4831 4832sub detectParamsOrder($) 4833{ 4834 my $Interface = $_[0]; 4835 my ($SpecAttributes, %OrderParam) = (); 4836 foreach my $Param_Pos (keys(%{$InterfaceSpecType{$Interface}{"SpecParam"}})) 4837 { # detect all dependencies 4838 my $SpecType_Id = $InterfaceSpecType{$Interface}{"SpecParam"}{$Param_Pos}; 4839 my %SpecType = %{$SpecType{$SpecType_Id}}; 4840 $SpecAttributes .= $SpecType{"Value"}.$SpecType{"PreCondition"}.$SpecType{"PostCondition"}.$SpecType{"InitCode"}.$SpecType{"DeclCode"}.$SpecType{"FinalCode"}; 4841 } 4842 my $Orded = 1; 4843 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 4844 { 4845 my $Param_Num = $Param_Pos + 1; 4846 if($SpecAttributes=~/\$$Param_Num(\W|\Z)/) 4847 { 4848 $OrderParam{$Param_Num} = $Orded; 4849 $Orded += 1; 4850 } 4851 } 4852 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 4853 { 4854 my $Param_Num = $Param_Pos + 1; 4855 if(not defined $OrderParam{$Param_Pos+1}) 4856 { 4857 $OrderParam{$Param_Num} = $Orded; 4858 $Orded += 1; 4859 } 4860 } 4861 return %OrderParam; 4862} 4863 4864sub chooseSpecType($$$) 4865{ 4866 my ($TypeId, $Kind, $Interface) = @_; 4867 if(my $SpecTypeId_Strong = chooseSpecType_Strong($TypeId, $Kind, $Interface, 1)) { 4868 return $SpecTypeId_Strong; 4869 } 4870 elsif(get_TypeType(get_FoundationTypeId($TypeId))!~/\A(Intrinsic)\Z/) { 4871 return chooseSpecType_Strong($TypeId, $Kind, $Interface, 0); 4872 } 4873 else { 4874 return ""; 4875 } 4876} 4877 4878sub chooseSpecType_Strong($$$$) 4879{ 4880 my ($TypeId, $Kind, $Interface, $Strong) = @_; 4881 return 0 if(not $TypeId or not $Kind); 4882 foreach my $SpecType_Id (sort {int($a)<=>int($b)} keys(%SpecType)) 4883 { 4884 next if($Interface and $Common_SpecType_Exceptions{$Interface}{$SpecType_Id}); 4885 if($SpecType{$SpecType_Id}{"Kind"} eq $Kind) 4886 { 4887 if($Strong) 4888 { 4889 if($TypeId==get_TypeIdByName($SpecType{$SpecType_Id}{"DataType"})) { 4890 return $SpecType_Id; 4891 } 4892 } 4893 else 4894 { 4895 my $FoundationTypeId = get_FoundationTypeId($TypeId); 4896 my $SpecType_FTypeId = get_FoundationTypeId(get_TypeIdByName($SpecType{$SpecType_Id}{"DataType"})); 4897 if($FoundationTypeId==$SpecType_FTypeId) { 4898 return $SpecType_Id; 4899 } 4900 } 4901 } 4902 } 4903 return 0; 4904} 4905 4906sub getAutoConstraint($) 4907{ 4908 my $ReturnType_Id = $_[0]; 4909 if(get_PointerLevel($ReturnType_Id) > 0) { 4910 return ("\$0 != ".get_null(), $ReturnType_Id); 4911 } 4912 else { 4913 return (); 4914 } 4915} 4916 4917sub requirementReturn($$$$) 4918{ 4919 my ($Interface, $Ireturn, $Ispecreturn, $CallObj) = @_; 4920 return "" if(defined $Template2Code and $Interface ne $TestedInterface); 4921 return "" if(not $Ireturn or not $Interface); 4922 my ($PostCondition, $TargetTypeId, $Requirement_Code) = (); 4923 if($Ispecreturn) { 4924 ($PostCondition, $TargetTypeId) = ($SpecType{$Ispecreturn}{"PostCondition"}, get_TypeIdByName($SpecType{$Ispecreturn}{"DataType"})); 4925 } 4926 elsif(defined $CheckReturn) { 4927 ($PostCondition, $TargetTypeId) = getAutoConstraint($Ireturn); 4928 } 4929 return "" if(not $PostCondition or not $TargetTypeId); 4930 my $PointerLevelReturn = get_PointerLevel($Ireturn); 4931 my ($TargetCallReturn, $TmpPreamble) = 4932 convertTypes(( 4933 "InputTypeName"=>get_TypeName($Ireturn), 4934 "InputPointerLevel"=>$PointerLevelReturn, 4935 "OutputTypeId"=>$TargetTypeId, 4936 "Value"=>"\$0", 4937 "Key"=>"\$0", 4938 "Destination"=>"Target", 4939 "MustConvert"=>0)); 4940 if($TmpPreamble) { 4941 $Requirement_Code .= $TmpPreamble."\n"; 4942 } 4943 if($TargetCallReturn=~/\A\*/ 4944 or $TargetCallReturn=~/\A\&/) { 4945 $TargetCallReturn = "(".$TargetCallReturn.")"; 4946 } 4947 if($CallObj=~/\A\*/ 4948 or $CallObj=~/\A\&/) { 4949 $CallObj = "(".$CallObj.")"; 4950 } 4951 $PostCondition=~s/\$0/$TargetCallReturn/g; 4952 if($CallObj ne "no object") { 4953 $PostCondition=~s/\$obj/$CallObj/g; 4954 } 4955 $PostCondition = clearSyntax($PostCondition); 4956 my $NormalResult = $PostCondition; 4957 while($PostCondition=~s/([^\\])"/$1\\\"/g){} 4958 $ConstraintNum{$Interface}+=1; 4959 $RequirementsCatalog{$Interface}{$ConstraintNum{$Interface}} = "constraint for the return value: \'$PostCondition\'"; 4960 my $ReqId = get_ShortName($Interface).".".normalize_num($ConstraintNum{$Interface}); 4961 if(my $Format = is_printable(get_TypeName($TargetTypeId))) 4962 { 4963 my $Comment = "constraint for the return value failed: \'$PostCondition\', returned value: $Format"; 4964 $Requirement_Code .= "REQva(\"$ReqId\",\n$NormalResult,\n\"$Comment\",\n$TargetCallReturn);\n"; 4965 $TraceFunc{"REQva"}=1; 4966 } 4967 else 4968 { 4969 my $Comment = "constraint for the return value failed: \'$PostCondition\'"; 4970 $Requirement_Code .= "REQ(\"$ReqId\",\n\"$Comment\",\n$NormalResult);\n"; 4971 $TraceFunc{"REQ"}=1; 4972 } 4973 return $Requirement_Code; 4974} 4975 4976sub is_printable($) 4977{ 4978 my $TypeName = remove_quals(uncover_typedefs($_[0])); 4979 if(isIntegerType($TypeName)) { 4980 return "\%d"; 4981 } 4982 elsif($TypeName=~/\A(char|unsigned char|wchar_t|void|short|unsigned short) const\*\Z/) { 4983 return "\%s"; 4984 } 4985 elsif(isCharType($TypeName)) { 4986 return "\%c"; 4987 } 4988 elsif($TypeName=~/\A(float|double|long double)\Z/) { 4989 return "\%f"; 4990 } 4991 else { 4992 return ""; 4993 } 4994} 4995 4996sub get_ShortName($) 4997{ 4998 my $Symbol = $_[0]; 4999 my $Short = $CompleteSignature{$Symbol}{"ShortName"}; 5000 if(my $Class = $CompleteSignature{$Symbol}{"Class"}) { 5001 $Short = get_TypeName($Class)."::".$Short; 5002 } 5003 return $Short; 5004} 5005 5006sub normalize_num($) 5007{ 5008 my $Num = $_[0]; 5009 if(int($Num)<10) { 5010 return "0".$Num; 5011 } 5012 else { 5013 return $Num; 5014 } 5015} 5016 5017sub get_PointerLevel($) 5018{ 5019 my $TypeId = $_[0]; 5020 return "" if(not $TypeId); 5021 if(defined $Cache{"get_PointerLevel"}{$TypeId} 5022 and not defined $AuxType{$TypeId}) { 5023 return $Cache{"get_PointerLevel"}{$TypeId}; 5024 } 5025 return "" if(not $TypeInfo{$TypeId}); 5026 my %Type = %{$TypeInfo{$TypeId}}; 5027 return 0 if(not $Type{"BaseType"}); 5028 return 0 if($Type{"Type"} eq "Array"); 5029 my $PointerLevel = 0; 5030 if($Type{"Type"} eq "Pointer") { 5031 $PointerLevel += 1; 5032 } 5033 $PointerLevel += get_PointerLevel($Type{"BaseType"}); 5034 $Cache{"get_PointerLevel"}{$TypeId} = $PointerLevel; 5035 return $PointerLevel; 5036} 5037 5038sub select_ValueFromCollection(@) 5039{ 5040 my %Init_Desc = @_; 5041 my ($TypeId, $Name, $Interface, $CreateChild, $IsObj) = ($Init_Desc{"TypeId"}, $Init_Desc{"ParamName"}, $Init_Desc{"Interface"}, $Init_Desc{"CreateChild"}, $Init_Desc{"ObjectInit"}); 5042 return () if($Init_Desc{"DoNotReuse"}); 5043 my $TypeName = get_TypeName($TypeId); 5044 my $FTypeId = get_FoundationTypeId($TypeId); 5045 my $FTypeName = get_TypeName($FTypeId); 5046 my $PointerLevel = get_PointerLevel($TypeId); 5047 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 5048 return () if(isString($TypeId, $Name, $Interface)); 5049 return () if(uncover_typedefs($TypeName)=~/\A(char|unsigned char|wchar_t|void\*)\Z/); 5050 return () if(isCyclical(\@RecurTypeId, get_TypeStackId($TypeId))); 5051 if($CurrentBlock and keys(%{$ValueCollection{$CurrentBlock}})) 5052 { 5053 my (@Name_Type_Coinsidence, @Name_FType_Coinsidence, @Type_Coinsidence, @FType_Coinsidence) = (); 5054 foreach my $Value (sort {$b=~/$Name/i<=>$a=~/$Name/i} sort keys(%{$ValueCollection{$CurrentBlock}})) 5055 { 5056 return () if($Name=~/dest|source/i and $Value=~/source|dest/i and $ShortName=~/copy|move|backup/i); 5057 my $Value_TypeId = $ValueCollection{$CurrentBlock}{$Value}; 5058 my $PointerLevel_Value = get_PointerLevel($Value_TypeId); 5059 if($Value!~/\A(argc|argv)\Z/) 5060 { 5061 if(get_TypeName($Value_TypeId)=~/(string|date|time|file)/i and $Name!~/\Ap\d+\Z/) 5062 { # date, time arguments 5063 unless($Name=~/_elem\Z/ and $PointerLevel_Value==0) 5064 { # array elements may be reused 5065 next; 5066 } 5067 } 5068 next if($CreateChild and not $SubClass_Instance{$Value}); 5069 # next if(not $IsObj and $SubClass_Instance{$Value}); 5070 next if(($Interface eq $TestedInterface) and ($Name ne $Value) 5071 and not $UseVarEveryWhere{$CurrentBlock}{$Value}); # and $Name!~/\Ap\d+\Z/ 5072 } 5073 if($TypeName eq get_TypeName($Value_TypeId)) 5074 { 5075 if($Value=~/\A(argc|argv)\Z/) { 5076 next if($PointerLevel > $PointerLevel_Value); 5077 } 5078 else 5079 { 5080 if(isNumericType($TypeName) 5081 and $Name!~/\Q$Value\E/i and $TypeName!~/[A-Z]|_t/) 5082 { # do not reuse intrinsic values 5083 next; 5084 } 5085 } 5086 if($Name=~/\A[_]*$Value(|[_]*[a-zA-Z0-9]|[_]*ptr)\Z/i) { 5087 push(@Name_Type_Coinsidence, $Value); 5088 } 5089 else 5090 { 5091 next if($Value=~/\A(argc|argv)\Z/ and $CurrentBlock eq "main"); 5092 push(@Type_Coinsidence, $Value); 5093 } 5094 } 5095 else 5096 { 5097 if($Value=~/\A(argc|argv)\Z/) { 5098 next if($PointerLevel > $PointerLevel_Value); 5099 } 5100 else 5101 { 5102 if(isNumericType($FTypeName) and $Name!~/\Q$Value\E/i) 5103 { # do not reuse intrinsic values 5104 next; 5105 } 5106 if($PointerLevel-$PointerLevel_Value!=1) 5107 { 5108 if($PointerLevel > $PointerLevel_Value) { 5109 next; 5110 } 5111 elsif($PointerLevel ne $PointerLevel_Value) 5112 { 5113 if(get_TypeType($FTypeId)=~/\A(Intrinsic|Array|Enum)\Z/ 5114 or isArray($Value_TypeId, $Value, $Interface)) { 5115 next; 5116 } 5117 } 5118 } 5119 if($PointerLevel<$PointerLevel_Value 5120 and $Init_Desc{"OuterType_Type"} eq "Array") { 5121 next; 5122 } 5123 } 5124 my $Value_FTypeId = get_FoundationTypeId($Value_TypeId); 5125 if($FTypeName eq get_TypeName($Value_FTypeId)) 5126 { 5127 if($Name=~/\A[_]*\Q$Value\E(|[_]*[a-z0-9]|[_]*ptr)\Z/i) { 5128 push(@Name_FType_Coinsidence, $Value); 5129 } 5130 else 5131 { 5132 next if($Value=~/\A(argc|argv)\Z/ and $CurrentBlock eq "main"); 5133 push(@FType_Coinsidence, $Value); 5134 } 5135 } 5136 } 5137 } 5138 my @All_Coinsidence = (@Name_Type_Coinsidence, @Name_FType_Coinsidence, @Type_Coinsidence, @FType_Coinsidence); 5139 if($#All_Coinsidence>-1) { 5140 return ($All_Coinsidence[0], $ValueCollection{$CurrentBlock}{$All_Coinsidence[0]}); 5141 } 5142 } 5143 return (); 5144} 5145 5146sub get_interface_param_pos($$) 5147{ 5148 my ($Interface, $Name) = @_; 5149 foreach my $Pos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 5150 { 5151 if($CompleteSignature{$Interface}{"Param"}{$Pos}{"name"} eq $Name) 5152 { 5153 return $Pos; 5154 } 5155 } 5156 return ""; 5157} 5158 5159sub hasLength($$) 5160{ 5161 my ($ParamName, $Interface) = @_; 5162 my $ParamPos = get_interface_param_pos($Interface, $ParamName); 5163 if(defined $CompleteSignature{$Interface}{"Param"}{$ParamPos+1}) 5164 { 5165 return (isIntegerType(get_TypeName($CompleteSignature{$Interface}{"Param"}{$ParamPos+1}{"type"})) 5166 and is_array_count($ParamName, $CompleteSignature{$Interface}{"Param"}{$ParamPos+1}{"name"})); 5167 } 5168 return 0; 5169} 5170 5171sub isArrayName($) 5172{ 5173 my $Name = $_[0]; 5174 if($Name=~/([a-z][a-rt-z]s\Z|matrix|list|set|range|array)/i) { 5175 return 1; 5176 } 5177 return 0; 5178} 5179 5180sub isArray($$$) 5181{ # detect parameter semantic 5182 my ($TypeId, $ParamName, $Interface) = @_; 5183 return 0 if(not $TypeId or not $ParamName); 5184 my $I_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 5185 my $FTypeId = get_FoundationTypeId($TypeId); 5186 my $FTypeType = get_TypeType($FTypeId); 5187 my $FTypeName = get_TypeName($FTypeId); 5188 my $TypeName = get_TypeName($TypeId); 5189 my $PLevel = get_PointerLevel($TypeId); 5190 my $ParamPos = get_interface_param_pos($Interface, $ParamName); 5191 5192 return 1 if(get_TypeType($TypeId) eq "Array"); 5193 5194 # strong reject 5195 return 0 if($PLevel <= 0); 5196 return 0 if(isString($TypeId, $ParamName, $Interface)); 5197 return 0 if($PLevel==1 and (isOpaque($FTypeId) or $FTypeName eq "void")); 5198 return 0 if($ParamName=~/ptr|pointer/i and $FTypeType=~/\A(Struct|Union|Class)\Z/); 5199 return 0 if($Interface_OutParam{$Interface}{$ParamName}); 5200 5201 # particular reject 5202 # FILE *fopen(const char *path, const char *__modes) 5203 return 0 if(is_const_type($TypeName) and isCharType($FTypeName) 5204 and $PLevel==1 and $ParamName=~/mode/i); 5205 5206 # returned by function 5207 return 0 if(($FTypeType=~/\A(Struct|Union|Class)\Z/ 5208 or ($TypeName ne uncover_typedefs($TypeName) and $TypeName!~/size_t|int/)) 5209 and check_type_returned($TypeId, isArrayName($TypeName))); 5210 5211 # array followed by the number 5212 return 1 if(not is_const_type($TypeName) and hasLength($ParamName, $Interface)); 5213 5214 return 0 if($PLevel>=2 and isCharType($FTypeName) 5215 and not is_const_type($TypeName)); 5216 5217 # allowed configurations 5218 # array of arguments 5219 return 1 if($ParamName=~/argv/i); 5220 # array, list, matrix 5221 if($ParamName!~/out|context|name/i and isArrayName($ParamName) 5222 and (getParamNameByTypeName($TypeName) ne $ParamName or $TypeName!~/\*/) 5223 and $TypeName!~/$ParamName/i) 5224 { # foo(struct type* list) 5225 #! curl_slist_free_all ( struct curl_slist* p1 ) 5226 return 1; 5227 } 5228 # array of function pointers 5229 return 1 if($PLevel==1 and $FTypeType=~/\A(FuncPtr|Array)\Z/); 5230 # QString::vsprintf ( char const* format, va_list ap ) 5231 return 1 if($ParamName!~/out|context/i and isArrayName($TypeName) and $TypeName!~/$ParamName/i); 5232 # high pointer level 5233 # xmlSchemaSAXPlug (xmlSchemaValidCtxtPtr ctxt, xmlSAXHandlerPtr* sax, void** user_data) 5234 return 1 if($PLevel>=2); 5235 # symbol array for reading 5236 return 1 if($PLevel==1 and not is_const_type($TypeName) and isCharType($FTypeName) 5237 and not grep(/\A(name|cur|current|out|ret|return|buf|buffer|res|result|rslt)\Z/i, @{get_tokens($ParamName)})); 5238 # array followed by the two numbers 5239 return 1 if(not is_const_type($TypeName) and defined $CompleteSignature{$Interface}{"Param"}{$ParamPos+1} 5240 and defined $CompleteSignature{$Interface}{"Param"}{$ParamPos+2} 5241 and isIntegerType(get_TypeName($CompleteSignature{$Interface}{"Param"}{$ParamPos+1}{"type"})) 5242 and isIntegerType(get_TypeName($CompleteSignature{$Interface}{"Param"}{$ParamPos+2}{"type"})) 5243 and is_array_count($ParamName, $CompleteSignature{$Interface}{"Param"}{$ParamPos+2}{"name"})); 5244 # numeric arrays for reading 5245 return 1 if(is_const_type($TypeName) and isNumericType($FTypeName)); 5246 # symbol buffer for reading 5247 return 1 if(is_const_type($TypeName) and $ParamName=~/buf/i and $I_ShortName=~/memory/i 5248 and isCharType($FTypeName)); 5249 5250 # isn't array 5251 return 0; 5252} 5253 5254sub check_type_returned($$) 5255{ 5256 my ($TypeId, $Strong) = @_; 5257 return 0 if(not $TypeId); 5258 my $BaseTypeId = get_FoundationTypeId($TypeId); 5259 if(get_TypeType($BaseTypeId) ne "Intrinsic") 5260 { # by return value 5261 return 1 if(keys(%{$ReturnTypeId_Interface{$TypeId}}) or keys(%{$ReturnTypeId_Interface{$BaseTypeId}})); 5262 if(not $Strong) 5263 { # base type and plevel match 5264 my $PLevel = get_PointerLevel($TypeId); 5265 foreach (0 .. $PLevel) 5266 { 5267 return 1 if(keys(%{$BaseType_PLevel_OutParam{$BaseTypeId}{$_}}) 5268 or keys(%{$BaseType_PLevel_Return{$BaseTypeId}{$_}})); 5269 } 5270 } 5271 5272 } 5273 return 0; 5274} 5275 5276sub isBuffer($$$) 5277{ 5278 my ($TypeId, $ParamName, $Interface) = @_; 5279 return 0 if(not $TypeId or not $ParamName); 5280 my $I_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 5281 my $FTypeId = get_FoundationTypeId($TypeId); 5282 my $FTypeType = get_TypeType($FTypeId); 5283 my $FTypeName = get_TypeName($FTypeId); 5284 my $TypeName = get_TypeName($TypeId); 5285 my $PLevel = get_PointerLevel($TypeId); 5286 5287 # exceptions 5288 # bmp_read24 (uintptr_t addr) 5289 # bmp_write24 (uintptr_t addr, int c) 5290 return 1 if($PLevel==0 and $ParamName=~/addr/i and isIntegerType($FTypeName)); 5291 # cblas_zdotu_sub (int const N, void const* X, int const incX, void const* Y, int const incY, void* dotu) 5292 return 1 if($PLevel==1 and $FTypeName eq "void"); 5293 if(get_TypeType($FTypeId) eq "Array" and $Interface) 5294 { 5295 my $ArrayElemType_Id = get_FoundationTypeId(get_OneStep_BaseTypeId($FTypeId)); 5296 if(get_TypeType($ArrayElemType_Id)=~/\A(Intrinsic|Enum)\Z/) 5297 { 5298 return 1 if(get_TypeAttr($FTypeId, "Count")>1024); 5299 } 5300 else 5301 { 5302 return 1 if(get_TypeAttr($FTypeId, "Count")>256); 5303 } 5304 } 5305 5306 # strong reject 5307 return 0 if($PLevel <= 0); 5308 return 0 if(is_const_type($TypeName)); 5309 return 0 if(isString($TypeId, $ParamName, $Interface)); 5310 return 0 if($PLevel==1 and isOpaque($FTypeId)); 5311 return 0 if(($FTypeType=~/\A(Struct|Union|Class)\Z/ 5312 or ($TypeName ne uncover_typedefs($TypeName) and $TypeName!~/size_t|int/)) 5313 and check_type_returned($TypeId, isArrayName($TypeName))); 5314 5315 # allowed configurations 5316 # symbol buffer for writing 5317 return 1 if(isSymbolBuffer($TypeId, $ParamName, $Interface)); 5318 if($ParamName=~/\Ap\d+\Z/) 5319 { 5320 # buffer of void* type for writing 5321 return 1 if($PLevel==1 and $FTypeName eq "void"); 5322 # buffer of arrays for writing 5323 return 1 if($FTypeType eq "Array"); 5324 } 5325 return 1 if(is_out_word($ParamName)); 5326 # gsl_fft_real_radix2_transform (double* data, size_t const stride, size_t const n) 5327 return 1 if($PLevel==1 and isNumericType($FTypeName) and $ParamName!~/(len|size)/i); 5328 5329 # isn't array 5330 return 0; 5331} 5332 5333sub is_out_word($) 5334{ 5335 my $Word = $_[0]; 5336 return grep(/\A(out|output|dest|buf|buff|buffer|ptr|pointer|result|res|ret|return|rtrn)\Z/i, @{get_tokens($Word)}); 5337} 5338 5339sub isSymbolBuffer($$$) 5340{ 5341 my ($TypeId, $ParamName, $Interface) = @_; 5342 return 0 if(not $TypeId or not $ParamName); 5343 my $FTypeId = get_FoundationTypeId($TypeId); 5344 my $FTypeName = get_TypeName($FTypeId); 5345 my $TypeName = get_TypeName($TypeId); 5346 my $PLevel = get_PointerLevel($TypeId); 5347 return (not is_const_type($TypeName) and $PLevel==1 5348 and isCharType($FTypeName) 5349 and $ParamName!~/data|value|arg|var/i and $TypeName!~/list|va_/ 5350 and (grep(/\A(name|cur|current)\Z/i, @{get_tokens($ParamName)}) or is_out_word($ParamName))); 5351} 5352 5353sub isOutParam_NoUsing($$$) 5354{ 5355 my ($TypeId, $ParamName, $Interface) = @_; 5356 return 0 if(not $TypeId or not $ParamName); 5357 my $Func_ShortName = $CompleteSignature{$Interface}{"ShortName"}; 5358 my $FTypeId = get_FoundationTypeId($TypeId); 5359 my $FTypeName = get_TypeName($FTypeId); 5360 my $TypeName = get_TypeName($TypeId); 5361 my $PLevel = get_PointerLevel($TypeId); 5362 return 0 if($PLevel==1 and isOpaque($FTypeId)); # size of the structure/union is unknown 5363 return 0 if(is_const_type($TypeName) or $PLevel<=0); 5364 return 1 if(grep(/\A(err|error)(_|)(p|ptr|)\Z/i, @{get_tokens($ParamName." ".$TypeName)}) and $Func_ShortName!~/error/i); 5365 return 1 if(grep(/\A(out|ret|return)\Z/i, @{get_tokens($ParamName)})); 5366 return 1 if($PLevel>=2 and isCharType($FTypeName) and not is_const_type($TypeName)); 5367 return 0; 5368} 5369 5370sub isString($$$) 5371{ 5372 my ($TypeId, $ParamName, $Interface) = @_; 5373 return 0 if(not $TypeId or not $ParamName); 5374 my $TypeName_Trivial = uncover_typedefs(get_TypeName($TypeId)); 5375 my $PLevel = get_PointerLevel($TypeId); 5376 my $TypeName = get_TypeName($TypeId); 5377 my $FoundationTypeName = get_TypeName(get_FoundationTypeId($TypeId)); 5378 # not a pointer 5379 return 0 if($ParamName=~/ptr|pointer/i); 5380 # standard string (std::string) 5381 return 1 if($PLevel==0 and $FoundationTypeName eq "std::basic_string<char>"); 5382 if($FoundationTypeName=~/\A(char|unsigned char|wchar_t|short|unsigned short)\Z/) 5383 { 5384 # char const*, unsigned char const*, wchar_t const* 5385 # void const*, short const*, unsigned short const* 5386 # ChannelGroup::getName ( char* name, int namelen ) 5387 return 1 if($PLevel==1 and is_const_type($TypeName_Trivial)); 5388 if(not hasLength($ParamName, $Interface)) 5389 { 5390 return 1 if($PLevel==1 and $CompleteSignature{$Interface}{"ShortName"}!~/get|encode/i 5391 and $ParamName=~/\A(file|)(_|)path\Z|description|label|name/i); 5392 # direct_trim ( char** s ) 5393 return 1 if($PLevel>=1 and $ParamName=~/\A(s|str|string)\Z/i); 5394 } 5395 } 5396 5397 # isn't a string 5398 return 0; 5399} 5400 5401sub isOpaque($) 5402{ 5403 my $TypeId = $_[0]; 5404 return 0 if(not $TypeId); 5405 my %Type = get_Type($TypeId); 5406 return ($Type{"Type"}=~/\A(Struct|Union)\Z/ and not keys(%{$Type{"Memb"}}) and not $Type{"Memb"}{0}{"name"}); 5407} 5408 5409sub isStr_FileName($$$) 5410{ # should be called after the "isString" function 5411 my ($ParamPos, $ParamName, $Interface_ShortName) = @_; 5412 return 0 if(not $ParamName); 5413 if($ParamName=~/ext/i) 5414 { # not an extension 5415 return 0; 5416 } 5417 if($ParamName=~/file|dtd/i 5418 and $ParamName!~/type|opt/i) 5419 { # any files, dtds 5420 return 1; 5421 } 5422 return 1 if(lc($ParamName) eq "fname"); 5423 # files as buffers 5424 return 1 if($ParamName=~/buf/i and $Interface_ShortName!~/memory|write/i and $Interface_ShortName=~/file/i); 5425 # name of the file at the first parameter of read/write/open functions 5426 # return 1 if($ParamName=~/\A[_]*name\Z/i and $Interface_ShortName=~/read|write|open/i and $ParamPos=="0"); 5427 # file path 5428 return 1 if($ParamName=~/path/i 5429 and $Interface_ShortName=~/open|create|file/i 5430 and $Interface_ShortName!~/(open|_)dir(_|\Z)/i); 5431 # path to the configs 5432 return 1 if($ParamName=~/path|cfgs/i and $Interface_ShortName=~/config/i); 5433 # parameter of the string constructor 5434 return 1 if($ParamName=~/src/i and $Interface_ShortName!~/string/i and $ParamPos=="0"); 5435 # uri/url of the local files 5436 return 1 if($ParamName=~/uri|url/i and $Interface_ShortName!~/http|ftp/i); 5437 5438 # isn't a file path 5439 return 0; 5440} 5441 5442sub isStr_Dir($$) 5443{ 5444 my ($ParamName, $Interface_ShortName) = @_; 5445 return 0 if(not $ParamName); 5446 return 1 if($ParamName=~/path/i 5447 and $Interface_ShortName=~/(open|_)dir(_|\Z)/i); 5448 return 1 if($ParamName=~/dir/i); 5449 5450 # isn't a directory 5451 return 0; 5452} 5453 5454sub equal_types($$) 5455{ 5456 my ($Type1_Id, $Type2_Id) = @_; 5457 return (uncover_typedefs(get_TypeName($Type1_Id)) eq uncover_typedefs(get_TypeName($Type2_Id))); 5458} 5459 5460sub reduce_pointer_level($) 5461{ 5462 my $TypeId = $_[0]; 5463 my %PureType = get_PureType($TypeId); 5464 my $BaseTypeId = get_OneStep_BaseTypeId($PureType{"Tid"}); 5465 return ($BaseTypeId eq $TypeId)?"":$BaseTypeId; 5466} 5467 5468sub reassemble_array($) 5469{ 5470 my $TypeId = $_[0]; 5471 return () if(not $TypeId); 5472 my $FoundationTypeId = get_FoundationTypeId($TypeId); 5473 if(get_TypeType($FoundationTypeId) eq "Array") 5474 { 5475 my ($BaseName, $Length) = (get_TypeName($FoundationTypeId), 1); 5476 while($BaseName=~s/\[(\d+)\]//) { 5477 $Length*=$1; 5478 } 5479 return ($BaseName, $Length); 5480 } 5481 else { 5482 return (); 5483 } 5484} 5485 5486sub get_call_malloc($) 5487{ 5488 my $TypeId = $_[0]; 5489 return "" if(not $TypeId); 5490 my $FoundationTypeId = get_FoundationTypeId($TypeId); 5491 my $FoundationTypeName = get_TypeName($FoundationTypeId); 5492 my $PointerLevel = get_PointerLevel($TypeId); 5493 my $Conv = ($FoundationTypeName ne "void")?"(".get_TypeName($TypeId).") ":""; 5494 $Conv=~s/\&//g; 5495 my $BuffSize = 0; 5496 if(get_TypeType($FoundationTypeId) eq "Array") 5497 { 5498 my ($Array_BaseName, $Array_Length) = reassemble_array($TypeId); 5499 $Conv = "($Array_BaseName*)"; 5500 $BuffSize = $Array_Length; 5501 $FoundationTypeName = $Array_BaseName; 5502 my %ArrayBase = get_BaseType($TypeId); 5503 $FoundationTypeId = $ArrayBase{"Tid"}; 5504 } 5505 else { 5506 $BuffSize = $BUFF_SIZE; 5507 } 5508 my $MallocCall = "malloc"; 5509 if($LibraryMallocFunc) 5510 { 5511 $MallocCall = $CompleteSignature{$LibraryMallocFunc}{"ShortName"}; 5512 if(my $NS = $CompleteSignature{$LibraryMallocFunc}{"NameSpace"}) { 5513 $MallocCall = $NS."::".$MallocCall; 5514 } 5515 } 5516 if($FoundationTypeName eq "void") { 5517 return $Conv.$MallocCall."($BuffSize)"; 5518 } 5519 else 5520 { 5521 if(isOpaque($FoundationTypeId)) 5522 { # opaque buffers 5523 if(get_TypeType($FoundationTypeId) eq "Array") { 5524 $BuffSize*=$BUFF_SIZE; 5525 } 5526 else { 5527 $BuffSize*=4; 5528 } 5529 return $Conv.$MallocCall."($BuffSize)"; 5530 } 5531 else 5532 { 5533 if($PointerLevel==1) 5534 { 5535 my $ReducedTypeId = reduce_pointer_level($TypeId); 5536 return $Conv.$MallocCall."(sizeof(".get_TypeName($ReducedTypeId).")".($BuffSize>1?"*$BuffSize":"").")"; 5537 } 5538 else { 5539 return $Conv.$MallocCall."(sizeof($FoundationTypeName)".($BuffSize>1?"*$BuffSize":"").")"; 5540 } 5541 } 5542 } 5543} 5544 5545sub isKnownExt($) 5546{ 5547 my $Ext = $_[0]; 5548 if($Ext=~/\A(png|tiff|zip|bmp|bitmap|nc)/i) 5549 { 5550 return $1; 5551 } 5552 return ""; 5553} 5554 5555sub add_VirtualSpecType(@) 5556{ 5557 my %Init_Desc = @_; 5558 my %NewInit_Desc = %Init_Desc; 5559 if($Init_Desc{"Value"} eq "") { 5560 $Init_Desc{"Value"} = "no value"; 5561 } 5562 my ($TypeId, $ParamName, $Interface) = ($Init_Desc{"TypeId"}, $Init_Desc{"ParamName"}, $Init_Desc{"Interface"}); 5563 my $FoundationTypeId = get_FoundationTypeId($TypeId); 5564 my $FoundationTypeName = get_TypeName($FoundationTypeId); 5565 my $PointerLevel = get_PointerLevel($TypeId); 5566 my $FoundationTypeType = $TypeInfo{$FoundationTypeId}{"Type"}; 5567 my $TypeName = get_TypeName($TypeId); 5568 my $TypeType = get_TypeType($TypeId); 5569 my $I_ShortName = $CompleteSignature{$Init_Desc{"Interface"}}{"ShortName"}; 5570 my $I_Header = $CompleteSignature{$Init_Desc{"Interface"}}{"Header"}; 5571 if($Init_Desc{"Value"} eq "no value" 5572 or (defined $ValueCollection{$CurrentBlock}{$ParamName} and $ValueCollection{$CurrentBlock}{$ParamName}==$TypeId)) 5573 { # create value atribute 5574 if($CurrentBlock and keys(%{$ValueCollection{$CurrentBlock}}) and not $Init_Desc{"InLineArray"}) 5575 { 5576 ($NewInit_Desc{"Value"}, $NewInit_Desc{"ValueTypeId"}) = select_ValueFromCollection(%Init_Desc); 5577 if($NewInit_Desc{"Value"} and $NewInit_Desc{"ValueTypeId"}) 5578 { 5579 my ($Call, $TmpPreamble)=convertTypes(( 5580 "InputTypeName"=>get_TypeName($NewInit_Desc{"ValueTypeId"}), 5581 "InputPointerLevel"=>get_PointerLevel($NewInit_Desc{"ValueTypeId"}), 5582 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$TypeId, 5583 "Value"=>$NewInit_Desc{"Value"}, 5584 "Key"=>$LongVarNames?$Init_Desc{"Key"}:$ParamName, 5585 "Destination"=>"Param", 5586 "MustConvert"=>0)); 5587 if($Call and not $TmpPreamble) 5588 { # try to create simple value 5589 $NewInit_Desc{"ValueTypeId"}=$TypeId; 5590 $NewInit_Desc{"Value"} = $Call; 5591 } 5592 if($NewInit_Desc{"ValueTypeId"}==$TypeId) { 5593 $NewInit_Desc{"InLine"} = 1; 5594 } 5595 $NewInit_Desc{"Reuse"} = 1; 5596 return %NewInit_Desc; 5597 } 5598 } 5599 if($TypeName=~/\&/ 5600 or not $Init_Desc{"InLine"}) { 5601 $NewInit_Desc{"InLine"} = 0; 5602 } 5603 else { 5604 $NewInit_Desc{"InLine"} = 1; 5605 } 5606 # creating virtual specialized type 5607 if($TypeName eq "...") 5608 { 5609 $NewInit_Desc{"Value"} = get_null(); 5610 $NewInit_Desc{"ValueTypeId"} = get_TypeIdByName("int"); 5611 } 5612 elsif($I_ShortName eq "time" and $I_Header eq "time.h") 5613 { # spectype for time_t time(time_t *t) from time.h 5614 $NewInit_Desc{"Value"} = get_null(); 5615 $NewInit_Desc{"ValueTypeId"} = $TypeId; 5616 } 5617 elsif($ParamName=~/unused/i and $PointerLevel>=1) 5618 { # curl_getdate ( char const* p, time_t const* unused ) 5619 $NewInit_Desc{"Value"} = get_null(); 5620 $NewInit_Desc{"ValueTypeId"} = $TypeId; 5621 } 5622 elsif($FoundationTypeName eq "int" and $ParamName=~/\Aargc(_|)(p|ptr|)\Z/i 5623 and not $Interface_OutParam{$Interface}{$ParamName} and $PointerLevel>=1 5624 and my $Value_TId = register_new_type(get_TypeIdByName("int"), 1)) 5625 { # gtk_init ( int* argc, char*** argv ) 5626 $NewInit_Desc{"Value"} = "&argc"; 5627 $NewInit_Desc{"ValueTypeId"} = $Value_TId; 5628 } 5629 elsif($FoundationTypeName eq "char" and $ParamName=~/\Aargv(_|)(p|ptr|)\Z/i 5630 and not $Interface_OutParam{$Interface}{$ParamName} and $PointerLevel>=3 5631 and my $Value_TId = register_new_type(get_TypeIdByName("char"), 3)) 5632 { # gtk_init ( int* argc, char*** argv ) 5633 $NewInit_Desc{"Value"} = "&argv"; 5634 $NewInit_Desc{"ValueTypeId"} = $Value_TId; 5635 } 5636 elsif($FoundationTypeName eq "complex float") 5637 { 5638 $NewInit_Desc{"Value"} = getIntrinsicValue("float")." + I*".getIntrinsicValue("float"); 5639 $NewInit_Desc{"ValueTypeId"} = $FoundationTypeId; 5640 } 5641 elsif($FoundationTypeName eq "complex double") 5642 { 5643 $NewInit_Desc{"Value"} = getIntrinsicValue("double")." + I*".getIntrinsicValue("double"); 5644 $NewInit_Desc{"ValueTypeId"} = $FoundationTypeId; 5645 } 5646 elsif($FoundationTypeName eq "complex long double") 5647 { 5648 $NewInit_Desc{"Value"} = getIntrinsicValue("long double")." + I*".getIntrinsicValue("long double"); 5649 $NewInit_Desc{"ValueTypeId"} = $FoundationTypeId; 5650 } 5651 elsif((($Interface_OutParam{$Interface}{$ParamName} and $PointerLevel>=1) or ($Interface_OutParam_NoUsing{$Interface}{$ParamName} 5652 and $PointerLevel>=1)) and not grep(/\A(in|input)\Z/, @{get_tokens($ParamName)}) and not isSymbolBuffer($TypeId, $ParamName, $Interface)) 5653 { 5654 $NewInit_Desc{"InLine"} = 0; 5655 $NewInit_Desc{"ValueTypeId"} = reduce_pointer_level($TypeId); 5656 if($PointerLevel>=2) { 5657 $NewInit_Desc{"Value"} = get_null(); 5658 } 5659 elsif($PointerLevel==1 and isNumericType(get_TypeName($FoundationTypeId))) 5660 { 5661 $NewInit_Desc{"Value"} = "0"; 5662 $NewInit_Desc{"OnlyByValue"} = 1; 5663 } 5664 else { 5665 $NewInit_Desc{"OnlyDecl"} = 1; 5666 } 5667 $NewInit_Desc{"UseableValue"} = 1; 5668 } 5669 elsif($FoundationTypeName eq "void" and $PointerLevel==1 5670 and my $SimilarType_Id = find_similar_type($NewInit_Desc{"TypeId"}, $ParamName) 5671 and $TypeName=~/(\W|\A)void(\W|\Z)/ and not $NewInit_Desc{"TypeId_Changed"}) 5672 { 5673 $NewInit_Desc{"TypeId"} = $SimilarType_Id; 5674 $NewInit_Desc{"DenyMalloc"} = 1; 5675 %NewInit_Desc = add_VirtualSpecType(%NewInit_Desc); 5676 $NewInit_Desc{"TypeId_Changed"} = $TypeId; 5677 } 5678 elsif(isArray($TypeId, $ParamName, $Interface) 5679 and not $Init_Desc{"IsString"}) 5680 { 5681 $NewInit_Desc{"FoundationType_Type"} = "Array"; 5682 if($ParamName=~/matrix/) { 5683 $NewInit_Desc{"ArraySize"} = 16; 5684 } 5685 $NewInit_Desc{"TypeType_Changed"} = 1; 5686 } 5687 elsif($Init_Desc{"FuncPtrName"}=~/realloc/i and $PointerLevel==1 5688 and $Init_Desc{"RetVal"} and $Init_Desc{"FuncPtrTypeId"}) 5689 { 5690 my %FuncPtrType = get_Type($Init_Desc{"FuncPtrTypeId"}); 5691 my ($IntParam, $IntParam2, $PtrParam, $PtrTypeId) = ("", "", "", 0); 5692 foreach my $ParamPos (sort {int($a) <=> int($b)} keys(%{$FuncPtrType{"Memb"}})) 5693 { 5694 my $ParamTypeId = $FuncPtrType{"Memb"}{$ParamPos}{"type"}; 5695 my $ParamName = $FuncPtrType{"Memb"}{$ParamPos}{"name"}; 5696 $ParamName = "p".($ParamPos+1) if(not $ParamName); 5697 my $ParamFTypeId = get_FoundationTypeId($ParamTypeId); 5698 if(isIntegerType(get_TypeName($ParamTypeId))) 5699 { 5700 if(not $IntParam) { 5701 $IntParam = $ParamName; 5702 } 5703 elsif(not $IntParam2) { 5704 $IntParam2 = $ParamName; 5705 } 5706 } 5707 elsif(get_PointerLevel($ParamTypeId)==1 5708 and get_TypeType($ParamFTypeId) eq "Intrinsic") 5709 { 5710 $PtrParam = $ParamName; 5711 $PtrTypeId = $ParamTypeId; 5712 } 5713 } 5714 if($IntParam and $PtrParam) 5715 { # function has an integer parameter 5716 my $Conv = ($FoundationTypeName ne "void")?"(".get_TypeName($TypeId).") ":""; 5717 $Conv=~s/\&//g; 5718 my $VoidConv = (get_TypeName(get_FoundationTypeId($PtrTypeId)) ne "void")?"(void*)":""; 5719 if($IntParam2) { 5720 $NewInit_Desc{"Value"} = $Conv."realloc($VoidConv$PtrParam, $IntParam2)"; 5721 } 5722 else { 5723 $NewInit_Desc{"Value"} = $Conv."realloc($VoidConv$PtrParam, $IntParam)"; 5724 } 5725 } 5726 else { 5727 $NewInit_Desc{"Value"} = get_call_malloc($TypeId); 5728 } 5729 $NewInit_Desc{"ValueTypeId"} = $TypeId; 5730 $NewInit_Desc{"InLine"} = ($Init_Desc{"RetVal"} or ($Init_Desc{"OuterType_Type"} eq "Array"))?1:0; 5731 if($LibraryMallocFunc and (not $IntParam or not $PtrParam)) { 5732 $NewInit_Desc{"Headers"} = addHeaders([$CompleteSignature{$LibraryMallocFunc}{"Header"}], $NewInit_Desc{"Headers"}); 5733 } 5734 else 5735 { 5736 $NewInit_Desc{"Headers"} = addHeaders(["stdlib.h"], $NewInit_Desc{"Headers"}); 5737 $AuxHeaders{"stdlib.h"} = 1; 5738 } 5739 } 5740 elsif($Init_Desc{"FuncPtrName"}=~/alloc/i and $PointerLevel==1 5741 and $Init_Desc{"RetVal"} and $Init_Desc{"FuncPtrTypeId"}) 5742 { 5743 my %FuncPtrType = get_Type($Init_Desc{"FuncPtrTypeId"}); 5744 my $IntParam = ""; 5745 foreach my $ParamPos (sort {int($a) <=> int($b)} keys(%{$FuncPtrType{"Memb"}})) 5746 { 5747 my $ParamTypeId = $FuncPtrType{"Memb"}{$ParamPos}{"type"}; 5748 my $ParamName = $FuncPtrType{"Memb"}{$ParamPos}{"name"}; 5749 $ParamName = "p".($ParamPos+1) if(not $ParamName); 5750 if(isIntegerType(get_TypeName($ParamTypeId))) 5751 { 5752 $IntParam = $ParamName; 5753 last; 5754 } 5755 } 5756 if($IntParam) 5757 { # function has an integer parameter 5758 my $Conv = ($FoundationTypeName ne "void")?"(".get_TypeName($TypeId).") ":""; 5759 $Conv=~s/\&//g; 5760 $NewInit_Desc{"Value"} = $Conv."malloc($IntParam)"; 5761 } 5762 else { 5763 $NewInit_Desc{"Value"} = get_call_malloc($TypeId); 5764 } 5765 $NewInit_Desc{"ValueTypeId"} = $TypeId; 5766 $NewInit_Desc{"InLine"} = ($Init_Desc{"RetVal"} or ($Init_Desc{"OuterType_Type"} eq "Array"))?1:0; 5767 if($LibraryMallocFunc and not $IntParam) { 5768 $NewInit_Desc{"Headers"} = addHeaders([$CompleteSignature{$LibraryMallocFunc}{"Header"}], $NewInit_Desc{"Headers"}); 5769 } 5770 else 5771 { 5772 $NewInit_Desc{"Headers"} = addHeaders(["stdlib.h"], $NewInit_Desc{"Headers"}); 5773 $AuxHeaders{"stdlib.h"} = 1; 5774 } 5775 } 5776 elsif((isBuffer($TypeId, $ParamName, $Interface) 5777 or ($PointerLevel==1 and $I_ShortName=~/free/i and $FoundationTypeName=~/\A(void|char|unsigned char|wchar_t)\Z/)) 5778 and not $NewInit_Desc{"InLineArray"} and not $Init_Desc{"IsString"} and not $Init_Desc{"DenyMalloc"}) 5779 { 5780 if(get_TypeName($TypeId) eq "char const*" 5781 and (my $NewTypeId = get_TypeIdByName("char*"))) { 5782 $TypeId = $NewTypeId; 5783 } 5784 $NewInit_Desc{"Value"} = get_call_malloc($TypeId); 5785 $NewInit_Desc{"ValueTypeId"} = $TypeId; 5786 $NewInit_Desc{"InLine"} = ($Init_Desc{"RetVal"} or ($Init_Desc{"OuterType_Type"} eq "Array"))?1:0; 5787 if($LibraryMallocFunc) { 5788 $NewInit_Desc{"Headers"} = addHeaders([$CompleteSignature{$LibraryMallocFunc}{"Header"}], $NewInit_Desc{"Headers"}); 5789 } 5790 else 5791 { 5792 $NewInit_Desc{"Headers"} = addHeaders(["stdlib.h"], $NewInit_Desc{"Headers"}); 5793 $AuxHeaders{"stdlib.h"} = 1; 5794 } 5795 } 5796 elsif(isString($TypeId, $ParamName, $Interface) 5797 or $Init_Desc{"IsString"}) 5798 { 5799 my @Values = (); 5800 if($ParamName and $ParamName!~/\Ap\d+\Z/) 5801 { 5802 if($I_ShortName=~/Display/ and $ParamName=~/name|display/i) 5803 { 5804 @Values = ("getenv(\"DISPLAY\")"); 5805 $NewInit_Desc{"Headers"} = addHeaders(["stdlib.h"], $NewInit_Desc{"Headers"}); 5806 $AuxHeaders{"stdlib.h"} = 1; 5807 } 5808 elsif($ParamName=~/uri|url|href/i 5809 and $I_ShortName!~/file/i) { 5810 @Values = ("\"http://www.w3.org/\""); 5811 } 5812 elsif($ParamName=~/language/i) { 5813 @Values = ("\"$COMMON_LANGUAGE\""); 5814 } 5815 elsif($ParamName=~/mount/i and $ParamName=~/path/i) { 5816 @Values = ("\"/dev\""); 5817 } 5818 elsif(isStr_FileName($Init_Desc{"ParamPos"}, $ParamName, $I_ShortName)) 5819 { 5820 if($I_ShortName=~/sqlite/i) { 5821 @Values = ("TG_TEST_DATA_DB"); 5822 } 5823 elsif($TestedInterface=~/\A(ov_|vorbis_)/i) { 5824 @Values = ("TG_TEST_DATA_AUDIO"); 5825 } 5826 elsif($TestedInterface=~/\A(zip_)/i) { 5827 @Values = ("TG_TEST_DATA_ZIP_FILE"); 5828 } 5829 elsif($ParamName=~/dtd/i or $I_ShortName=~/dtd/i) { 5830 @Values = ("TG_TEST_DATA_DTD_FILE"); 5831 } 5832 elsif($ParamName=~/xml/i or $I_ShortName=~/xml/i 5833 or ($Init_Desc{"OuterType_Type"}=~/\A(Struct|Union)\Z/ and get_TypeName($Init_Desc{"OuterType_Id"})=~/xml/i)) 5834 { 5835 @Values = ("TG_TEST_DATA_XML_FILE"); 5836 } 5837 elsif($ParamName=~/html/i or $I_ShortName=~/html/i 5838 or ($Init_Desc{"OuterType_Type"}=~/\A(Struct|Union)\Z/ and get_TypeName($Init_Desc{"OuterType_Id"})=~/html/i)) 5839 { 5840 @Values = ("TG_TEST_DATA_HTML_FILE"); 5841 } 5842 elsif($ParamName=~/path/i and $I_ShortName=~/\Asnd_/) 5843 { # ALSA 5844 @Values = ("TG_TEST_DATA_ASOUNDRC_FILE"); 5845 } 5846 else 5847 { 5848 my $KnownExt = isKnownExt(getPrefix($I_ShortName)); 5849 $KnownExt = isKnownExt($Init_Desc{"Key"}) if(not $KnownExt); 5850 $KnownExt = isKnownExt($TestedInterface) if(not $KnownExt); 5851 $KnownExt = isKnownExt($I_ShortName) if(not $KnownExt); 5852 if($KnownExt) { 5853 @Values = ("TG_TEST_DATA_FILE_".uc($KnownExt)); 5854 } 5855 else { 5856 @Values = ("TG_TEST_DATA_PLAIN_FILE"); 5857 } 5858 } 5859 } 5860 elsif(isStr_Dir($ParamName, $I_ShortName) 5861 or ($ParamName=~/path/ and get_TypeName($Init_Desc{"OuterType_Id"})=~/Dir|directory/)) 5862 { 5863 @Values = ("TG_TEST_DATA_DIRECTORY"); 5864 } 5865 elsif($ParamName=~/path/i and $I_ShortName=~/\Adbus_/) 5866 { # D-Bus 5867 @Values = ("TG_TEST_DATA_ABS_FILE"); 5868 } 5869 elsif($ParamName=~/path/i) { 5870 @Values = ("TG_TEST_DATA_PLAIN_FILE"); 5871 } 5872 elsif($ParamName=~/\A(ext|extension(s|))\Z/i) { 5873 @Values = ("\".txt\"", "\".hh\""); 5874 } 5875 elsif($ParamName=~/mode/i and $I_ShortName=~/fopen/i) 5876 { # FILE *fopen(const char *path, const char *mode) 5877 @Values = ("\"r+\""); 5878 } 5879 elsif($ParamName=~/mode/i and $I_ShortName=~/open/i) { 5880 @Values = ("\"rw\""); 5881 } 5882 elsif($ParamName=~/date/i) { 5883 @Values = ("\"Sun, 06 Nov 1994 08:49:37 GMT\""); 5884 } 5885 elsif($ParamName=~/day/i) { 5886 @Values = ("\"monday\"", "\"tuesday\""); 5887 } 5888 elsif($ParamName=~/month/i) { 5889 @Values = ("\"november\"", "\"october\""); 5890 } 5891 elsif($ParamName=~/name/i and $I_ShortName=~/font/i) 5892 { 5893 if($I_ShortName=~/\A[_]*X/) { 5894 @Values = ("\"10x20\"", "\"fixed\""); 5895 } 5896 else { 5897 @Values = ("\"times\"", "\"arial\"", "\"courier\""); 5898 } 5899 } 5900 elsif($ParamName=~/version/i) { 5901 @Values = ("\"1.0\"", "\"2.0\""); 5902 } 5903 elsif($ParamName=~/encoding/i 5904 or $Init_Desc{"Key"}=~/encoding/i) { 5905 @Values = ("\"utf-8\"", "\"koi-8\""); 5906 } 5907 elsif($ParamName=~/method/i 5908 and $I_ShortName=~/http|ftp|url|uri|request/i) { 5909 @Values = ("\"GET\"", "\"PUT\""); 5910 } 5911 elsif($I_ShortName=~/cast/i 5912 and $CompleteSignature{$Interface}{"Class"}) { 5913 @Values = ("\"".get_TypeName($CompleteSignature{$Interface}{"Class"})."\""); 5914 } 5915 elsif($I_ShortName=~/\Asnd_/ and $I_ShortName!~/\Asnd_seq_/ and $ParamName=~/name/i) 5916 { # ALSA 5917 @Values = ("\"hw:0\""); 5918 } 5919 elsif($ParamName=~/var/i and $I_ShortName=~/env/i) { 5920 @Values = ("\"HOME\"", "\"PATH\""); 5921 } 5922 elsif($ParamName=~/error_name/i and $I_ShortName=~/\Adbus_/) 5923 { # D-Bus 5924 if($Constants{"DBUS_ERROR_FAILED"}{"Value"}) { 5925 @Values = ("DBUS_ERROR_FAILED"); 5926 } 5927 else { 5928 @Values = ("\"org.freedesktop.DBus.Error.Failed\""); 5929 } 5930 } 5931 elsif($ParamName=~/name/i and $I_ShortName=~/\Adbus_/) 5932 { # D-Bus 5933 @Values = ("\"sample.bus\""); 5934 } 5935 elsif($ParamName=~/interface/i and $I_ShortName=~/\Adbus_/) { 5936 @Values = ("\"sample.interface\""); # D-Bus 5937 } 5938 elsif($ParamName=~/address/i and $I_ShortName=~/\Adbus_server/) { 5939 @Values = ("\"unix:tmpdir=/tmp\""); # D-Bus 5940 } 5941 elsif($CompleteSignature{$Interface}{"Constructor"} and not $Init_Desc{"ParamRenamed"}) 5942 { 5943 my $KeyPart = $Init_Desc{"Key"}; 5944 my $IgnoreSiffix = lc($I_ShortName)."_".$ParamName; 5945 $KeyPart=~s/_\Q$ParamName\E\Z// if($I_ShortName=~/string|char/i and $KeyPart!~/(\A|_)\Q$IgnoreSiffix\E\Z/); 5946 $KeyPart=~s/_\d+\Z//g; 5947 $KeyPart=~s/\A.*_([^_]+)\Z/$1/g; 5948 if($KeyPart!~/(\A|_)p\d+\Z/) 5949 { 5950 $NewInit_Desc{"ParamName"} = $KeyPart; 5951 $NewInit_Desc{"ParamRenamed"} = 1; 5952 %NewInit_Desc = add_VirtualSpecType(%NewInit_Desc); 5953 } 5954 else { 5955 @Values = ("\"".$ParamName."\""); 5956 } 5957 } 5958 else { 5959 @Values = ("\"".$ParamName."\""); 5960 } 5961 } 5962 else 5963 { 5964 if($I_ShortName=~/Display/) 5965 { 5966 @Values = ("getenv(\"DISPLAY\")"); 5967 $NewInit_Desc{"Headers"} = addHeaders(["stdlib.h"], $NewInit_Desc{"Headers"}); 5968 $AuxHeaders{"stdlib.h"} = 1; 5969 } 5970 elsif($I_ShortName=~/cast/ and $CompleteSignature{$Interface}{"Class"}) { 5971 @Values = ("\"".get_TypeName($CompleteSignature{$Interface}{"Class"})."\""); 5972 } 5973 else { 5974 @Values = (getIntrinsicValue("char*")); 5975 } 5976 } 5977 if($FoundationTypeName eq "wchar_t") 5978 { 5979 foreach my $Str (@Values) { 5980 $Str = "L".$Str if($Str=~/\A\"/); 5981 } 5982 $NewInit_Desc{"ValueTypeId"} = get_TypeIdByName("wchar_t const*"); 5983 } 5984 elsif($FoundationTypeType eq "Intrinsic") { 5985 $NewInit_Desc{"ValueTypeId"} = get_TypeIdByName("char const*"); 5986 } 5987 else 5988 { # std::string 5989 $NewInit_Desc{"ValueTypeId"} = $FoundationTypeId; 5990 } 5991 $NewInit_Desc{"Value"} = vary_values(\@Values, \%Init_Desc) if($#Values>=0); 5992 if(not is_const_type(uncover_typedefs(get_TypeName($TypeId))) and not $Init_Desc{"IsString"}) 5993 { # FIXME: inlining strings 5994 #$NewInit_Desc{"InLine"} = 0; 5995 } 5996 } 5997 elsif(($FoundationTypeName eq "void") and ($PointerLevel==1)) 5998 { 5999 $NewInit_Desc{"FoundationType_Type"} = "Array"; 6000 $NewInit_Desc{"TypeType_Changed"} = 1; 6001 $NewInit_Desc{"TypeId"} = get_TypeIdByName("char*"); 6002 $NewInit_Desc{"TypeId_Changed"} = $TypeId; 6003 } 6004 elsif($FoundationTypeType eq "Intrinsic") 6005 { 6006 if($PointerLevel==1 and $ParamName=~/matrix/i) 6007 { 6008 $NewInit_Desc{"FoundationType_Type"} = "Array"; 6009 $NewInit_Desc{"TypeType_Changed"} = 1; 6010 $NewInit_Desc{"ArraySize"} = 16; 6011 } 6012 elsif(isIntegerType($FoundationTypeName)) 6013 { 6014 if($PointerLevel==0) 6015 { 6016 if($Init_Desc{"RetVal"} 6017 and $CurrentBlock=~/read/i) { 6018 $NewInit_Desc{"Value"} = "0"; 6019 } 6020 elsif($Init_Desc{"RetVal"} 6021 and $TypeName=~/err/i) { 6022 $NewInit_Desc{"Value"} = "1"; 6023 } 6024 elsif($ParamName=~/socket|block/i) { 6025 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6026 } 6027 elsif($ParamName=~/freq/i) { 6028 $NewInit_Desc{"Value"} = vary_values(["50"], \%Init_Desc); 6029 } 6030 elsif(lc($ParamName) eq "id") { 6031 $NewInit_Desc{"Value"} = "0"; 6032 } 6033 elsif($ParamName=~/verbose/i) { 6034 $NewInit_Desc{"Value"} = vary_values(["0", "1"], \%Init_Desc); 6035 } 6036 elsif($ParamName=~/year/i 6037 or ($ParamName eq "y" and $I_ShortName=~/date/i)) { 6038 $NewInit_Desc{"Value"} = vary_values(["2009", "2010"], \%Init_Desc); 6039 } 6040 elsif($ParamName eq "sa_family" 6041 and get_TypeName($Init_Desc{"OuterType_Id"}) eq "struct sockaddr") { 6042 $NewInit_Desc{"Value"} = vary_values(["AF_INET", "AF_INET6"], \%Init_Desc); 6043 } 6044 elsif($ParamName=~/day/i or ($ParamName eq "d" and $I_ShortName=~/date/i)) { 6045 $NewInit_Desc{"Value"} = vary_values(["30", "17"], \%Init_Desc); 6046 } 6047 elsif($ParamName=~/month/i 6048 or ($ParamName eq "m" and $I_ShortName=~/date/i)) { 6049 $NewInit_Desc{"Value"} = vary_values(["11", "10"], \%Init_Desc); 6050 } 6051 elsif($ParamName=~/\Ac\Z/i and $I_ShortName=~/char/i) { 6052 $NewInit_Desc{"Value"} = vary_values([get_CharNum()], \%Init_Desc); 6053 } 6054 elsif($ParamName=~/n_param_values/i) { 6055 $NewInit_Desc{"Value"} = vary_values(["2"], \%Init_Desc); 6056 } 6057 elsif($ParamName=~/debug/i) { 6058 $NewInit_Desc{"Value"} = vary_values(["0", "1"], \%Init_Desc); 6059 } 6060 elsif($ParamName=~/hook/i) 6061 { 6062 $NewInit_Desc{"Value"} = vary_values(["128"], \%Init_Desc); 6063 } 6064 elsif($ParamName=~/size|len|count/i 6065 and $I_ShortName=~/char|string/i) { 6066 $NewInit_Desc{"Value"} = vary_values(["7"], \%Init_Desc); 6067 } 6068 elsif($ParamName=~/size|len|capacity|count|max|(\A(n|l|s|c)_)/i) { 6069 $NewInit_Desc{"Value"} = vary_values([$DEFAULT_ARRAY_AMOUNT], \%Init_Desc); 6070 } 6071 elsif($ParamName=~/time/i and $ParamName=~/req/i) { 6072 $NewInit_Desc{"Value"} = vary_values([$HANGED_EXECUTION_TIME], \%Init_Desc); 6073 } 6074 elsif($ParamName=~/time/i 6075 or ($ParamName=~/len/i and $ParamName!~/error/i)) { 6076 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6077 } 6078 elsif($ParamName=~/depth/i) { 6079 $NewInit_Desc{"Value"} = vary_values(["1"], \%Init_Desc); 6080 } 6081 elsif($ParamName=~/delay/i) { 6082 $NewInit_Desc{"Value"} = vary_values(["0", "1"], \%Init_Desc); 6083 } 6084 elsif($TypeName=~/(count|size)_t/i 6085 and $ParamName=~/items/) { 6086 $NewInit_Desc{"Value"} = vary_values([$DEFAULT_ARRAY_AMOUNT], \%Init_Desc); 6087 } 6088 elsif($ParamName=~/exists|start/i) { 6089 $NewInit_Desc{"Value"} = vary_values(["0", "1"], \%Init_Desc); 6090 } 6091 elsif($ParamName=~/make/i) { 6092 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6093 } 6094 elsif($ParamName=~/\A(n|l|s|c)[0-9_]*\Z/i 6095 # gsl_vector_complex_float_alloc (size_t const n) 6096 # gsl_matrix_complex_float_alloc (size_t const n1, size_t const n2) 6097 or (is_alloc_func($I_ShortName) and $ParamName=~/(num|len)[0-9_]*/i)) 6098 { 6099 if($I_ShortName=~/column/) { 6100 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6101 } 6102 else { 6103 $NewInit_Desc{"Value"} = vary_values([$DEFAULT_ARRAY_AMOUNT], \%Init_Desc); 6104 } 6105 } 6106 elsif($Init_Desc{"OuterType_Type"} eq "Array" 6107 and $Init_Desc{"Index"} ne "") { 6108 $NewInit_Desc{"Value"} = vary_values([$Init_Desc{"Index"}], \%Init_Desc); 6109 } 6110 elsif(($ParamName=~/index|from|pos|field|line|column|row/i and $ParamName!~/[a-z][a-rt-z]s\Z/i) 6111 or $ParamName=~/\A(i|j|k|icol)\Z/i) 6112 { # gsl_vector_complex_float_get (gsl_vector_complex_float const* v, size_t const i) 6113 if($Init_Desc{"OuterType_Type"} eq "Array") { 6114 $NewInit_Desc{"Value"} = vary_values([$Init_Desc{"Index"}], \%Init_Desc); 6115 } 6116 else { 6117 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6118 } 6119 } 6120 elsif($TypeName=~/bool/i) { 6121 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6122 } 6123 elsif($ParamName=~/with/i) { 6124 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6125 } 6126 elsif($ParamName=~/sign/i) { 6127 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6128 } 6129 elsif($ParamName=~/endian|order/i) { 6130 $NewInit_Desc{"Value"} = vary_values(["1", "0"], \%Init_Desc); 6131 } 6132 elsif($ParamName=~/\A(w|width)\d*\Z/i 6133 and $I_ShortName=~/display/i) { 6134 $NewInit_Desc{"Value"} = vary_values(["640"], \%Init_Desc); 6135 } 6136 elsif($ParamName=~/\A(h|height)\d*\Z/i 6137 and $I_ShortName=~/display/i) { 6138 $NewInit_Desc{"Value"} = vary_values(["480"], \%Init_Desc); 6139 } 6140 elsif($ParamName=~/width|height/i 6141 or $ParamName=~/\A(x|y|z|w|h)\d*\Z/i) { 6142 $NewInit_Desc{"Value"} = vary_values([8 * getIntrinsicValue($FoundationTypeName)], \%Init_Desc); 6143 } 6144 elsif($ParamName=~/offset/i) { 6145 $NewInit_Desc{"Value"} = vary_values(["8", "16"], \%Init_Desc); 6146 } 6147 elsif($ParamName=~/stride|step|spacing|iter|interval|move/i 6148 or $ParamName=~/\A(to)\Z/) { 6149 $NewInit_Desc{"Value"} = vary_values(["1"], \%Init_Desc); 6150 } 6151 elsif($ParamName=~/channels|frames/i and $I_ShortName=~/\Asnd_/i) 6152 { # ALSA 6153 $NewInit_Desc{"Value"} = vary_values([$DEFAULT_ARRAY_AMOUNT], \%Init_Desc); 6154 } 6155 elsif($ParamName=~/first/i and ($Init_Desc{"OuterType_Type"} eq "Struct" and get_TypeName($Init_Desc{"OuterType_Id"})=~/_snd_/i)) 6156 { # ALSA 6157 $NewInit_Desc{"Value"} = vary_values([8 * getIntrinsicValue($FoundationTypeName)], \%Init_Desc); 6158 } 6159 elsif(isFD($TypeId, $ParamName)) 6160 { 6161 $NewInit_Desc{"Value"} = vary_values(["open(TG_TEST_DATA_PLAIN_FILE, O_RDWR)"], \%Init_Desc); 6162 $NewInit_Desc{"Headers"} = addHeaders(["sys/stat.h", "fcntl.h"], $NewInit_Desc{"Headers"}); 6163 $AuxHeaders{"sys/stat.h"}=1; 6164 $NewInit_Desc{"InLine"}=0; 6165 $AuxHeaders{"fcntl.h"}=1; 6166 $FuncNames{"open"} = 1; 6167 } 6168 elsif(($TypeName=~/enum/i or $ParamName=~/message_type/i) 6169 and my $EnumConstant = selectConstant($TypeName, $ParamName, $Interface)) 6170 { # or ($TypeName eq "int" and $ParamName=~/\Amode|type\Z/i and $I_ShortName=~/\Asnd_/i) or $ParamName=~/mask/ 6171 $NewInit_Desc{"Value"} = vary_values([$EnumConstant], \%Init_Desc); 6172 $NewInit_Desc{"Headers"} = addHeaders([$Constants{$EnumConstant}{"Header"}], $NewInit_Desc{"Headers"}); 6173 } 6174 elsif($TypeName=~/enum/i 6175 or $ParamName=~/mode|type|flag|option/i) { 6176 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6177 } 6178 elsif($ParamName=~/mask|alloc/i) { 6179 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6180 } 6181 elsif($ParamName=~/screen|format/i) { 6182 $NewInit_Desc{"Value"} = vary_values(["1"], \%Init_Desc); 6183 } 6184 elsif($ParamName=~/ed\Z/i) { 6185 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6186 } 6187 elsif($ParamName=~/key/i 6188 and $I_ShortName=~/\A[_]*X/) 6189 { #X11 6190 $NewInit_Desc{"Value"} = vary_values(["9"], \%Init_Desc); 6191 } 6192 elsif($ParamName=~/\Ap\d+\Z/ 6193 and $Init_Desc{"ParamPos"}==$Init_Desc{"MaxParamPos"} 6194 and $I_ShortName=~/create|intern|privat/i) { 6195 $NewInit_Desc{"Value"} = vary_values(["0"], \%Init_Desc); 6196 } 6197 elsif($TypeName=~/size/i) { 6198 $NewInit_Desc{"Value"} = vary_values([$DEFAULT_ARRAY_AMOUNT], \%Init_Desc); 6199 } 6200 else { 6201 $NewInit_Desc{"Value"} = vary_values([getIntrinsicValue($FoundationTypeName)], \%Init_Desc); 6202 } 6203 } 6204 else { 6205 $NewInit_Desc{"Value"} = "0"; 6206 } 6207 } 6208 elsif(isCharType($FoundationTypeName) 6209 and $TypeName=~/bool/i) { 6210 $NewInit_Desc{"Value"} = vary_values([1, 0], \%Init_Desc); 6211 } 6212 else { 6213 $NewInit_Desc{"Value"} = vary_values([getIntrinsicValue($FoundationTypeName)], \%Init_Desc); 6214 } 6215 $NewInit_Desc{"ValueTypeId"} = ($PointerLevel==0)?$TypeId:$FoundationTypeId; 6216 } 6217 elsif($FoundationTypeType eq "Enum") 6218 { 6219 if(my $EnumMember = getSomeEnumMember($FoundationTypeId)) 6220 { 6221 if(defined $Template2Code and $PointerLevel==0) 6222 { 6223 my $Members = []; 6224 foreach my $Member (@{getEnumMembers($FoundationTypeId)}) 6225 { 6226 if(is_valid_constant($Member)) { 6227 push(@{$Members}, $Member); 6228 } 6229 } 6230 if($#{$Members}>=0) { 6231 $NewInit_Desc{"Value"} = vary_values($Members, \%Init_Desc); 6232 } 6233 else { 6234 $NewInit_Desc{"Value"} = vary_values(getEnumMembers($FoundationTypeId), \%Init_Desc); 6235 } 6236 } 6237 else { 6238 $NewInit_Desc{"Value"} = $EnumMember; 6239 } 6240 } 6241 else { 6242 $NewInit_Desc{"Value"} = "0"; 6243 } 6244 $NewInit_Desc{"ValueTypeId"} = $FoundationTypeId; 6245 } 6246 } 6247 else 6248 { 6249 if(not $NewInit_Desc{"ValueTypeId"}) 6250 { # for union spectypes 6251 $NewInit_Desc{"ValueTypeId"} = $TypeId; 6252 } 6253 } 6254 if($NewInit_Desc{"Value"} eq "") 6255 { 6256 $NewInit_Desc{"Value"} = "no value"; 6257 } 6258 return %NewInit_Desc; 6259} 6260 6261sub is_valid_constant($) 6262{ 6263 my $Constant = $_[0]; 6264 return $Constant!~/(unknown|invalid|null|err|none|(_|\A)(ms|win\d*|no)(_|\Z))/i; 6265} 6266 6267sub get_CharNum() 6268{ 6269 $IntrinsicNum{"Char"}=64 if($IntrinsicNum{"Char"} > 89 or $IntrinsicNum{"Char"} < 64); 6270 if($RandomCode) { 6271 $IntrinsicNum{"Char"} = 64+int(rand(25)); 6272 } 6273 $IntrinsicNum{"Char"}+=1; 6274 return $IntrinsicNum{"Char"}; 6275} 6276 6277sub vary_values($$) 6278{ 6279 my ($ValuesArrayRef, $Init_Desc) = @_; 6280 my @ValuesArray = @{$ValuesArrayRef}; 6281 return "" if($#ValuesArray==-1); 6282 if(defined $Template2Code and ($Init_Desc->{"Interface"} eq $TestedInterface) and not $Init_Desc->{"OuterType_Type"} and length($Init_Desc->{"ParamName"})>=2 and $Init_Desc->{"ParamName"}!~/\Ap\d+\Z/i) 6283 { 6284 my $Define = uc($Init_Desc->{"ParamName"}); 6285 if(defined $Constants{$Define}) { 6286 $Define = "_".$Define; 6287 } 6288 $Define = select_var_name($Define, ""); 6289 $Block_Variable{$CurrentBlock}{$Define} = 1; 6290 my $DefineWithNum = keys(%Template2Code_Defines).":".$Define; 6291 if($#ValuesArray>=1) { 6292 $Template2Code_Defines{$DefineWithNum} = "SET(".$ValuesArray[0]."; ".$ValuesArray[1].")"; 6293 } 6294 else { 6295 $Template2Code_Defines{$DefineWithNum} = $ValuesArray[0]; 6296 } 6297 return $Define; 6298 } 6299 else 6300 { # standalone 6301 return $ValuesArray[0]; 6302 } 6303} 6304 6305sub selectConstant($$$) 6306{ 6307 my ($TypeName, $ParamName, $Interface) = @_; 6308 return $Cache{"selectConstant"}{$TypeName}{$ParamName}{$Interface} if(defined $Cache{"selectConstant"}{$TypeName}{$ParamName}{$Interface}); 6309 my @Csts = (); 6310 foreach (keys(%Constants)) 6311 { 6312 if($Constants{$_}{"Value"}=~/\A\d/) { 6313 push(@Csts, $_); 6314 } 6315 } 6316 @Csts = sort @Csts; 6317 @Csts = sort {length($a)<=>length($b)} @Csts; 6318 @Csts = sort {$CompleteSignature{$Interface}{"Header"} cmp $Constants{$a}{"HeaderName"}} @Csts; 6319 my (@Valid, @Invalid) = (); 6320 foreach (@Csts) 6321 { 6322 if(is_valid_constant($_)) { 6323 push(@Valid, $_); 6324 } 6325 else { 6326 push(@Invalid, $_); 6327 } 6328 } 6329 @Csts = (@Valid, @Invalid); 6330 sort_byName(\@Csts, $ParamName." ".$CompleteSignature{$Interface}{"ShortName"}." ".$TypeName, "Constants"); 6331 if($#Csts>=0) 6332 { 6333 $Cache{"selectConstant"}{$TypeName}{$ParamName}{$Interface} = $Csts[0]; 6334 return $Csts[0]; 6335 } 6336 else 6337 { 6338 $Cache{"selectConstant"}{$TypeName}{$ParamName}{$Interface} = ""; 6339 return ""; 6340 } 6341} 6342 6343sub isFD($$) 6344{ 6345 my ($TypeId, $ParamName) = @_; 6346 my $FoundationTypeId = get_FoundationTypeId($TypeId); 6347 my $FoundationTypeName = get_TypeName($FoundationTypeId); 6348 if($ParamName=~/(\A|[_]+)fd(s|)\Z/i 6349 and isIntegerType($FoundationTypeName)) { 6350 return (-f "/usr/include/sys/stat.h" and -f "/usr/include/fcntl.h"); 6351 } 6352 else { 6353 return ""; 6354 } 6355} 6356 6357sub find_similar_type($$) 6358{ 6359 my ($TypeId, $ParamName) = @_; 6360 return 0 if(not $TypeId or not $ParamName); 6361 return 0 if($ParamName=~/\A(p\d+|data|object)\Z/i or length($ParamName)<=2 or is_out_word($ParamName)); 6362 return $Cache{"find_similar_type"}{$TypeId}{$ParamName} if(defined $Cache{"find_similar_type"}{$TypeId}{$ParamName} and not defined $AuxType{$TypeId}); 6363 my $PointerLevel = get_PointerLevel($TypeId); 6364 $ParamName=~s/([a-z][a-df-rt-z])s\Z/$1/i; 6365 my @TypeNames = (); 6366 foreach my $TypeName (keys(%StructUnionPName_Tid)) 6367 { 6368 if($TypeName=~/\Q$ParamName\E/i) 6369 { 6370 my $Tid = $StructUnionPName_Tid{$TypeName}; 6371 next if(not $Tid); 6372 my $FTid = get_FoundationTypeId($Tid); 6373 next if(get_TypeType($FTid)!~/\A(Struct|Union)\Z/); 6374 next if(isOpaque($FTid) and not keys(%{$ReturnTypeId_Interface{$Tid}})); 6375 next if(get_PointerLevel($Tid)!=$PointerLevel); 6376 push(@TypeNames, $TypeName); 6377 } 6378 } 6379 @TypeNames = sort {lc($a) cmp lc($b)} @TypeNames; 6380 @TypeNames = sort {length($a)<=>length($b)} @TypeNames; 6381 @TypeNames = sort {$a=~/\*/<=>$b=~/\*/} @TypeNames; 6382 # @TypeNames = sort {keys(%{$ReturnTypeId_Interface{$TName_Tid{$b}}})<=>keys(%{$ReturnTypeId_Interface{$TName_Tid{$a}}})} @TypeNames; 6383 if($#TypeNames>=0) 6384 { 6385 $Cache{"find_similar_type"}{$TypeId}{$ParamName} = $TName_Tid{$TypeNames[0]}; 6386 return $StructUnionPName_Tid{$TypeNames[0]}; 6387 } 6388 else 6389 { 6390 $Cache{"find_similar_type"}{$TypeId}{$ParamName} = 0; 6391 return 0; 6392 } 6393} 6394 6395sub isCyclical($$) 6396{ 6397 return (grep {$_ eq $_[1]} @{$_[0]}); 6398} 6399 6400sub convertTypes(@) 6401{ 6402 my %Conv = @_; 6403 return () if(not $Conv{"OutputTypeId"} or not $Conv{"InputTypeName"} or not $Conv{"Value"} or not $Conv{"Key"}); 6404 my $OutputType_PointerLevel = get_PointerLevel($Conv{"OutputTypeId"}); 6405 my $OutputType_Name = get_TypeName($Conv{"OutputTypeId"}); 6406 my $OutputFType_Id = get_FoundationTypeId($Conv{"OutputTypeId"}); 6407 my $OutputType_BaseTypeType = get_TypeType($OutputFType_Id); 6408 my $PLevelDelta = $OutputType_PointerLevel - $Conv{"InputPointerLevel"}; 6409 return ($Conv{"Value"}, "") if($OutputType_Name eq "..."); 6410 my $Tmp_Var = $Conv{"Key"}; 6411 $Tmp_Var .= ($Conv{"Destination"} eq "Target")?"_tp":"_p"; 6412 my $NeedTypeConvertion = 0; 6413 my ($Preamble, $ToCall) = (); 6414 # pointer convertion 6415 if($PLevelDelta==0) { 6416 $ToCall = $Conv{"Value"}; 6417 } 6418 elsif($PLevelDelta==1) 6419 { 6420 if($Conv{"Value"}=~/\A\&/) 6421 { 6422 $Preamble .= $Conv{"InputTypeName"}." $Tmp_Var = (".$Conv{"InputTypeName"}.")".$Conv{"Value"}.";\n"; 6423 $Block_Variable{$CurrentBlock}{$Tmp_Var} = 1; 6424 $ToCall = "&".$Tmp_Var; 6425 } 6426 else { 6427 $ToCall = "&".$Conv{"Value"}; 6428 } 6429 } 6430 elsif($PLevelDelta<0) 6431 { 6432 foreach (0 .. - 1 - $PLevelDelta) { 6433 $ToCall = $ToCall."*"; 6434 } 6435 $ToCall = $ToCall.$Conv{"Value"}; 6436 } 6437 else 6438 { # this section must be deprecated in future 6439 my $Stars = "**"; 6440 if($Conv{"Value"}=~/\A\&/) 6441 { 6442 $Preamble .= $Conv{"InputTypeName"}." $Tmp_Var = (".$Conv{"InputTypeName"}.")".$Conv{"Value"}.";\n"; 6443 $Block_Variable{$CurrentBlock}{$Tmp_Var} = 1; 6444 $Conv{"Value"} = $Tmp_Var; 6445 $Tmp_Var .= "p"; 6446 } 6447 $Preamble .= $Conv{"InputTypeName"}." *$Tmp_Var = (".$Conv{"InputTypeName"}." *)&".$Conv{"Value"}.";\n"; 6448 $Block_Variable{$CurrentBlock}{$Tmp_Var} = 1; 6449 my $Tmp_Var_Pre = $Tmp_Var; 6450 foreach my $Itr (1 .. $PLevelDelta - 1) 6451 { 6452 $Tmp_Var .= "p"; 6453 $Block_Variable{$CurrentBlock}{$Tmp_Var} = 1; 6454 $Preamble .= $Conv{"InputTypeName"}." $Stars$Tmp_Var = &$Tmp_Var_Pre;\n"; 6455 $Stars .= "*"; 6456 $NeedTypeConvertion = 1; 6457 $Tmp_Var_Pre = $Tmp_Var; 6458 $ToCall = $Tmp_Var; 6459 } 6460 } 6461 $Preamble .= "\n" if($Preamble); 6462 6463 $NeedTypeConvertion = 1 if(get_base_type_name($OutputType_Name) ne get_base_type_name($Conv{"InputTypeName"})); 6464 $NeedTypeConvertion = 1 if(not is_equal_types($OutputType_Name,$Conv{"InputTypeName"}) and $PLevelDelta==0); 6465 $NeedTypeConvertion = 1 if(not is_const_type($OutputType_Name) and is_const_type($Conv{"InputTypeName"})); 6466 $NeedTypeConvertion = 0 if(($OutputType_PointerLevel eq 0) and (($OutputType_BaseTypeType eq "Class") or ($OutputType_BaseTypeType eq "Struct"))); 6467 $NeedTypeConvertion = 1 if((($OutputType_Name=~/\&/) or $Conv{"MustConvert"}) and ($OutputType_PointerLevel > 0) and (($OutputType_BaseTypeType eq "Class") or ($OutputType_BaseTypeType eq "Struct"))); 6468 $NeedTypeConvertion = 1 if($OutputType_PointerLevel eq 2); 6469 $NeedTypeConvertion = 0 if($OutputType_Name eq $Conv{"InputTypeName"}); 6470 $NeedTypeConvertion = 0 if(uncover_typedefs($OutputType_Name)=~/\[(\d+|)\]/); # arrays 6471 $NeedTypeConvertion = 0 if(isAnon($OutputType_Name)); 6472 6473 # type convertion 6474 if($NeedTypeConvertion and ($Conv{"Destination"} eq "Param")) 6475 { 6476 if($ToCall=~/\-\>/) { 6477 $ToCall = "(".$OutputType_Name.")"."(".$ToCall.")"; 6478 } 6479 else { 6480 $ToCall = "(".$OutputType_Name.")".$ToCall; 6481 } 6482 } 6483 return ($ToCall, $Preamble); 6484} 6485 6486sub sortTypes_ByPLevel($$) 6487{ 6488 my ($Types, $PLevel) = @_; 6489 my (@Eq, @Lt, @Gt) = (); 6490 foreach my $TypeId (@{$Types}) 6491 { 6492 my $Type_PLevel = get_PointerLevel($TypeId); 6493 if($Type_PLevel==$PLevel) { 6494 push(@Eq, $TypeId); 6495 } 6496 elsif($Type_PLevel<$PLevel) { 6497 push(@Lt, $TypeId); 6498 } 6499 elsif($Type_PLevel>$PLevel) { 6500 push(@Gt, $TypeId); 6501 } 6502 } 6503 @{$Types} = (@Eq, @Lt, @Gt); 6504} 6505 6506sub familyTypes($) 6507{ 6508 my $TypeId = $_[0]; 6509 return [] if(not $TypeId); 6510 my $FoundationTypeId = get_FoundationTypeId($TypeId); 6511 return $Cache{"familyTypes"}{$TypeId} if($Cache{"familyTypes"}{$TypeId} and not defined $AuxType{$TypeId}); 6512 my (@FamilyTypes_Const, @FamilyTypes_NotConst) = (); 6513 foreach my $Tid (sort {int($a)<=>int($b)} keys(%TypeInfo)) 6514 { 6515 if((get_FoundationTypeId($Tid) eq $FoundationTypeId) and ($Tid ne $TypeId)) 6516 { 6517 if(is_const_type(get_TypeName($Tid))) { 6518 @FamilyTypes_Const = (@FamilyTypes_Const, $Tid); 6519 } 6520 else { 6521 @FamilyTypes_NotConst = (@FamilyTypes_NotConst, $Tid); 6522 } 6523 } 6524 } 6525 sortTypes_ByPLevel(\@FamilyTypes_Const, get_PointerLevel($TypeId)); 6526 sortTypes_ByPLevel(\@FamilyTypes_NotConst, get_PointerLevel($TypeId)); 6527 my @FamilyTypes = ((is_const_type(get_TypeName($TypeId)))?(@FamilyTypes_NotConst, $TypeId, @FamilyTypes_Const):($TypeId, @FamilyTypes_NotConst, @FamilyTypes_Const)); 6528 $Cache{"familyTypes"}{$TypeId} = \@FamilyTypes; 6529 return \@FamilyTypes; 6530} 6531 6532sub register_ExtType($$$) 6533{ 6534 my ($Type_Name, $Type_Type, $BaseTypeId) = @_; 6535 return "" if(not $Type_Name or not $Type_Type or not $BaseTypeId); 6536 return $TName_Tid{$Type_Name} if($TName_Tid{$Type_Name}); 6537 $MaxTypeId += 1; 6538 $TName_Tid{$Type_Name} = $MaxTypeId; 6539 %{$TypeInfo{$MaxTypeId}}=( 6540 "Name" => $Type_Name, 6541 "Type" => $Type_Type, 6542 "BaseType" => $BaseTypeId, 6543 "Tid" => $MaxTypeId, 6544 "Headers"=>getTypeHeaders($BaseTypeId) 6545 ); 6546 $AuxType{$MaxTypeId} = $Type_Name; 6547 return $MaxTypeId; 6548} 6549 6550 6551sub get_ExtTypeId($$) 6552{ 6553 my ($Key, $TypeId) = @_; 6554 return () if(not $TypeId); 6555 my ($Declarations, $Headers) = ("", []); 6556 if(get_TypeType($TypeId) eq "Typedef") { 6557 return ($TypeId, "", ""); 6558 } 6559 my $FTypeId = get_FoundationTypeId($TypeId); 6560 my %BaseType = goToFirst($TypeId, "Typedef"); 6561 my $BaseTypeId = $BaseType{"Tid"}; 6562 if(not $BaseTypeId) 6563 { 6564 $BaseTypeId = $FTypeId; 6565 if(get_TypeName($BaseTypeId)=~/\Astd::/) 6566 { 6567 if(my $CxxTypedefId = get_type_typedef($BaseTypeId)) { 6568 $BaseTypeId = $CxxTypedefId; 6569 } 6570 } 6571 } 6572 my $PointerLevel = get_PointerLevel($TypeId) - get_PointerLevel($BaseTypeId); 6573 if(get_TypeType($FTypeId) eq "Array") 6574 { 6575 my ($Array_BaseName, $Array_Length) = reassemble_array($FTypeId); 6576 $BaseTypeId = get_TypeIdByName($Array_BaseName); 6577 $PointerLevel+=1; 6578 } 6579 my $BaseTypeName = get_TypeName($BaseTypeId); 6580 my $BaseTypeType = get_TypeType($BaseTypeId); 6581 if($BaseTypeType eq "FuncPtr") { 6582 $Declarations .= declare_funcptr_typedef($Key, $BaseTypeId); 6583 } 6584 if(isAnon($BaseTypeName)) 6585 { 6586 if($BaseTypeType eq "Struct") 6587 { 6588 my ($AnonStruct_Declarations, $AnonStruct_Headers) = declare_anon_struct($Key, $BaseTypeId); 6589 $Declarations .= $AnonStruct_Declarations; 6590 $Headers = addHeaders($AnonStruct_Headers, $Headers); 6591 } 6592 elsif($BaseTypeType eq "Union") 6593 { 6594 my ($AnonUnion_Declarations, $AnonUnion_Headers) = declare_anon_union($Key, $BaseTypeId); 6595 $Declarations .= $AnonUnion_Declarations; 6596 $Headers = addHeaders($AnonUnion_Headers, $Headers); 6597 } 6598 } 6599 if($PointerLevel>=1) 6600 { 6601# if(get_TypeType(get_FoundationTypeId($TypeId)) eq "FuncPtr" and get_TypeName($TypeId)=~/\A[^*]+const\W/) 6602# { 6603# $BaseTypeId = register_ExtType(get_TypeName($BaseTypeId)." const", "Const", $BaseTypeId); 6604# } 6605 6606 my $ExtTypeId = register_new_type($BaseTypeId, $PointerLevel); 6607 return ($ExtTypeId, $Declarations, $Headers); 6608 } 6609 else { 6610 return ($BaseTypeId, $Declarations, $Headers); 6611 } 6612} 6613 6614sub register_new_type($$) 6615{ 6616 my ($BaseTypeId, $PLevel) = @_; 6617 my $ExtTypeName = get_TypeName($BaseTypeId); 6618 my $ExtTypeId = $BaseTypeId; 6619 foreach (1 .. $PLevel) 6620 { 6621 $ExtTypeName .= "*"; 6622 $ExtTypeName = formatName($ExtTypeName, "T"); 6623 if(not $TName_Tid{$ExtTypeName}) { 6624 register_ExtType($ExtTypeName, "Pointer", $ExtTypeId); 6625 } 6626 $ExtTypeId = $TName_Tid{$ExtTypeName}; 6627 } 6628 return $ExtTypeId; 6629} 6630 6631sub correct_init_stmt($$$) 6632{ 6633 my ($String, $TypeName, $ParamName) = @_; 6634 my $Stmt = $TypeName." ".$ParamName." = ".$TypeName; 6635 if($String=~/\Q$Stmt\E\:\:/) { 6636 return $String; 6637 } 6638 else 6639 { 6640 $String=~s/(\W|\A)\Q$Stmt\E\(\)(\W|\Z)/$1$TypeName $ParamName$2/g; 6641 $String=~s/(\W|\A)\Q$Stmt\E(\W|\Z)/$1$TypeName $ParamName$2/g; 6642 return $String; 6643 } 6644} 6645 6646sub isValidConv($) 6647{ 6648 return ($_[0]!~/\A(__va_list_tag|...)\Z/); 6649} 6650 6651sub emptyDeclaration(@) 6652{ 6653 my %Init_Desc = @_; 6654 my %Type_Init = (); 6655 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 6656 my $Var = $Init_Desc{"Var"}; 6657 my $InitTypeId = $Init_Desc{"ValueTypeId"}; 6658 if(not $InitTypeId) { 6659 $InitTypeId = $Init_Desc{"TypeId"}; 6660 } 6661 my $InitializedType_PLevel = get_PointerLevel($InitTypeId); 6662 my ($ETypeId, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $InitTypeId); 6663 my $InitializedType_Name = get_TypeName($ETypeId); 6664 if($InitializedType_Name eq "void") { 6665 $InitializedType_Name = "int"; 6666 } 6667 $Type_Init{"Code"} .= $Declarations; 6668 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 6669 $Type_Init{"Headers"} = addHeaders($Headers, getTypeHeaders($ETypeId)); 6670 $Type_Init{"Headers"} = addHeaders($Headers, getTypeHeaders(get_FoundationTypeId($ETypeId))) if($InitializedType_PLevel==0); 6671 $Type_Init{"Init"} = $InitializedType_Name." ".$Var.";\n"; 6672 $Block_Variable{$CurrentBlock}{$Var} = 1; 6673 # create call 6674 my ($Call, $Preamble) = convertTypes(( 6675 "InputTypeName"=>$InitializedType_Name, 6676 "InputPointerLevel"=>$InitializedType_PLevel, 6677 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6678 "Value"=>$Var, 6679 "Key"=>$Var, 6680 "Destination"=>"Param", 6681 "MustConvert"=>0)); 6682 $Type_Init{"Init"} .= $Preamble; 6683 $Type_Init{"Call"} = $Call; 6684 # call to constraint 6685 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 6686 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 6687 } 6688 else 6689 { 6690 my ($TargetCall, $TargetPreamble) = 6691 convertTypes(( 6692 "InputTypeName"=>$InitializedType_Name, 6693 "InputPointerLevel"=>$InitializedType_PLevel, 6694 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 6695 "Value"=>$Var, 6696 "Key"=>$Var, 6697 "Destination"=>"Target", 6698 "MustConvert"=>0)); 6699 $Type_Init{"TargetCall"} = $TargetCall; 6700 $Type_Init{"Init"} .= $TargetPreamble; 6701 } 6702 $Type_Init{"IsCorrect"} = 1; 6703 return %Type_Init; 6704} 6705 6706sub initializeByValue(@) 6707{ 6708 my %Init_Desc = @_; 6709 return () if($Init_Desc{"DoNotAssembly"} and $Init_Desc{"ByNull"}); 6710 my %Type_Init = (); 6711 $Init_Desc{"InLine"} = 1 if($Init_Desc{"Value"}=~/\$\d+/); 6712 my $TName_Trivial = get_TypeName($Init_Desc{"TypeId"}); 6713 $TName_Trivial=~s/&//g; 6714 my $FoundationType_Id = get_FoundationTypeId($Init_Desc{"TypeId"}); 6715 # $Type_Init{"Headers"} = addHeaders(getTypeHeaders($FoundationType_Id), $Type_Init{"Headers"}); 6716 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Init_Desc{"TypeId"}), $Type_Init{"Headers"}); 6717 if(uncover_typedefs(get_TypeName($Init_Desc{"TypeId"}))=~/\&/ 6718 and $Init_Desc{"OuterType_Type"}=~/\A(Struct|Union|Array)\Z/) { 6719 $Init_Desc{"InLine"} = 0; 6720 } 6721 my $FoundationType_Name = get_TypeName($FoundationType_Id); 6722 my $FoundationType_Type = get_TypeType($FoundationType_Id); 6723 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 6724 my $Target_PointerLevel = get_PointerLevel($Init_Desc{"TargetTypeId"}); 6725 if($FoundationType_Name eq "...") 6726 { 6727 $PointerLevel = get_PointerLevel($Init_Desc{"ValueTypeId"}); 6728 $Target_PointerLevel = $PointerLevel; 6729 } 6730 my $Value_PointerLevel = get_PointerLevel($Init_Desc{"ValueTypeId"}); 6731 return () if(not $Init_Desc{"ValueTypeId"} or $Init_Desc{"Value"} eq ""); 6732 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 6733 my $Var = $Init_Desc{"Var"}; 6734 my ($Value_ETypeId, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ValueTypeId"}); 6735 my $Value_ETypeName = get_TypeName($Value_ETypeId); 6736 $Type_Init{"Code"} .= $Declarations; 6737 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 6738 if($FoundationType_Type eq "Class") 6739 { # classes 6740 my ($ChildCreated, $CallDestructor) = (0, 1); 6741 if(my $ValueClass = getValueClass($Init_Desc{"Value"}) and $Target_PointerLevel eq 0) 6742 { # class object construction by constructor in value 6743 if($FoundationType_Name eq $ValueClass) 6744 { 6745 if(isAbstractClass($FoundationType_Id) or $Init_Desc{"CreateChild"}) 6746 { # when don't know constructor in value, so declaring all in the child 6747 my $ChildClassName = getSubClassName($FoundationType_Name); 6748 my $FoundationChildName = getSubClassName($FoundationType_Name); 6749 $ChildCreated = 1; 6750 if($Init_Desc{"Value"}=~/\Q$FoundationType_Name\E/ 6751 and $Init_Desc{"Value"}!~/\Q$ChildClassName\E/) { 6752 substr($Init_Desc{"Value"}, index($Init_Desc{"Value"}, $FoundationType_Name), pos($FoundationType_Name) + length($FoundationType_Name)) = $FoundationChildName; 6753 } 6754 $IntSubClass{$TestedInterface}{$FoundationType_Id} = 1; 6755 $Create_SubClass{$FoundationType_Id} = 1; 6756 foreach my $ClassConstructor (getClassConstructors($FoundationType_Id)) { 6757 $UsedConstructors{$FoundationType_Id}{$ClassConstructor} = 1; 6758 } 6759 $FoundationType_Name = $ChildClassName; 6760 } 6761 } 6762 else 6763 { # new class 6764 $FoundationType_Name = $ValueClass; 6765 } 6766 if($Init_Desc{"InLine"} and ($PointerLevel eq 0)) 6767 { 6768 $Type_Init{"Call"} = $Init_Desc{"Value"}; 6769 $CallDestructor = 0; 6770 } 6771 else 6772 { 6773 $Block_Variable{$CurrentBlock}{$Var} = 1; 6774 if(not defined $DisableReuse) { 6775 $ValueCollection{$CurrentBlock}{$Var} = $FoundationType_Id; 6776 } 6777 $Type_Init{"Init"} .= $FoundationType_Name." $Var = ".$Init_Desc{"Value"}.";".($Init_Desc{"ByNull"}?" //can't initialize":"")."\n"; 6778 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($FoundationType_Id), $Type_Init{"Headers"}); 6779 $Type_Init{"Init"} = correct_init_stmt($Type_Init{"Init"}, $FoundationType_Name, $Var); 6780 my ($Call, $TmpPreamble) = 6781 convertTypes(( 6782 "InputTypeName"=>$FoundationType_Name, 6783 "InputPointerLevel"=>$Value_PointerLevel, 6784 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6785 "Value"=>$Var, 6786 "Key"=>$Var, 6787 "Destination"=>"Param", 6788 "MustConvert"=>0)); 6789 $Type_Init{"Init"} .= $TmpPreamble; 6790 $Type_Init{"Call"} = $Call; 6791 } 6792 } 6793 else 6794 { # class object returned by some interface in value 6795 if($Init_Desc{"CreateChild"}) 6796 { 6797 $ChildCreated = 1; 6798 my $FoundationChildName = getSubClassName($FoundationType_Name); 6799 my $TNameChild = $TName_Trivial; 6800 substr($Value_ETypeName, index($Value_ETypeName, $FoundationType_Name), pos($FoundationType_Name) + length($FoundationType_Name)) = $FoundationChildName; 6801 substr($TNameChild, index($TNameChild, $FoundationType_Name), pos($FoundationType_Name) + length($FoundationType_Name)) = $FoundationChildName; 6802 $IntSubClass{$TestedInterface}{$FoundationType_Id} = 1; 6803 $Create_SubClass{$FoundationType_Id} = 1; 6804 if($Value_PointerLevel==0 6805 and my $SomeConstructor = getSomeConstructor($FoundationType_Id)) { 6806 $UsedConstructors{$FoundationType_Id}{$SomeConstructor} = 1; 6807 } 6808 if($Init_Desc{"InLine"} and ($PointerLevel eq $Value_PointerLevel)) 6809 { 6810 if($Init_Desc{"Value"} eq "NULL" 6811 or $Init_Desc{"Value"} eq "0") { 6812 $Type_Init{"Call"} = "($TNameChild) ".$Init_Desc{"Value"}; 6813 } 6814 else 6815 { 6816 my ($Call, $TmpPreamble) = 6817 convertTypes(( 6818 "InputTypeName"=>get_TypeName($Init_Desc{"ValueTypeId"}), 6819 "InputPointerLevel"=>$Value_PointerLevel, 6820 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6821 "Value"=>$Init_Desc{"Value"}, 6822 "Key"=>$LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, 6823 "Destination"=>"Param", 6824 "MustConvert"=>1)); 6825 $Type_Init{"Call"} = $Call; 6826 $Type_Init{"Init"} .= $TmpPreamble; 6827 } 6828 $CallDestructor = 0; 6829 } 6830 else 6831 { 6832 $Block_Variable{$CurrentBlock}{$Var} = 1; 6833 if((not defined $DisableReuse and ($Init_Desc{"Value"} ne "NULL") and ($Init_Desc{"Value"} ne "0")) 6834 or $Init_Desc{"ByNull"} or $Init_Desc{"UseableValue"}) { 6835 $ValueCollection{$CurrentBlock}{$Var} = $Value_ETypeId; 6836 } 6837 $Type_Init{"Init"} .= $Value_ETypeName." $Var = ($Value_ETypeName)".$Init_Desc{"Value"}.";".($Init_Desc{"ByNull"}?" //can't initialize":"")."\n"; 6838 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Value_ETypeId), $Type_Init{"Headers"}); 6839 my ($Call, $TmpPreamble) = 6840 convertTypes(( 6841 "InputTypeName"=>$Value_ETypeName, 6842 "InputPointerLevel"=>$Value_PointerLevel, 6843 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6844 "Value"=>$Var, 6845 "Key"=>$Var, 6846 "Destination"=>"Param", 6847 "MustConvert"=>0)); 6848 $Type_Init{"Init"} .= $TmpPreamble; 6849 $Type_Init{"Call"} = $Call; 6850 } 6851 } 6852 else 6853 { 6854 if($Init_Desc{"InLine"} and $PointerLevel eq $Value_PointerLevel) 6855 { 6856 if($Init_Desc{"Value"} eq "NULL" 6857 or $Init_Desc{"Value"} eq "0") { 6858 $Type_Init{"Call"} = "($TName_Trivial) ".$Init_Desc{"Value"}; 6859 $CallDestructor = 0; 6860 } 6861 else 6862 { 6863 $CallDestructor = 0; 6864 my ($Call, $TmpPreamble) = 6865 convertTypes(( 6866 "InputTypeName"=>get_TypeName($Init_Desc{"ValueTypeId"}), 6867 "InputPointerLevel"=>$Value_PointerLevel, 6868 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6869 "Value"=>$Init_Desc{"Value"}, 6870 "Key"=>$LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, 6871 "Destination"=>"Param", 6872 "MustConvert"=>1)); 6873 $Type_Init{"Call"} = $Call; 6874 $Type_Init{"Init"} .= $TmpPreamble; 6875 } 6876 } 6877 else 6878 { 6879 $Block_Variable{$CurrentBlock}{$Var} = 1; 6880 if((not defined $DisableReuse and $Init_Desc{"Value"} ne "NULL" and $Init_Desc{"Value"} ne "0") 6881 or $Init_Desc{"ByNull"} or $Init_Desc{"UseableValue"}) { 6882 $ValueCollection{$CurrentBlock}{$Var} = $Value_ETypeId; 6883 } 6884 $Type_Init{"Init"} .= $Value_ETypeName." $Var = ".$Init_Desc{"Value"}.";".($Init_Desc{"ByNull"}?" //can't initialize":"")."\n"; 6885 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Value_ETypeId), $Type_Init{"Headers"}); 6886 my ($Call, $TmpPreamble) = 6887 convertTypes(( 6888 "InputTypeName"=>$Value_ETypeName, 6889 "InputPointerLevel"=>$Value_PointerLevel, 6890 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6891 "Value"=>$Var, 6892 "Key"=>$Var, 6893 "Destination"=>"Param", 6894 "MustConvert"=>0)); 6895 $Type_Init{"Init"} .= $TmpPreamble; 6896 $Type_Init{"Call"} = $Call; 6897 } 6898 } 6899 } 6900 6901 # create destructor call for class object 6902 if($CallDestructor and 6903 ((has_public_destructor($FoundationType_Id, "D2") and $ChildCreated) or 6904 (has_public_destructor($FoundationType_Id, "D0") and not $ChildCreated)) ) 6905 { 6906 if($Value_PointerLevel > 0) 6907 { 6908 if($Value_PointerLevel eq 1) { 6909 $Type_Init{"Destructors"} .= "delete($Var);\n"; 6910 } 6911 else 6912 { 6913 $Type_Init{"Destructors"} .= "delete("; 6914 foreach (0 .. $Value_PointerLevel - 2) { 6915 $Type_Init{"Destructors"} .= "*"; 6916 } 6917 $Type_Init{"Destructors"} .= $Var.");\n"; 6918 } 6919 } 6920 } 6921 } 6922 else 6923 { # intrinsics, structs 6924 if($Init_Desc{"InLine"} and ($PointerLevel eq $Value_PointerLevel)) 6925 { 6926 if(($Init_Desc{"Value"} eq "NULL") or ($Init_Desc{"Value"} eq "0")) 6927 { 6928 if((getSymLang($TestedInterface) eq "C++" or $Init_Desc{"StrongConvert"}) 6929 and isValidConv($TName_Trivial) and ($Init_Desc{"OuterType_Type"} ne "Array")) 6930 { 6931 $Type_Init{"Call"} = "($TName_Trivial) ".$Init_Desc{"Value"}; 6932 } 6933 else 6934 { 6935 $Type_Init{"Call"} = $Init_Desc{"Value"}; 6936 } 6937 } 6938 else 6939 { 6940 if((not is_equal_types(get_TypeName($Init_Desc{"TypeId"}), get_TypeName($Init_Desc{"ValueTypeId"})) or $Init_Desc{"StrongConvert"}) and isValidConv($TName_Trivial)) 6941 { 6942 $Type_Init{"Call"} = "($TName_Trivial) ".$Init_Desc{"Value"}; 6943 } 6944 else 6945 { 6946 $Type_Init{"Call"} = $Init_Desc{"Value"}; 6947 } 6948 } 6949 } 6950 else 6951 { 6952 $Block_Variable{$CurrentBlock}{$Var} = 1; 6953 if((not defined $DisableReuse and ($Init_Desc{"Value"} ne "NULL") and ($Init_Desc{"Value"} ne "0")) 6954 or $Init_Desc{"ByNull"} or $Init_Desc{"UseableValue"}) 6955 { 6956 $ValueCollection{$CurrentBlock}{$Var} = $Value_ETypeId; 6957 } 6958 $Type_Init{"Init"} .= $Value_ETypeName." $Var = ".$Init_Desc{"Value"}.";".($Init_Desc{"ByNull"}?" //can't initialize":"")."\n"; 6959 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Value_ETypeId), $Type_Init{"Headers"}); 6960 my ($Call, $TmpPreamble) = 6961 convertTypes(( 6962 "InputTypeName"=>$Value_ETypeName, 6963 "InputPointerLevel"=>$Value_PointerLevel, 6964 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 6965 "Value"=>$Var, 6966 "Key"=>$Var, 6967 "Destination"=>"Param", 6968 "MustConvert"=>$Init_Desc{"StrongConvert"})); 6969 $Type_Init{"Init"} .= $TmpPreamble; 6970 $Type_Init{"Call"} = $Call; 6971 } 6972 } 6973 # call to constraint 6974 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) 6975 { 6976 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 6977 } 6978 else 6979 { 6980 my ($TargetCall, $TargetPreamble) = 6981 convertTypes(( 6982 "InputTypeName"=>$Value_ETypeName, 6983 "InputPointerLevel"=>$Value_PointerLevel, 6984 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 6985 "Value"=>$Var, 6986 "Key"=>$Var, 6987 "Destination"=>"Target", 6988 "MustConvert"=>0)); 6989 $Type_Init{"TargetCall"} = $TargetCall; 6990 $Type_Init{"Init"} .= $TargetPreamble; 6991 } 6992 if(get_TypeType($Init_Desc{"TypeId"}) eq "Ref") 6993 { # ref handler 6994 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 6995 my $BaseRefName = get_TypeName($BaseRefId); 6996 if(get_PointerLevel($BaseRefId) > $Value_PointerLevel) 6997 { 6998 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 6999 $Type_Init{"Call"} = $Var."_ref"; 7000 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 7001 if(not defined $DisableReuse and ($Init_Desc{"Value"} ne "NULL") and ($Init_Desc{"Value"} ne "0")) 7002 { 7003 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 7004 } 7005 } 7006 } 7007 $Type_Init{"Code"} = $Type_Init{"Code"}; 7008 $Type_Init{"IsCorrect"} = 1; 7009 $Type_Init{"ByNull"} = 1 if($Init_Desc{"ByNull"}); 7010 return %Type_Init; 7011} 7012 7013sub remove_quals($) 7014{ 7015 my $Type_Name = $_[0]; 7016 $Type_Name=~s/ (const|volatile|restrict)\Z//g; 7017 $Type_Name=~s/\A(const|volatile|restrict) //g; 7018 while($Type_Name=~s/(\W|\A|>)(const|volatile|restrict)(\W([^<>()]+|)|)\Z/$1$3/g){}; 7019 return formatName($Type_Name, "T"); 7020} 7021 7022sub is_equal_types($$) 7023{ 7024 my ($Type1_Name, $Type2_Name) = @_; 7025 return (remove_quals(uncover_typedefs($Type1_Name)) eq 7026 remove_quals(uncover_typedefs($Type2_Name))); 7027} 7028 7029sub get_base_type_name($) 7030{ 7031 my $Type_Name = $_[0]; 7032 while($Type_Name=~s/(\*|\&)([^<>()]+|)\Z/$2/g){}; 7033 my $Type_Name = remove_quals(uncover_typedefs($Type_Name)); 7034 while($Type_Name=~s/(\*|\&)([^<>()]+|)\Z/$2/g){}; 7035 return $Type_Name; 7036} 7037 7038sub isIntegerType($) 7039{ 7040 my $TName = remove_quals(uncover_typedefs($_[0])); 7041 return 0 if($TName=~/[(<*]/); 7042 if($TName eq "bool") 7043 { 7044 return (getSymLang($TestedInterface) ne "C++"); 7045 } 7046 return ($TName=~/(\W|\A| )(int)(\W|\Z| )/ 7047 or $TName=~/\A(short|size_t|unsigned|long|long long|unsigned long|unsigned long long|unsigned short)\Z/); 7048} 7049 7050sub isCharType($) 7051{ 7052 my $TName = remove_quals(uncover_typedefs($_[0])); 7053 return 0 if($TName=~/[(<*]/); 7054 return ($TName=~/\A(char|unsigned char|signed char|wchar_t)\Z/); 7055} 7056 7057sub isNumericType($) 7058{ 7059 my $TName = uncover_typedefs($_[0]); 7060 return 0 if($TName=~/[(<*]/); 7061 if(isIntegerType($TName)) 7062 { 7063 return 1; 7064 } 7065 else 7066 { 7067 return ($TName=~/\A(float|double|long double|float const|double const|long double const)\Z/); 7068 } 7069} 7070 7071sub getIntrinsicValue($) 7072{ 7073 my $TypeName = $_[0]; 7074 $IntrinsicNum{"Char"}=64 if($IntrinsicNum{"Char"}>89 or $IntrinsicNum{"Char"}<64); 7075 $IntrinsicNum{"Int"}=0 if($IntrinsicNum{"Int"} >= 10); 7076 if($RandomCode) 7077 { 7078 $IntrinsicNum{"Char"} = 64+int(rand(25)); 7079 $IntrinsicNum{"Int"} = int(rand(5)); 7080 } 7081 if($TypeName eq "char*") 7082 { 7083 $IntrinsicNum{"Str"}+=1; 7084 if($IntrinsicNum{"Str"}==1) 7085 { 7086 return "\"str\""; 7087 } 7088 else 7089 { 7090 return "\"str".$IntrinsicNum{"Str"}."\""; 7091 } 7092 } 7093 elsif($TypeName=~/(\A| )char(\Z| )/) 7094 { 7095 $IntrinsicNum{"Char"} += 1; 7096 return "'".chr($IntrinsicNum{"Char"})."'"; 7097 } 7098 elsif($TypeName eq "wchar_t") 7099 { 7100 $IntrinsicNum{"Char"}+=1; 7101 return "L'".chr($IntrinsicNum{"Char"})."'"; 7102 } 7103 elsif($TypeName eq "wchar_t*") 7104 { 7105 $IntrinsicNum{"Str"}+=1; 7106 if($IntrinsicNum{"Str"}==1) 7107 { 7108 return "L\"str\""; 7109 } 7110 else 7111 { 7112 return "L\"str".$IntrinsicNum{"Str"}."\""; 7113 } 7114 } 7115 elsif($TypeName eq "wint_t") 7116 { 7117 $IntrinsicNum{"Int"}+=1; 7118 return "L".$IntrinsicNum{"Int"}; 7119 } 7120 elsif($TypeName=~/\A(long|long int)\Z/) 7121 { 7122 $IntrinsicNum{"Int"} += 1; 7123 return $IntrinsicNum{"Int"}."L"; 7124 } 7125 elsif($TypeName=~/\A(long long|long long int)\Z/) 7126 { 7127 $IntrinsicNum{"Int"} += 1; 7128 return $IntrinsicNum{"Int"}."LL"; 7129 } 7130 elsif(isIntegerType($TypeName)) 7131 { 7132 $IntrinsicNum{"Int"} += 1; 7133 return $IntrinsicNum{"Int"}; 7134 } 7135 elsif($TypeName eq "float") 7136 { 7137 $IntrinsicNum{"Float"} += 1; 7138 return $IntrinsicNum{"Float"}.".5f"; 7139 } 7140 elsif($TypeName eq "double") 7141 { 7142 $IntrinsicNum{"Float"} += 1; 7143 return $IntrinsicNum{"Float"}.".5"; 7144 } 7145 elsif($TypeName eq "long double") 7146 { 7147 $IntrinsicNum{"Float"} += 1; 7148 return $IntrinsicNum{"Float"}.".5L"; 7149 } 7150 elsif($TypeName eq "bool") 7151 { 7152 if(getSymLang($TestedInterface) eq "C++") { 7153 return "true"; 7154 } 7155 else { 7156 return "1"; 7157 } 7158 } 7159 else 7160 { # void, "..." and other 7161 return ""; 7162 } 7163} 7164 7165sub findInterface_OutParam($$$$$$) 7166{ 7167 my ($TypeId, $Key, $StrongTypeCompliance, $Var, $ParamName, $Strong) = @_; 7168 return () if(not $TypeId); 7169 foreach my $FamilyTypeId (get_OutParamFamily($TypeId, 1)) 7170 { 7171 foreach my $Interface (get_CompatibleInterfaces($FamilyTypeId, "OutParam", $ParamName)) 7172 { # find interface to create some type in the family as output parameter 7173 if($Strong) 7174 { 7175 foreach my $PPos (keys(%{$CompleteSignature{$Interface}{"Param"}})) 7176 { # only one possible structural out parameter 7177 my $PTypeId = $CompleteSignature{$Interface}{"Param"}{$PPos}{"type"}; 7178 my $P_FTypeId = get_FoundationTypeId($PTypeId); 7179 return () if(get_TypeType($P_FTypeId)!~/\A(Intrinsic|Enum)\Z/ 7180 and $P_FTypeId ne get_FoundationTypeId($FamilyTypeId) 7181 and not is_const_type(get_TypeName($PTypeId))); 7182 } 7183 } 7184 my $OutParam_Pos = $OutParam_Interface{$FamilyTypeId}{$Interface}; 7185 my %Interface_Init = callInterface(( 7186 "Interface"=>$Interface, 7187 "Key"=>$Key, 7188 "OutParam"=>$OutParam_Pos, 7189 "OutVar"=>$Var)); 7190 if($Interface_Init{"IsCorrect"}) 7191 { 7192 $Interface_Init{"Interface"} = $Interface; 7193 $Interface_Init{"OutParamPos"} = $OutParam_Pos; 7194 return %Interface_Init; 7195 } 7196 } 7197 } 7198 return (); 7199} 7200 7201sub findInterface(@) 7202{ 7203 my %Init_Desc = @_; 7204 my ($TypeId, $Key, $StrongTypeCompliance, $ParamName) = ($Init_Desc{"TypeId"}, $Init_Desc{"Key"}, $Init_Desc{"StrongTypeCompliance"}, $Init_Desc{"ParamName"}); 7205 return () if(not $TypeId); 7206 my @FamilyTypes = (); 7207 if($StrongTypeCompliance) 7208 { 7209 @FamilyTypes = ($TypeId); 7210 # try to initialize basic typedef 7211 my $BaseTypeId = $TypeId; 7212 $BaseTypeId = get_OneStep_BaseTypeId($TypeId) if(get_TypeType($BaseTypeId) eq "Const"); 7213 $BaseTypeId = get_OneStep_BaseTypeId($TypeId) if(get_TypeType($BaseTypeId) eq "Pointer"); 7214 if($BaseTypeId ne $TypeId) 7215 { 7216 if(get_TypeType($BaseTypeId) eq "Typedef") { 7217 push(@FamilyTypes, $BaseTypeId); 7218 } 7219 } 7220 } 7221 else { 7222 @FamilyTypes = @{familyTypes($TypeId)}; 7223 } 7224 my @Ints = (); 7225 foreach my $FamilyTypeId (@FamilyTypes) 7226 { 7227 next if((get_PointerLevel($TypeId)<get_PointerLevel($FamilyTypeId)) and $Init_Desc{"OuterType_Type"} eq "Array"); 7228 next if(get_TypeType($TypeId) eq "Class" and get_PointerLevel($FamilyTypeId)==0); 7229 if($Init_Desc{"OnlyData"}) { 7230 @Ints = (@Ints, get_CompatibleInterfaces($FamilyTypeId, "OnlyData", 7231 $Init_Desc{"Interface"}." ".$ParamName." ".$Init_Desc{"KeyWords"})); 7232 } 7233 elsif($Init_Desc{"OnlyReturn"}) { 7234 @Ints = (@Ints, get_CompatibleInterfaces($FamilyTypeId, "OnlyReturn", 7235 $Init_Desc{"Interface"}." ".$ParamName." ".$Init_Desc{"KeyWords"})); 7236 } 7237 else { 7238 @Ints = (@Ints, get_CompatibleInterfaces($FamilyTypeId, "Return", 7239 $Init_Desc{"Interface"}." ".$ParamName." ".$Init_Desc{"KeyWords"})); 7240 } 7241 } 7242 sort_byCriteria(\@Ints, "DeleteSmth"); 7243 foreach my $Interface (@Ints) 7244 { # find interface for returning some type in the family 7245 my %Interface_Init = callInterface(( 7246 "Interface"=>$Interface, 7247 "Key"=>$Key, 7248 "RetParam"=>$ParamName)); 7249 if($Interface_Init{"IsCorrect"}) { 7250 $Interface_Init{"Interface"} = $Interface; 7251 return %Interface_Init; 7252 } 7253 } 7254 return (); 7255} 7256 7257sub initializeByInterface_OutParam(@) 7258{ 7259 my %Init_Desc = @_; 7260 return () if(not $Init_Desc{"TypeId"}); 7261 my $Global_State = save_state(); 7262 my %Type_Init = (); 7263 my $FTypeId = get_FoundationTypeId($Init_Desc{"TypeId"}); 7264 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 7265 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 7266 my $Var = $Init_Desc{"Var"}; 7267 $Block_Variable{$CurrentBlock}{$Var} = 1; 7268 my %Interface_Init = findInterface_OutParam($Init_Desc{"TypeId"}, $Init_Desc{"Key"}, $Init_Desc{"StrongTypeCompliance"}, "\@OUT_PARAM\@", $Init_Desc{"ParamName"}, $Init_Desc{"Strong"}); 7269 if(not $Interface_Init{"IsCorrect"}) 7270 { 7271 restore_state($Global_State); 7272 return (); 7273 } 7274 $Type_Init{"Init"} = $Interface_Init{"Init"}; 7275 $Type_Init{"Destructors"} = $Interface_Init{"Destructors"}; 7276 $Type_Init{"Code"} .= $Interface_Init{"Code"}; 7277 $Type_Init{"Headers"} = addHeaders($Interface_Init{"Headers"}, $Type_Init{"Headers"}); 7278 7279 # initialization 7280 my $OutParam_Pos = $Interface_Init{"OutParamPos"}; 7281 my $OutParam_TypeId = $CompleteSignature{$Interface_Init{"Interface"}}{"Param"}{$OutParam_Pos}{"type"}; 7282 my $PLevel_Out = get_PointerLevel($OutParam_TypeId); 7283 my ($InitializedEType_Id, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $OutParam_TypeId); 7284 my $InitializedType_Name = get_TypeName($InitializedEType_Id); 7285 $Type_Init{"Code"} .= $Declarations; 7286 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 7287 my $InitializedFType_Id = get_FoundationTypeId($OutParam_TypeId); 7288# my $InitializedFType_Type = get_TypeType($InitializedFType_Id); 7289 my $InitializedType_PointerLevel = get_PointerLevel($OutParam_TypeId); 7290 my $VarNameForReplace = $Var; 7291 if($PLevel_Out>1 or ($PLevel_Out==1 and not isOpaque($InitializedFType_Id))) 7292 { 7293 $OutParam_TypeId = reduce_pointer_level($InitializedEType_Id); 7294 $InitializedType_Name=get_TypeName($OutParam_TypeId); 7295 $VarNameForReplace="&".$Var; 7296 $InitializedType_PointerLevel-=1; 7297 } 7298 foreach (keys(%Interface_Init)) 7299 { 7300 $Interface_Init{$_}=~s/\@OUT_PARAM\@/$VarNameForReplace/g; 7301 $Interface_Init{$_} = clearSyntax($Interface_Init{$_}); 7302 } 7303 if(uncover_typedefs($InitializedType_Name)=~/&|\[/ or $PLevel_Out==1) 7304 { 7305# if($InitializedFType_Type eq "Struct") 7306# { 7307# my %Struct_Desc = %Init_Desc; 7308# $Struct_Desc{"TypeId"} = $OutParam_TypeId; 7309# $Struct_Desc{"InLine"} = 0; 7310# my $Key = $Struct_Desc{"Key"}; 7311# delete($Block_Variable{$CurrentBlock}{$Var}); 7312# my %Assembly = assembleStruct(%Struct_Desc); 7313# $Block_Variable{$CurrentBlock}{$Var} = 1; 7314# $Type_Init{"Init"} .= $Assembly{"Init"}; 7315# $Type_Init{"Code"} .= $Assembly{"Code"}; 7316# $Type_Init{"Headers"} = addHeaders($Assembly{"Headers"}, $Type_Init{"Headers"}); 7317# } 7318# else 7319# { 7320 $Type_Init{"Init"} .= $InitializedType_Name." $Var;\n"; 7321 if(get_TypeType($InitializedFType_Id) eq "Struct") 7322 { 7323 my %Type = get_Type($InitializedFType_Id); 7324 foreach my $MemPos (keys(%{$Type{"Memb"}})) 7325 { 7326 if($Type{"Memb"}{$MemPos}{"name"}=~/initialized/i 7327 and isNumericType(get_TypeName($Type{"Memb"}{$MemPos}{"type"}))) 7328 { 7329 $Type_Init{"Init"} .= "$Var.initialized = 0;\n"; 7330 last; 7331 } 7332 } 7333 } 7334 } 7335 else 7336 { 7337 $Type_Init{"Init"} .= $InitializedType_Name." $Var = ".get_null().";\n"; 7338 } 7339 if(not defined $DisableReuse) 7340 { 7341 $ValueCollection{$CurrentBlock}{$Var} = $OutParam_TypeId; 7342 } 7343 $Type_Init{"Init"} .= $Interface_Init{"PreCondition"} if($Interface_Init{"PreCondition"}); 7344 $Type_Init{"Init"} .= $Interface_Init{"Call"}.";\n"; 7345 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Init_Desc{"TypeId"}), $Type_Init{"Headers"}); 7346 $Type_Init{"Init"} .= $Interface_Init{"PostCondition"} if($Interface_Init{"PostCondition"}); 7347 if($Interface_Init{"FinalCode"}) 7348 { 7349 $Type_Init{"Init"} .= "//final code\n"; 7350 $Type_Init{"Init"} .= $Interface_Init{"FinalCode"}."\n"; 7351 } 7352 # create call 7353 my ($Call, $Preamble) = convertTypes(( 7354 "InputTypeName"=>$InitializedType_Name, 7355 "InputPointerLevel"=>$InitializedType_PointerLevel, 7356 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 7357 "Value"=>$Var, 7358 "Key"=>$Var, 7359 "Destination"=>"Param", 7360 "MustConvert"=>0)); 7361 $Type_Init{"Init"} .= $Preamble; 7362 $Type_Init{"Call"} = $Call; 7363 # create call to constraint 7364 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) 7365 { 7366 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 7367 } 7368 else 7369 { 7370 my ($TargetCall, $TargetPreamble) = convertTypes(( 7371 "InputTypeName"=>$InitializedType_Name, 7372 "InputPointerLevel"=>$InitializedType_PointerLevel, 7373 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 7374 "Value"=>$Var, 7375 "Key"=>$Var, 7376 "Destination"=>"Target", 7377 "MustConvert"=>0)); 7378 $Type_Init{"TargetCall"} = $TargetCall; 7379 $Type_Init{"Init"} .= $TargetPreamble; 7380 } 7381 if(get_TypeType($Init_Desc{"TypeId"}) eq "Ref") 7382 { # ref handler 7383 my $BaseRefTypeId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 7384 if(get_PointerLevel($BaseRefTypeId) > $InitializedType_PointerLevel) 7385 { 7386 my $BaseRefTypeName = get_TypeName($BaseRefTypeId); 7387 $Type_Init{"Init"} .= $BaseRefTypeName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 7388 $Type_Init{"Call"} = $Var."_ref"; 7389 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 7390 if(not defined $DisableReuse) 7391 { 7392 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 7393 } 7394 } 7395 } 7396 $Type_Init{"Init"} .= "\n"; 7397 $Type_Init{"IsCorrect"} = 1; 7398 return %Type_Init; 7399} 7400 7401sub declare_funcptr_typedef($$) 7402{ 7403 my ($Key, $TypeId) = @_; 7404 return "" if($AuxType{$TypeId} or not $TypeId or not $Key); 7405 my $TypedefTo = $Key."_type"; 7406 my $Typedef = "typedef ".get_TypeName($TypeId).";\n"; 7407 $Typedef=~s/[ ]*\(\*\)[ ]*/ \(\*$TypedefTo\) /; 7408 $AuxType{$TypeId} = $TypedefTo; 7409 $TypeInfo{$TypeId}{"Name_Old"} = get_TypeName($TypeId); 7410 $TypeInfo{$TypeId}{"Name"} = $AuxType{$TypeId}; 7411 $TName_Tid{$TypedefTo} = $TypeId; 7412 return $Typedef; 7413} 7414 7415sub have_copying_constructor($) 7416{ 7417 my $ClassId = $_[0]; 7418 return 0 if(not $ClassId); 7419 foreach my $Constructor (keys(%{$Class_Constructors{$ClassId}})) 7420 { 7421 if(keys(%{$CompleteSignature{$Constructor}{"Param"}})==1 7422 and not $CompleteSignature{$Constructor}{"Protected"}) 7423 { 7424 my $FirstParamTypeId = $CompleteSignature{$Constructor}{"Param"}{0}{"type"}; 7425 if(get_FoundationTypeId($FirstParamTypeId) eq $ClassId 7426 and get_PointerLevel($FirstParamTypeId)==0) { 7427 return 1; 7428 } 7429 } 7430 } 7431 return 0; 7432} 7433 7434sub initializeByInterface(@) 7435{ 7436 my %Init_Desc = @_; 7437 return () if(not $Init_Desc{"TypeId"}); 7438 my $Global_State = save_state(); 7439 my %Type_Init = (); 7440 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 7441 my $FTypeId = get_FoundationTypeId($Init_Desc{"TypeId"}); 7442 if(get_TypeType($FTypeId) eq "Class" and $PointerLevel==0 7443 and not have_copying_constructor($FTypeId)) { 7444 return (); 7445 } 7446 my %Interface_Init = (); 7447 if($Init_Desc{"ByInterface"}) 7448 { 7449 %Interface_Init = callInterface(( 7450 "Interface"=>$Init_Desc{"ByInterface"}, 7451 "Key"=>$Init_Desc{"Key"}, 7452 "RetParam"=>$Init_Desc{"ParamName"}, 7453 "OnlyReturn"=>1)); 7454 } 7455 else { 7456 %Interface_Init = findInterface(%Init_Desc); 7457 } 7458 if(not $Interface_Init{"IsCorrect"}) 7459 { 7460 restore_state($Global_State); 7461 return (); 7462 } 7463 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 7464 $Type_Init{"Init"} = $Interface_Init{"Init"}; 7465 $Type_Init{"Destructors"} = $Interface_Init{"Destructors"}; 7466 $Type_Init{"Code"} = $Interface_Init{"Code"}; 7467 $Type_Init{"Headers"} = addHeaders($Interface_Init{"Headers"}, $Type_Init{"Headers"}); 7468 if(keys(%{$CompleteSignature{$Interface_Init{"Interface"}}{"Param"}})>$MAX_PARAMS_INLINE) { 7469 $Init_Desc{"InLine"} = 0; 7470 } 7471 # initialization 7472 my $ReturnType_PointerLevel = get_PointerLevel($Interface_Init{"ReturnTypeId"}); 7473 if($ReturnType_PointerLevel==$PointerLevel and $Init_Desc{"InLine"} 7474 and not $Interface_Init{"PreCondition"} and not $Interface_Init{"PostCondition"} 7475 and not $Interface_Init{"ReturnFinalCode"}) 7476 { 7477 my ($Call, $Preamble) = convertTypes(( 7478 "InputTypeName"=>get_TypeName($Interface_Init{"ReturnTypeId"}), 7479 "InputPointerLevel"=>$ReturnType_PointerLevel, 7480 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 7481 "Value"=>$Interface_Init{"Call"}, 7482 "Key"=>$Init_Desc{"Var"}, 7483 "Destination"=>"Param", 7484 "MustConvert"=>0)); 7485 $Type_Init{"Init"} .= $Preamble; 7486 $Type_Init{"Call"} = $Call; 7487 $Type_Init{"TypeName"} = get_TypeName($Interface_Init{"ReturnTypeId"}); 7488 } 7489 else 7490 { 7491 my $Var = $Init_Desc{"Var"}; 7492 $Block_Variable{$CurrentBlock}{$Var} = 1; 7493 my ($InitializedEType_Id, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Interface_Init{"ReturnTypeId"}); 7494 my $InitializedType_Name = get_TypeName($InitializedEType_Id); 7495 $Type_Init{"TypeName"} = $InitializedType_Name; 7496 $Type_Init{"Code"} .= $Declarations; 7497 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 7498 my %ReturnType = get_Type($Interface_Init{"ReturnTypeId"}); 7499 if(not defined $DisableReuse) { 7500 $ValueCollection{$CurrentBlock}{$Var} = $Interface_Init{"ReturnTypeId"}; 7501 } 7502 $Type_Init{"Init"} .= $Interface_Init{"PreCondition"} if($Interface_Init{"PreCondition"}); 7503 if(($InitializedType_Name eq $ReturnType{"Name"})) { 7504 $Type_Init{"Init"} .= $InitializedType_Name." $Var = ".$Interface_Init{"Call"}.";\n"; 7505 } 7506 else { 7507 $Type_Init{"Init"} .= $InitializedType_Name." $Var = "."(".$InitializedType_Name.")".$Interface_Init{"Call"}.";\n"; 7508 } 7509 if($Interface_Init{"Interface"} eq "fopen") { 7510 $OpenStreams{$CurrentBlock}{$Var} = 1; 7511 } 7512 # create call 7513 my ($Call, $Preamble) = convertTypes(( 7514 "InputTypeName"=>$InitializedType_Name, 7515 "InputPointerLevel"=>$ReturnType_PointerLevel, 7516 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 7517 "Value"=>$Var, 7518 "Key"=>$Var, 7519 "Destination"=>"Param", 7520 "MustConvert"=>0)); 7521 $Type_Init{"Init"} .= $Preamble; 7522 $Type_Init{"Call"} = $Call; 7523 # create call to constraint 7524 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 7525 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 7526 } 7527 else 7528 { 7529 my ($TargetCall, $TargetPreamble) = convertTypes(( 7530 "InputTypeName"=>$InitializedType_Name, 7531 "InputPointerLevel"=>$ReturnType_PointerLevel, 7532 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 7533 "Value"=>$Var, 7534 "Key"=>$Var, 7535 "Destination"=>"Target", 7536 "MustConvert"=>0)); 7537 $Type_Init{"TargetCall"} = $TargetCall; 7538 $Type_Init{"Init"} .= $TargetPreamble; 7539 } 7540 if(get_TypeType($Init_Desc{"TypeId"}) eq "Ref") 7541 { # ref handler 7542 my $BaseRefTypeId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 7543 if(get_PointerLevel($BaseRefTypeId) > $ReturnType_PointerLevel) 7544 { 7545 my $BaseRefTypeName = get_TypeName($BaseRefTypeId); 7546 $Type_Init{"Init"} .= $BaseRefTypeName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 7547 $Type_Init{"Call"} = $Var."_ref"; 7548 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 7549 if(not defined $DisableReuse) 7550 { 7551 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 7552 } 7553 } 7554 } 7555 if($Interface_Init{"ReturnRequirement"}) 7556 { 7557 $Interface_Init{"ReturnRequirement"}=~s/(\$0|\$retval)/$Var/gi; 7558 $Type_Init{"Init"} .= $Interface_Init{"ReturnRequirement"}; 7559 } 7560 if($Interface_Init{"ReturnFinalCode"}) 7561 { 7562 $Interface_Init{"ReturnFinalCode"}=~s/(\$0|\$retval)/$Var/gi; 7563 $Type_Init{"Init"} .= "//final code\n"; 7564 $Type_Init{"Init"} .= $Interface_Init{"ReturnFinalCode"}."\n"; 7565 } 7566 } 7567 $Type_Init{"Init"} .= $Interface_Init{"PostCondition"} if($Interface_Init{"PostCondition"}); 7568 if($Interface_Init{"FinalCode"}) 7569 { 7570 $Type_Init{"Init"} .= "//final code\n"; 7571 $Type_Init{"Init"} .= $Interface_Init{"FinalCode"}."\n"; 7572 } 7573 7574 $Type_Init{"IsCorrect"} = 1; 7575 return %Type_Init; 7576} 7577 7578sub initializeFuncPtr(@) 7579{ 7580 my %Init_Desc = @_; 7581 my %Type_Init = initializeByInterface(%Init_Desc); 7582 if($Type_Init{"IsCorrect"}) { 7583 return %Type_Init; 7584 } 7585 else { 7586 return assembleFuncPtr(%Init_Desc); 7587 } 7588} 7589 7590sub get_OneStep_BaseTypeId($) 7591{ 7592 my $TypeId = $_[0]; 7593 my %Type = %{$TypeInfo{$TypeId}}; 7594 if(defined $Type{"BaseType"} 7595 and $Type{"BaseType"}) { 7596 return $Type{"BaseType"}; 7597 } 7598 else { 7599 return $Type{"Tid"}; 7600 } 7601} 7602 7603sub initializeArray(@) 7604{ 7605 my %Init_Desc = @_; 7606 if($Init_Desc{"TypeType_Changed"}) 7607 { 7608 my %Type_Init = assembleArray(%Init_Desc); 7609 if($Type_Init{"IsCorrect"}) { 7610 return %Type_Init; 7611 } 7612 else 7613 { # failed to initialize as "array" 7614 if(my $FTId = get_FoundationTypeId($Init_Desc{"TypeId"})) 7615 { 7616 my $FType = get_TypeType($FTId); 7617 if($FType ne "Array") 7618 { 7619 $Init_Desc{"FoundationType_Type"} = $FType; 7620 return selectInitializingWay(%Init_Desc); 7621 } 7622 } 7623 return (); 7624 } 7625 } 7626 else 7627 { 7628 $Init_Desc{"StrongTypeCompliance"} = 1; 7629 my %Type_Init = initializeByInterface(%Init_Desc); 7630 if($Type_Init{"IsCorrect"}) { 7631 return %Type_Init; 7632 } 7633 else 7634 { 7635 %Type_Init = initializeByInterface_OutParam(%Init_Desc); 7636 if($Type_Init{"IsCorrect"}) { 7637 return %Type_Init; 7638 } 7639 else 7640 { 7641 $Init_Desc{"StrongTypeCompliance"} = 0; 7642 return assembleArray(%Init_Desc); 7643 } 7644 } 7645 } 7646} 7647 7648sub get_PureType($) 7649{ 7650 my $TypeId = $_[0]; 7651 return () if(not $TypeId); 7652 if(defined $Cache{"get_PureType"}{$TypeId} 7653 and not defined $AuxType{$TypeId}) { 7654 return %{$Cache{"get_PureType"}{$TypeId}}; 7655 } 7656 return () if(not $TypeInfo{$TypeId}); 7657 my %Type = %{$TypeInfo{$TypeId}}; 7658 return %Type if(not $Type{"BaseType"}); 7659 if($Type{"Type"}=~/\A(Ref|Const|Volatile|Restrict|Typedef)\Z/) { 7660 %Type = get_PureType($Type{"BaseType"}); 7661 } 7662 $Cache{"get_PureType"}{$TypeId} = \%Type; 7663 return %Type; 7664} 7665 7666sub delete_quals($) 7667{ 7668 my $TypeId = $_[0]; 7669 return () if(not $TypeId); 7670 if(defined $Cache{"delete_quals"}{$TypeId} 7671 and not defined $AuxType{$TypeId}) { 7672 return %{$Cache{"delete_quals"}{$TypeId}}; 7673 } 7674 return () if(not $TypeInfo{$TypeId}); 7675 my %Type = %{$TypeInfo{$TypeId}}; 7676 return %Type if(not $Type{"BaseType"}); 7677 if($Type{"Type"}=~/\A(Ref|Const|Volatile|Restrict)\Z/) { 7678 %Type = delete_quals($Type{"BaseType"}); 7679 } 7680 $Cache{"delete_quals"}{$TypeId} = \%Type; 7681 return %Type; 7682} 7683 7684sub goToFirst($$) 7685{ 7686 my ($TypeId, $Type_Type) = @_; 7687 if(defined $Cache{"goToFirst"}{$TypeId}{$Type_Type} 7688 and not defined $AuxType{$TypeId}) { 7689 return %{$Cache{"goToFirst"}{$TypeId}{$Type_Type}}; 7690 } 7691 return () if(not $TypeInfo{$TypeId}); 7692 my %Type = %{$TypeInfo{$TypeId}}; 7693 return () if(not $Type{"Type"}); 7694 if($Type{"Type"} ne $Type_Type) 7695 { 7696 return () if(not $Type{"BaseType"}); 7697 %Type = goToFirst($Type{"BaseType"}, $Type_Type); 7698 } 7699 $Cache{"goToFirst"}{$TypeId}{$Type_Type} = \%Type; 7700 return %Type; 7701} 7702 7703sub detectArrayTypeId($) 7704{ 7705 my $TypeId = $_[0]; 7706 my $ArrayType_Id = get_FoundationTypeId($TypeId); 7707 my $PointerLevel = get_PointerLevel($TypeId); 7708 if(get_TypeType($ArrayType_Id) eq "Array")# and $PointerLevel==0 7709 { 7710 return $ArrayType_Id; 7711 } 7712 else 7713 { # this branch for types like arrays (char* like char[]) 7714 my %Type = get_PureType($TypeId); 7715 return $Type{"Tid"}; 7716 } 7717} 7718 7719sub assembleArray(@) 7720{ 7721 my %Init_Desc = @_; 7722 my %Type_Init = (); 7723 my $Global_State = save_state(); 7724 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 7725 my %Type = get_Type($Init_Desc{"TypeId"}); 7726 # determine array base 7727 my $ArrayType_Id = detectArrayTypeId($Init_Desc{"TypeId"}); 7728 my %ArrayType = get_Type($ArrayType_Id); 7729 my $AmountArray = ($ArrayType{"Type"} eq "Array")?$ArrayType{"Count"}:(($Init_Desc{"ArraySize"})?$Init_Desc{"ArraySize"}:$DEFAULT_ARRAY_AMOUNT); 7730 if($AmountArray>1024) 7731 { # such too long arrays should be initialized by other methods 7732 restore_state($Global_State); 7733 return (); 7734 } 7735 # array base type attributes 7736 my $ArrayElemType_Id = get_OneStep_BaseTypeId($ArrayType_Id); 7737 my $ArrayElemType_Name = remove_quals(get_TypeName($ArrayElemType_Id)); 7738 my $ArrayElemType_PLevel = get_PointerLevel($ArrayElemType_Id); 7739 my $ArrayElemFType_Id = get_FoundationTypeId($ArrayElemType_Id); 7740 my $IsInlineDef = (($ArrayType{"Type"} eq "Array") and $PointerLevel==0 and ($Type{"Type"} ne "Ref") and $Init_Desc{"InLine"} or $Init_Desc{"InLineArray"}); 7741 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 7742 my $Var = $Init_Desc{"Var"}; 7743 if(not $IsInlineDef) { 7744 $Block_Variable{$CurrentBlock}{$Var} = 1; 7745 } 7746 if(not isCharType(get_TypeName($ArrayElemFType_Id)) and not $IsInlineDef) 7747 { 7748 my ($ExtTypeId, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $ArrayElemType_Id); 7749 $ArrayElemType_Id = $ExtTypeId; 7750 $Type_Init{"Code"} .= $Declarations; 7751 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 7752 } 7753 my @ElemStr = (); 7754 foreach my $Elem_Pos (1 .. $AmountArray) 7755 { # initialize array members 7756 my $ElemName = ""; 7757 if(isCharType(get_TypeName($ArrayElemFType_Id)) 7758 and $ArrayElemType_PLevel==1) { 7759 $ElemName = $Init_Desc{"ParamName"}."_".$Elem_Pos; 7760 } 7761 elsif(my $EName = getParamNameByTypeName($ArrayElemType_Name)) { 7762 $ElemName = $EName; 7763 } 7764 else { 7765 $ElemName = $Init_Desc{"ParamName"}.((not defined $DisableReuse)?"_elem":""); 7766 $ElemName=~s/es_elem\Z/e/g; 7767 } 7768 my %Elem_Init = initializeParameter(( 7769 "TypeId" => $ArrayElemType_Id, 7770 "Key" => $Init_Desc{"Key"}."_".$Elem_Pos, 7771 "InLine" => 1, 7772 "Value" => "no value", 7773 "ValueTypeId" => 0, 7774 "TargetTypeId" => 0, 7775 "CreateChild" => 0, 7776 "Usage" => "Common", 7777 "ParamName" => $ElemName, 7778 "OuterType_Type" => "Array", 7779 "Index" => $Elem_Pos-1, 7780 "InLineArray" => ($ArrayElemType_PLevel==1 and isCharType(get_TypeName($ArrayElemFType_Id)) and $Init_Desc{"ParamName"}=~/text|txt|doc/i)?1:0, 7781 "IsString" => ($ArrayElemType_PLevel==1 and isCharType(get_TypeName($ArrayElemFType_Id)) and $Init_Desc{"ParamName"}=~/prefixes/i)?1:0 )); 7782 if(not $Elem_Init{"IsCorrect"} or $Elem_Init{"ByNull"}) { 7783 restore_state($Global_State); 7784 return (); 7785 } 7786 if($Elem_Pos eq 1) { 7787 $Type_Init{"Headers"} = addHeaders($Elem_Init{"Headers"}, $Type_Init{"Headers"}); 7788 } 7789 @ElemStr = (@ElemStr, $Elem_Init{"Call"}); 7790 $Type_Init{"Init"} .= $Elem_Init{"Init"}; 7791 $Type_Init{"Destructors"} .= $Elem_Init{"Destructors"}; 7792 $Type_Init{"Code"} .= $Elem_Init{"Code"}; 7793 } 7794 if(($ArrayType{"Type"} ne "Array") and not isNumericType($ArrayElemType_Name)) 7795 { # the last array element 7796 if($ArrayElemType_PLevel==0 7797 and get_TypeName($ArrayElemFType_Id)=~/\A(char|unsigned char)\Z/) { 7798 @ElemStr = (@ElemStr, "\'\\0\'"); 7799 } 7800 elsif($ArrayElemType_PLevel==0 7801 and is_equal_types($ArrayElemType_Name, "wchar_t")) { 7802 @ElemStr = (@ElemStr, "L\'\\0\'"); 7803 } 7804 elsif($ArrayElemType_PLevel>=1) { 7805 @ElemStr = (@ElemStr, get_null()); 7806 } 7807 elsif($ArrayElemType_PLevel==0 7808 and get_TypeType($ArrayElemFType_Id)=~/\A(Struct|Union)\Z/) { 7809 @ElemStr = (@ElemStr, "($ArrayElemType_Name) "."{0}"); 7810 } 7811 } 7812 # initialization 7813 if($IsInlineDef) { 7814 $Type_Init{"Call"} = "{".create_matrix(\@ElemStr, " ")."}"; 7815 } 7816 else 7817 { 7818 if(not defined $DisableReuse) { 7819 $ValueCollection{$CurrentBlock}{$Var} = $ArrayType_Id; 7820 } 7821 # $Type_Init{"Init"} .= "//parameter initialization\n"; 7822 $Type_Init{"Init"} .= $ArrayElemType_Name." $Var [".(($ArrayType{"Type"} eq "Array")?$AmountArray:"")."] = {".create_matrix(\@ElemStr, " ")."};\n"; 7823 #create call 7824 my ($Call, $TmpPreamble) = 7825 convertTypes(( 7826 "InputTypeName"=>formatName($ArrayElemType_Name."*", "T"), 7827 "InputPointerLevel"=>get_PointerLevel($ArrayType_Id), 7828 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 7829 "Value"=>$Var, 7830 "Key"=>$Var, 7831 "Destination"=>"Param", 7832 "MustConvert"=>0)); 7833 $Type_Init{"Init"} .= $TmpPreamble; 7834 $Type_Init{"Call"} = $Call; 7835 # create type 7836 7837 # create call to constraint 7838 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 7839 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 7840 } 7841 else 7842 { 7843 my ($TargetCall, $Target_TmpPreamble) = 7844 convertTypes(( 7845 "InputTypeName"=>formatName($ArrayElemType_Name."*", "T"), 7846 "InputPointerLevel"=>get_PointerLevel($ArrayType_Id), 7847 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 7848 "Value"=>$Var, 7849 "Key"=>$Var, 7850 "Destination"=>"Target", 7851 "MustConvert"=>0)); 7852 $Type_Init{"TargetCall"} = $TargetCall; 7853 $Type_Init{"Init"} .= $Target_TmpPreamble; 7854 } 7855 # ref handler 7856 if($Type{"Type"} eq "Ref") 7857 { 7858 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 7859 if($ArrayType{"Type"} eq "Pointer" or (get_PointerLevel($BaseRefId) > 0)) 7860 { 7861 my $BaseRefName = get_TypeName($BaseRefId); 7862 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 7863 $Type_Init{"Call"} = $Var."_ref"; 7864 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 7865 if(not defined $DisableReuse) { 7866 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 7867 } 7868 } 7869 } 7870 } 7871 $Type_Init{"TypeName"} = $ArrayElemType_Name." [".(($ArrayType{"Type"} eq "Array")?$AmountArray:"")."]"; 7872 $Type_Init{"IsCorrect"} = 1; 7873 return %Type_Init; 7874} 7875 7876sub get_null() 7877{ 7878 if(getSymLang($TestedInterface) eq "C++" 7879 and $Constants{"NULL"}) { 7880 return "NULL"; 7881 } 7882 else { 7883 return "0"; 7884 } 7885} 7886 7887sub create_list($$) 7888{ 7889 my ($Array, $Spaces) = @_; 7890 my @Elems = @{$Array}; 7891 my ($MaxLength, $SumLength); 7892 foreach my $Elem (@Elems) 7893 { 7894 $SumLength += length($Elem); 7895 if(not defined $MaxLength 7896 or $MaxLength<length($Elem)) { 7897 $MaxLength = length($Elem); 7898 } 7899 } 7900 if(($#Elems+1>$MAX_PARAMS_INLINE) 7901 or ($SumLength>$MAX_PARAMS_LENGTH_INLINE and $#Elems>0) 7902 or join("", @Elems)=~/\n/) { 7903 return "\n$Spaces".join(",\n$Spaces", @Elems); 7904 } 7905 else { 7906 return join(", ", @Elems); 7907 } 7908} 7909 7910sub create_matrix($$) 7911{ 7912 my ($Array, $Spaces) = @_; 7913 my @Elems = @{$Array}; 7914 my $MaxLength; 7915 foreach my $Elem (@Elems) 7916 { 7917 if(length($Elem) > $MATRIX_MAX_ELEM_LENGTH) { 7918 return create_list($Array, $Spaces); 7919 } 7920 if(not defined $MaxLength 7921 or $MaxLength<length($Elem)) { 7922 $MaxLength = length($Elem); 7923 } 7924 } 7925 if($#Elems+1 >= $MIN_PARAMS_MATRIX) 7926 { 7927 my (@Rows, @Row) = (); 7928 foreach my $Num (0 .. $#Elems) 7929 { 7930 my $Elem = $Elems[$Num]; 7931 if($Num%$MATRIX_WIDTH==0 and $Num!=0) 7932 { 7933 push(@Rows, join(", ", @Row)); 7934 @Row = (); 7935 } 7936 push(@Row, aligh_str($Elem, $MaxLength)); 7937 } 7938 push(@Rows, join(", ", @Row)) if($#Row>=0); 7939 return "\n$Spaces".join(",\n$Spaces", @Rows); 7940 } 7941 else { 7942 return create_list($Array, $Spaces); 7943 } 7944} 7945 7946sub aligh_str($$) 7947{ 7948 my ($Str, $Length) = @_; 7949 if(length($Str)<$Length) 7950 { 7951 foreach (1 .. $Length - length($Str)) { 7952 $Str = " ".$Str; 7953 } 7954 } 7955 return $Str; 7956} 7957 7958sub findFuncPtr_RealFunc($$) 7959{ 7960 my ($FuncTypeId, $ParamName) = @_; 7961 my @AvailableRealFuncs = (); 7962 foreach my $Interface (sort {length($a)<=>length($b)} sort {$a cmp $b} keys(%{$Func_TypeId{$FuncTypeId}})) 7963 { 7964 next if(isCyclical(\@RecurInterface, $Interface)); 7965 if($Symbol_Library{$Interface} 7966 or $DepSymbol_Library{$Interface}) { 7967 push(@AvailableRealFuncs, $Interface); 7968 } 7969 } 7970 sort_byCriteria(\@AvailableRealFuncs, "Internal"); 7971 @AvailableRealFuncs = sort {($b=~/\Q$ParamName\E/i)<=>($a=~/\Q$ParamName\E/i)} @AvailableRealFuncs if($ParamName!~/\Ap\d+\Z/); 7972 sort_byName(\@AvailableRealFuncs, $ParamName, "Interfaces"); 7973 if($#AvailableRealFuncs>=0) { 7974 return $AvailableRealFuncs[0]; 7975 } 7976 else { 7977 return ""; 7978 } 7979} 7980 7981sub get_base_typedef($) 7982{ 7983 my $TypeId = $_[0]; 7984 my %TypeDef = goToFirst($TypeId, "Typedef"); 7985 return 0 if(not $TypeDef{"Type"}); 7986 if(get_PointerLevel($TypeDef{"Tid"})==0) { 7987 return $TypeDef{"Tid"}; 7988 } 7989 my $BaseTypeId = get_OneStep_BaseTypeId($TypeDef{"Tid"}); 7990 return get_base_typedef($BaseTypeId); 7991} 7992 7993sub assembleFuncPtr(@) 7994{ 7995 my %Init_Desc = @_; 7996 my %Type_Init = (); 7997 my $Global_State = save_state(); 7998 my %Type = get_Type($Init_Desc{"TypeId"}); 7999 my $FuncPtr_TypeId = get_FoundationTypeId($Init_Desc{"TypeId"}); 8000 my %FuncPtrType = get_Type($FuncPtr_TypeId); 8001 my ($TypeName, $AuxFuncName) = ($FuncPtrType{"Name"}, ""); 8002 if(get_PointerLevel($Init_Desc{"TypeId"})>0) 8003 { 8004 if(my $Typedef_Id = get_base_typedef($Init_Desc{"TypeId"})) { 8005 $TypeName = get_TypeName($Typedef_Id); 8006 } 8007 elsif(my $Typedef_Id = get_type_typedef($FuncPtr_TypeId)) 8008 { 8009 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Typedef_Id), $Type_Init{"Headers"}); 8010 $TypeName = get_TypeName($Typedef_Id); 8011 } 8012 else 8013 { 8014 $Type_Init{"Code"} .= declare_funcptr_typedef($Init_Desc{"Key"}, $FuncPtr_TypeId); 8015 $TypeName = get_TypeName($FuncPtr_TypeId); 8016 } 8017 } 8018 if($FuncPtrType{"Name"} eq "void*(*)(size_t)") 8019 { 8020 $Type_Init{"Headers"} = addHeaders(["stdlib.h"], $Type_Init{"Headers"}); 8021 $AuxHeaders{"stdlib.h"} = 1; 8022 $AuxFuncName = "malloc"; 8023 } 8024 elsif(my $Interface_FuncPtr = findFuncPtr_RealFunc($FuncPtrType{"FuncTypeId"}, $Init_Desc{"ParamName"})) 8025 { 8026 $UsedInterfaces{$Interface_FuncPtr} = 1; 8027 $Type_Init{"Headers"} = addHeaders([$CompleteSignature{$Interface_FuncPtr}{"Header"}], $Type_Init{"Headers"}); 8028 $AuxFuncName = $CompleteSignature{$Interface_FuncPtr}{"ShortName"}; 8029 if($CompleteSignature{$Interface_FuncPtr}{"NameSpace"}) { 8030 $AuxFuncName = $CompleteSignature{$Interface_FuncPtr}{"NameSpace"}."::".$AuxFuncName; 8031 } 8032 } 8033 else 8034 { 8035 if($AuxFunc{$FuncPtr_TypeId}) { 8036 $AuxFuncName = $AuxFunc{$FuncPtr_TypeId}; 8037 } 8038 else 8039 { 8040 my @FuncParams = (); 8041 $AuxFuncName = select_func_name($LongVarNames?$Init_Desc{"Key"}:(($Init_Desc{"ParamName"}=~/\Ap\d+\Z/)?"aux_func":$Init_Desc{"ParamName"})); 8042 # global 8043 $AuxFunc{$FuncPtr_TypeId} = $AuxFuncName; 8044 my $PreviousBlock = $CurrentBlock; 8045 $CurrentBlock = $AuxFuncName; 8046 # function declaration 8047 my $FuncReturnType_Id = $FuncPtrType{"Return"}; 8048 foreach my $ParamPos (sort {int($a)<=>int($b)} keys(%{$FuncPtrType{"Param"}})) 8049 { 8050 my $ParamTypeId = $FuncPtrType{"Param"}{$ParamPos}{"type"}; 8051 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($ParamTypeId), $Type_Init{"Headers"}); 8052 my $ParamName = $FuncPtrType{"Param"}{$ParamPos}{"name"}; 8053 $ParamName = "p".($ParamPos+1) if(not $ParamName); 8054 # my ($ParamEType_Id, $Param_Declarations, $Param_Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $ParamTypeId); 8055 my $ParamTypeName = get_TypeName($ParamTypeId);#get_TypeName($ParamEType_Id); 8056 # $Type_Init{"Header"} = addHeaders($Param_Headers, $Type_Init{"Header"}); 8057 # $Type_Init{"Code"} .= $Param_Declarations; 8058 if($ParamTypeName and ($ParamTypeName ne "...")) 8059 { 8060 my $Field = create_member_decl($ParamTypeName, $ParamName); 8061 @FuncParams = (@FuncParams, $Field); 8062 } 8063 $ValueCollection{$AuxFuncName}{$ParamName} = $ParamTypeId; 8064 $Block_Param{$AuxFuncName}{$ParamName} = $ParamTypeId; 8065 $Block_Variable{$CurrentBlock}{$ParamName} = 1; 8066 } 8067 # definition of function 8068 if(get_TypeName($FuncReturnType_Id) eq "void") 8069 { 8070 my $FuncDef = "//auxiliary function\n"; 8071 $FuncDef .= "void\n".$AuxFuncName."(".create_list(\@FuncParams, " ").")"; 8072 if($AuxFuncName=~/free/i) 8073 { 8074 my $PtrParam = ""; 8075 foreach my $ParamPos (sort {int($a)<=>int($b)} keys(%{$FuncPtrType{"Param"}})) 8076 { 8077 my $ParamTypeId = $FuncPtrType{"Param"}{$ParamPos}{"type"}; 8078 my $ParamName = $FuncPtrType{"Param"}{$ParamPos}{"name"}; 8079 $ParamName = "p".($ParamPos+1) if(not $ParamName); 8080 my $ParamFTypeId = get_FoundationTypeId($ParamTypeId); 8081 if(get_PointerLevel($ParamTypeId)==1 8082 and get_TypeType($ParamFTypeId) eq "Intrinsic") 8083 { 8084 $PtrParam = $ParamName; 8085 last; 8086 } 8087 } 8088 if($PtrParam) 8089 { 8090 $FuncDef .= "{\n"; 8091 $FuncDef .= " free($PtrParam);\n"; 8092 $FuncDef .= "}\n\n"; 8093 } 8094 else { 8095 $FuncDef .= "{}\n\n"; 8096 } 8097 } 8098 else { 8099 $FuncDef .= "{}\n\n"; 8100 } 8101 $Type_Init{"Code"} .= "\n".$FuncDef; 8102 } 8103 else 8104 { 8105 my %ReturnType_Init = initializeParameter(( 8106 "TypeId" => $FuncReturnType_Id, 8107 "Key" => "retval", 8108 "InLine" => 1, 8109 "Value" => "no value", 8110 "ValueTypeId" => 0, 8111 "TargetTypeId" => 0, 8112 "CreateChild" => 0, 8113 "Usage" => "Common", 8114 "RetVal" => 1, 8115 "ParamName" => "retval", 8116 "FuncPtrTypeId" => $FuncPtr_TypeId), 8117 "FuncPtrName" => $AuxFuncName); 8118 if(not $ReturnType_Init{"IsCorrect"}) 8119 { 8120 restore_state($Global_State); 8121 $CurrentBlock = $PreviousBlock; 8122 return (); 8123 } 8124 $ReturnType_Init{"Init"} = alignCode($ReturnType_Init{"Init"}, " ", 0); 8125 $ReturnType_Init{"Call"} = alignCode($ReturnType_Init{"Call"}, " ", 1); 8126 $Type_Init{"Code"} .= $ReturnType_Init{"Code"}; 8127 $Type_Init{"Headers"} = addHeaders($ReturnType_Init{"Headers"}, $Type_Init{"Headers"}); 8128 my ($FuncReturnEType_Id, $Declarations, $Headers) = get_ExtTypeId($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $FuncReturnType_Id); 8129 my $FuncReturnType_Name = get_TypeName($FuncReturnEType_Id); 8130 $Type_Init{"Code"} .= $Declarations; 8131 $Type_Init{"Headers"} = addHeaders($Headers, $Type_Init{"Headers"}); 8132 my $FuncDef = "//auxiliary function\n"; 8133 $FuncDef .= $FuncReturnType_Name."\n".$AuxFuncName."(".create_list(\@FuncParams, " ").")"; 8134 $FuncDef .= "{\n"; 8135 $FuncDef .= $ReturnType_Init{"Init"}; 8136 $FuncDef .= " return ".$ReturnType_Init{"Call"}.";\n}\n\n"; 8137 $Type_Init{"Code"} .= "\n".$FuncDef; 8138 } 8139 $CurrentBlock = $PreviousBlock; 8140 } 8141 } 8142 8143 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 8144 my $Var = $Init_Desc{"Var"}; 8145 8146 # create call 8147 my ($Call, $TmpPreamble) = 8148 convertTypes(( 8149 "InputTypeName"=>$TypeName, 8150 "InputPointerLevel"=>0, 8151 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 8152 "Value"=>"&".$AuxFuncName, 8153 "Key"=>$LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, 8154 "Destination"=>"Param", 8155 "MustConvert"=>0)); 8156 $Type_Init{"Init"} .= $TmpPreamble; 8157 $Type_Init{"Call"} = $Call; 8158 # create type 8159 $Type_Init{"TypeName"} = get_TypeName($Init_Desc{"TypeId"}); 8160 # create call to constraint 8161 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 8162 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 8163 } 8164 else 8165 { 8166 my ($TargetCall, $Target_TmpPreamble) = 8167 convertTypes(( 8168 "InputTypeName"=>$TypeName, 8169 "InputPointerLevel"=>0, 8170 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 8171 "Value"=>"&".$AuxFuncName, 8172 "Key"=>$LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, 8173 "Destination"=>"Target", 8174 "MustConvert"=>0)); 8175 $Type_Init{"TargetCall"} = $TargetCall; 8176 $Type_Init{"Init"} .= $Target_TmpPreamble; 8177 } 8178 8179 # ref handler 8180 if($Type{"Type"} eq "Ref") 8181 { 8182 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 8183 if(get_PointerLevel($BaseRefId) > 0) 8184 { 8185 my $BaseRefName = get_TypeName($BaseRefId); 8186 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 8187 $Type_Init{"Call"} = $Var."_ref"; 8188 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 8189 } 8190 } 8191 $Type_Init{"IsCorrect"} = 1; 8192 return %Type_Init; 8193} 8194 8195sub declare_anon_union($$) 8196{ 8197 my ($Key, $UnionId) = @_; 8198 return "" if($AuxType{$UnionId} or not $UnionId or not $Key); 8199 my %Union = get_Type($UnionId); 8200 my @MembStr = (); 8201 my ($Headers, $Declarations) = ([], ""); 8202 foreach my $Member_Pos (sort {int($a)<=>int($b)} keys(%{$Union{"Memb"}})) 8203 { # create member types string 8204 my $Member_Name = $Union{"Memb"}{$Member_Pos}{"name"}; 8205 my $MemberType_Id = $Union{"Memb"}{$Member_Pos}{"type"}; 8206 my $MemberFType_Id = get_FoundationTypeId($MemberType_Id); 8207 my $MemberType_Name = ""; 8208 if(isAnon(get_TypeName($MemberFType_Id))) 8209 { 8210 my ($FieldEType_Id, $Field_Declarations, $Field_Headers) = get_ExtTypeId($Key, $MemberType_Id); 8211 $Headers = addHeaders($Field_Headers, $Headers); 8212 $Declarations .= $Field_Declarations; 8213 $MemberType_Name = get_TypeName($FieldEType_Id); 8214 } 8215 else { 8216 $MemberType_Name = get_TypeName($MemberFType_Id); 8217 } 8218 my $MembDecl = create_member_decl($MemberType_Name, $Member_Name); 8219 @MembStr = (@MembStr, $MembDecl); 8220 } 8221 my $Type_Name = select_type_name("union_type_".$Key); 8222 $Declarations .= "//auxiliary union type\nunion ".$Type_Name; 8223 $Declarations .= "{\n ".join(";\n ", @MembStr).";};\n\n"; 8224 $AuxType{$UnionId} = "union ".$Type_Name; 8225 $TName_Tid{$AuxType{$UnionId}} = $UnionId; 8226 $TypeInfo{$UnionId}{"Name_Old"} = $Union{"Name"}; 8227 $TypeInfo{$UnionId}{"Name"} = $AuxType{$UnionId}; 8228 return ($Declarations, $Headers); 8229} 8230 8231sub declare_anon_struct($$) 8232{ 8233 my ($Key, $StructId) = @_; 8234 return () if($AuxType{$StructId} or not $StructId or not $Key); 8235 my %Struct = get_Type($StructId); 8236 my @MembStr = (); 8237 my ($Headers, $Declarations) = ([], ""); 8238 foreach my $Member_Pos (sort {int($a)<=>int($b)} keys(%{$Struct{"Memb"}})) 8239 { 8240 my $Member_Name = $Struct{"Memb"}{$Member_Pos}{"name"}; 8241 my $MemberType_Id = $Struct{"Memb"}{$Member_Pos}{"type"}; 8242 my $MemberFType_Id = get_FoundationTypeId($MemberType_Id); 8243 my $MemberType_Name = ""; 8244 if(isAnon(get_TypeName($MemberFType_Id))) 8245 { 8246 my ($FieldEType_Id, $Field_Declarations, $Field_Headers) = get_ExtTypeId($Key, $MemberType_Id); 8247 $Headers = addHeaders($Field_Headers, $Headers); 8248 $Declarations .= $Field_Declarations; 8249 $MemberType_Name = get_TypeName($FieldEType_Id); 8250 } 8251 else { 8252 $MemberType_Name = get_TypeName($MemberFType_Id); 8253 } 8254 my $MembDecl = create_member_decl($MemberType_Name, $Member_Name); 8255 @MembStr = (@MembStr, $MembDecl); 8256 } 8257 my $Type_Name = select_type_name("struct_type_".$Key); 8258 $Declarations .= "//auxiliary struct type\nstruct ".$Type_Name; 8259 $Declarations .= "{\n ".join(";\n ", @MembStr).";};\n\n"; 8260 $AuxType{$StructId} = "struct ".$Type_Name; 8261 $TName_Tid{$AuxType{$StructId}} = $StructId; 8262 $TypeInfo{$StructId}{"Name_Old"} = $Struct{"Name"}; 8263 $TypeInfo{$StructId}{"Name"} = $AuxType{$StructId}; 8264 return ($Declarations, $Headers); 8265} 8266 8267sub create_member_decl($$) 8268{ 8269 my ($TName, $Member) = @_; 8270 if($TName=~/\([\*]+\)/) 8271 { 8272 $TName=~s/\(([\*]+)\)/\($1$Member\)/; 8273 return $TName; 8274 } 8275 else 8276 { 8277 my @ArraySizes = (); 8278 while($TName=~s/(\[[^\[\]]*\])\Z//) { 8279 push(@ArraySizes, $1); 8280 } 8281 return $TName." ".$Member.join("", @ArraySizes); 8282 } 8283} 8284 8285sub assembleStruct(@) 8286{ 8287 my %Init_Desc = @_; 8288 my %Type_Init = (); 8289 my %Type = get_Type($Init_Desc{"TypeId"}); 8290 my $Type_PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 8291 my $StructId = get_FoundationTypeId($Init_Desc{"TypeId"}); 8292 my $StructName = get_TypeName($StructId); 8293 return () if($OpaqueTypes{$StructName}); 8294 my %Struct = get_Type($StructId); 8295 return () if(not keys(%{$Struct{"Memb"}})); 8296 my $Global_State = save_state(); 8297 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 8298 my $Var = $Init_Desc{"Var"}; 8299 if($Type_PointerLevel>0 or $Type{"Type"} eq "Ref" 8300 or not $Init_Desc{"InLine"}) { 8301 $Block_Variable{$CurrentBlock}{$Var} = 1; 8302 } 8303 $Type_Init{"Headers"} = addHeaders([$Struct{"Header"}], $Type_Init{"Headers"}); 8304 my @ParamStr = (); 8305 my $Static = ""; 8306 foreach my $Member_Pos (sort {int($a)<=>int($b)} keys(%{$Struct{"Memb"}})) 8307 { # initialize members 8308 my $Member_Name = $Struct{"Memb"}{$Member_Pos}{"name"}; 8309 if(getSymLang($TestedInterface) eq "C") 8310 { 8311 if($Member_Name eq "c_class" 8312 and $StructName=~/\A(struct |)(XWindowAttributes|Visual|XVisualInfo)\Z/) 8313 { # for X11 8314 $Member_Name = "class"; 8315 } 8316 elsif($Member_Name eq "c_explicit" 8317 and $StructName=~/\A(struct |)(_XkbServerMapRec)\Z/) 8318 { # for X11 8319 $Member_Name = "explicit"; 8320 } 8321 elsif($Member_Name=~/\A(__|)fds_bits\Z/ and $StructName eq "fd_set") 8322 { # for libc 8323 if(defined $Constants{"__USE_XOPEN"}) { 8324 $Member_Name = "fds_bits"; 8325 } 8326 else { 8327 $Member_Name = "__fds_bits"; 8328 } 8329 } 8330 } 8331 my $MemberType_Id = $Struct{"Memb"}{$Member_Pos}{"type"}; 8332 my $MemberFType_Id = get_FoundationTypeId($MemberType_Id); 8333 8334 if(not $Static) 8335 { 8336 if($Member_Pos+1==keys(%{$Struct{"Memb"}})) 8337 { 8338 if(get_TypeName($MemberFType_Id)=~/\[\]/) 8339 { # flexible arrays 8340 $Static = "static "; 8341 } 8342 } 8343 } 8344 8345 if(get_TypeType($MemberFType_Id) eq "Array") 8346 { 8347 my $ArrayElemType_Id = get_FoundationTypeId(get_OneStep_BaseTypeId($MemberFType_Id)); 8348 if(get_TypeType($ArrayElemType_Id)=~/\A(Intrinsic|Enum)\Z/) 8349 { 8350 if(get_TypeAttr($MemberFType_Id, "Count")>1024) { 8351 next; 8352 } 8353 } 8354 else 8355 { 8356 if(get_TypeAttr($MemberFType_Id, "Count")>256) { 8357 next; 8358 } 8359 } 8360 } 8361# my $Member_Access = $Struct{"Memb"}{$Member_Pos}{"access"}; 8362# return () if($Member_Access eq "private" or $Member_Access eq "protected"); 8363 my $Memb_Key = ""; 8364 if($Member_Name) { 8365 $Memb_Key = ($Init_Desc{"Key"})?$Init_Desc{"Key"}."_".$Member_Name:$Member_Name; 8366 } 8367 else { 8368 $Memb_Key = ($Init_Desc{"Key"})?$Init_Desc{"Key"}."_".($Member_Pos+1):"m".($Member_Pos+1); 8369 } 8370 my %Memb_Init = initializeParameter(( 8371 "TypeId" => $MemberType_Id, 8372 "Key" => $Memb_Key, 8373 "InLine" => 1, 8374 "Value" => "no value", 8375 "ValueTypeId" => 0, 8376 "TargetTypeId" => 0, 8377 "CreateChild" => 0, 8378 "Usage" => "Common", 8379 "ParamName" => $Member_Name, 8380 "OuterType_Type" => "Struct", 8381 "OuterType_Id" => $StructId)); 8382 if(not $Memb_Init{"IsCorrect"}) { 8383 restore_state($Global_State); 8384 return (); 8385 } 8386 $Type_Init{"Code"} .= $Memb_Init{"Code"}; 8387 $Type_Init{"Headers"} = addHeaders($Memb_Init{"Headers"}, $Type_Init{"Headers"}); 8388 $Memb_Init{"Call"} = alignCode($Memb_Init{"Call"}, get_paragraph($Memb_Init{"Call"}, 1)." ", 1); 8389 if(getSymLang($TestedInterface) eq "C" 8390 and $OSgroup ne "windows") { 8391 @ParamStr = (@ParamStr, "\.$Member_Name = ".$Memb_Init{"Call"}); 8392 } 8393 else { 8394 @ParamStr = (@ParamStr, $Memb_Init{"Call"}); 8395 } 8396 $Type_Init{"Init"} .= $Memb_Init{"Init"}; 8397 $Type_Init{"Destructors"} .= $Memb_Init{"Destructors"}; 8398 } 8399 if(my $Typedef_Id = get_type_typedef($StructId)) { 8400 $StructName = get_TypeName($Typedef_Id); 8401 } 8402 8403 # initialization 8404 if($Type_PointerLevel==0 and ($Type{"Type"} ne "Ref") and $Init_Desc{"InLine"} and not $Static) 8405 { 8406 my $Conversion = (not isAnon($StructName) and not isAnon($Struct{"Name_Old"}))?"(".$Type{"Name"}.") ":""; 8407 $Type_Init{"Call"} = $Conversion."{".create_list(\@ParamStr, " ")."}"; 8408 $Type_Init{"TypeName"} = $Type{"Name"}; 8409 } 8410 else 8411 { 8412 if(not defined $DisableReuse) { 8413 $ValueCollection{$CurrentBlock}{$Var} = $StructId; 8414 } 8415 if(isAnon($StructName)) 8416 { 8417 my ($AnonStruct_Declarations, $AnonStruct_Headers) = declare_anon_struct($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $StructId); 8418 $Type_Init{"Code"} .= $AnonStruct_Declarations; 8419 $Type_Init{"Headers"} = addHeaders($AnonStruct_Headers, $Type_Init{"Headers"}); 8420 $Type_Init{"Init"} .= $Static.get_TypeName($StructId)." $Var = {".create_list(\@ParamStr, " ")."};\n"; 8421 $Type_Init{"TypeName"} = get_TypeName($StructId); 8422 foreach (1 .. $Type_PointerLevel) { 8423 $Type_Init{"TypeName"} .= "*"; 8424 } 8425 } 8426 else 8427 { 8428 $Type_Init{"Init"} .= $Static.$StructName." $Var = {".create_list(\@ParamStr, " ")."};\n"; 8429 $Type_Init{"TypeName"} = $Type{"Name"}; 8430 } 8431 # create call 8432 my ($Call, $TmpPreamble) = 8433 convertTypes(( 8434 "InputTypeName"=>get_TypeName($StructId), 8435 "InputPointerLevel"=>0, 8436 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 8437 "Value"=>$Var, 8438 "Key"=>$Var, 8439 "Destination"=>"Param", 8440 "MustConvert"=>0)); 8441 $Type_Init{"Init"} .= $TmpPreamble; 8442 $Type_Init{"Call"} = $Call; 8443 # create call for constraint 8444 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 8445 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 8446 } 8447 else 8448 { 8449 my ($TargetCall, $Target_TmpPreamble) = 8450 convertTypes(( 8451 "InputTypeName"=>get_TypeName($StructId), 8452 "InputPointerLevel"=>0, 8453 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 8454 "Value"=>$Var, 8455 "Key"=>$Var, 8456 "Destination"=>"Target", 8457 "MustConvert"=>0)); 8458 $Type_Init{"TargetCall"} = $TargetCall; 8459 $Type_Init{"Init"} .= $Target_TmpPreamble; 8460 } 8461 #ref handler 8462 if($Type{"Type"} eq "Ref") 8463 { 8464 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 8465 if(get_PointerLevel($BaseRefId) > 0) 8466 { 8467 my $BaseRefName = get_TypeName($BaseRefId); 8468 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 8469 $Type_Init{"Call"} = $Var."_ref"; 8470 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 8471 if(not defined $DisableReuse) { 8472 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 8473 } 8474 } 8475 } 8476 } 8477 $Type_Init{"IsCorrect"} = 1; 8478 return %Type_Init; 8479} 8480 8481sub getSomeEnumMember($) 8482{ 8483 my $EnumId = $_[0]; 8484 my %Enum = get_Type($EnumId); 8485 return "" if(not keys(%{$Enum{"Memb"}})); 8486 my @Members = (); 8487 foreach my $MembPos (sort{int($a)<=>int($b)} keys(%{$Enum{"Memb"}})) { 8488 push(@Members, $Enum{"Memb"}{$MembPos}{"name"}); 8489 } 8490 if($RandomCode) { 8491 @Members = mix_array(@Members); 8492 } 8493 my @ValidMembers = (); 8494 foreach my $Member (@Members) 8495 { 8496 if(is_valid_constant($Member)) { 8497 push(@ValidMembers, $Member); 8498 } 8499 } 8500 my $MemberName = $Members[0]; 8501 if($#ValidMembers>=0) { 8502 $MemberName = $ValidMembers[0]; 8503 } 8504 if($Enum{"NameSpace"} and $MemberName 8505 and getSymLang($TestedInterface) eq "C++") { 8506 $MemberName = $Enum{"NameSpace"}."::".$MemberName; 8507 } 8508 return $MemberName; 8509} 8510 8511sub getEnumMembers($) 8512{ 8513 my $EnumId = $_[0]; 8514 my %Enum = get_Type($EnumId); 8515 return () if(not keys(%{$Enum{"Memb"}})); 8516 my @Members = (); 8517 foreach my $MembPos (sort{int($a)<=>int($b)} keys(%{$Enum{"Memb"}})) { 8518 push(@Members, $Enum{"Memb"}{$MembPos}{"name"}); 8519 } 8520 return \@Members; 8521} 8522 8523sub add_NullSpecType(@) 8524{ 8525 my %Init_Desc = @_; 8526 my %NewInit_Desc = %Init_Desc; 8527 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 8528 my $TypeName = get_TypeName($Init_Desc{"TypeId"}); 8529 if($TypeName=~/\&/ or not $Init_Desc{"InLine"}) { 8530 $NewInit_Desc{"InLine"} = 0; 8531 } 8532 else { 8533 $NewInit_Desc{"InLine"} = 1; 8534 } 8535 if($PointerLevel>=1) 8536 { 8537 if($Init_Desc{"OuterType_Type"}!~/\A(Struct|Union|Array)\Z/ 8538 and (isOutParam_NoUsing($Init_Desc{"TypeId"}, $Init_Desc{"ParamName"}, $Init_Desc{"Interface"}) 8539 or $Interface_OutParam{$Init_Desc{"Interface"}}{$Init_Desc{"ParamName"}} 8540 or $Interface_OutParam_NoUsing{$Init_Desc{"Interface"}}{$Init_Desc{"ParamName"}} or $PointerLevel>=2)) 8541 { 8542 $NewInit_Desc{"InLine"} = 0; 8543 $NewInit_Desc{"ValueTypeId"} = reduce_pointer_level($Init_Desc{"TypeId"}); 8544 if($PointerLevel>=2) { 8545 $NewInit_Desc{"Value"} = get_null(); 8546 } 8547 else { 8548 $NewInit_Desc{"OnlyDecl"} = 1; 8549 } 8550 } 8551 else 8552 { 8553 $NewInit_Desc{"Value"} = get_null(); 8554 $NewInit_Desc{"ValueTypeId"} = $Init_Desc{"TypeId"}; 8555 $NewInit_Desc{"ByNull"}=1; 8556 } 8557 } 8558 else { 8559 $NewInit_Desc{"Value"} = "no value"; 8560 } 8561 return %NewInit_Desc; 8562} 8563 8564sub initializeIntrinsic(@) 8565{ 8566 my %Init_Desc = @_; 8567 $Init_Desc{"StrongTypeCompliance"} = 1; 8568 my %Type_Init = initializeByInterface(%Init_Desc); 8569 if($Type_Init{"IsCorrect"}) { 8570 return %Type_Init; 8571 } 8572 else { 8573 return initializeByInterface_OutParam(%Init_Desc); 8574 } 8575} 8576 8577sub initializeRetVal(@) 8578{ 8579 my %Init_Desc = @_; 8580 return () if(get_TypeName($Init_Desc{"TypeId"}) eq "void*"); 8581 my %Type_Init = initializeByInterface(%Init_Desc); 8582 if($Type_Init{"IsCorrect"}) { 8583 return %Type_Init; 8584 } 8585 else { 8586 return initializeByInterface_OutParam(%Init_Desc); 8587 } 8588} 8589 8590sub initializeEnum(@) 8591{ 8592 my %Init_Desc = @_; 8593 return initializeByInterface(%Init_Desc); 8594} 8595 8596sub is_geometry_body($) 8597{ 8598 my $TypeId = $_[0]; 8599 return 0 if(not $TypeId); 8600 my $StructId = get_FoundationTypeId($TypeId); 8601 my %Struct = get_Type($StructId); 8602 return 0 if($Struct{"Name"}!~/rectangle|line/i); 8603 return 0 if($Struct{"Type"} ne "Struct"); 8604 foreach my $Member_Pos (sort {int($a)<=>int($b)} keys(%{$Struct{"Memb"}})) 8605 { 8606 if(get_TypeType(get_FoundationTypeId($Struct{"Memb"}{$Member_Pos}{"type"}))!~/\A(Intrinsic|Enum)\Z/) { 8607 return 0; 8608 } 8609 } 8610 return 1; 8611} 8612 8613sub initializeUnion(@) 8614{ 8615 my %Init_Desc = @_; 8616 $Init_Desc{"Strong"}=1; 8617 my %Type_Init = initializeByInterface_OutParam(%Init_Desc); 8618 if($Type_Init{"IsCorrect"}) { 8619 return %Type_Init; 8620 } 8621 else 8622 { 8623 delete($Init_Desc{"Strong"}); 8624 %Type_Init = initializeByInterface(%Init_Desc); 8625 if($Type_Init{"IsCorrect"}) { 8626 return %Type_Init; 8627 } 8628 else 8629 { 8630 %Type_Init = assembleUnion(%Init_Desc); 8631 if($Type_Init{"IsCorrect"}) { 8632 return %Type_Init; 8633 } 8634 else { 8635 return initializeByInterface_OutParam(%Init_Desc); 8636 } 8637 } 8638 } 8639} 8640 8641sub initializeStruct(@) 8642{ 8643 my %Init_Desc = @_; 8644 if(is_geometry_body($Init_Desc{"TypeId"})) 8645 { # GdkRectangle 8646 return assembleStruct(%Init_Desc); 8647 } 8648# $Init_Desc{"Strong"}=1; 8649# my %Type_Init = initializeByInterface_OutParam(%Init_Desc); 8650# if($Type_Init{"IsCorrect"}) 8651# { 8652# return %Type_Init; 8653# } 8654# else 8655# { 8656# delete($Init_Desc{"Strong"}); 8657 $Init_Desc{"OnlyReturn"}=1; 8658 my %Type_Init = initializeByInterface(%Init_Desc); 8659 if($Type_Init{"IsCorrect"}) { 8660 return %Type_Init; 8661 } 8662 else 8663 { 8664 return () if($Init_Desc{"OnlyByInterface"}); 8665 delete($Init_Desc{"OnlyReturn"}); 8666 %Type_Init = initializeByInterface_OutParam(%Init_Desc); 8667 if($Type_Init{"IsCorrect"}) { 8668 return %Type_Init; 8669 } 8670 else 8671 { 8672 $Init_Desc{"OnlyData"}=1; 8673 %Type_Init = initializeByInterface(%Init_Desc); 8674 if($Type_Init{"IsCorrect"}) { 8675 return %Type_Init; 8676 } 8677 else 8678 { 8679 delete($Init_Desc{"OnlyData"}); 8680 %Type_Init = initializeByAlienInterface(%Init_Desc); 8681 if($Type_Init{"IsCorrect"}) { 8682 return %Type_Init; 8683 } 8684 else 8685 { 8686 %Type_Init = initializeSubClass_Struct(%Init_Desc); 8687 if($Type_Init{"IsCorrect"}) { 8688 return %Type_Init; 8689 } 8690 else 8691 { 8692 if($Init_Desc{"DoNotAssembly"}) { 8693 return initializeByField(%Init_Desc); 8694 } 8695 else 8696 { 8697 %Type_Init = assembleStruct(%Init_Desc); 8698 if($Type_Init{"IsCorrect"}) { 8699 return %Type_Init; 8700 } 8701 else 8702 { 8703 %Type_Init = assembleClass(%Init_Desc); 8704 if($Type_Init{"IsCorrect"}) { 8705 return %Type_Init; 8706 } 8707 else { 8708 return initializeByField(%Init_Desc); 8709 } 8710 } 8711 } 8712 } 8713 } 8714 } 8715 } 8716 } 8717} 8718 8719sub initializeByAlienInterface(@) 8720{ # GtkWidget* gtk_plug_new (GdkNativeWindow socket_id) 8721 # return GtkPlug* 8722 my %Init_Desc = @_; 8723 if($Init_Desc{"ByInterface"} = find_alien_interface($Init_Desc{"TypeId"})) 8724 { 8725 my %Type_Init = initializeByInterface(%Init_Desc); 8726 if(not $Type_Init{"ByNull"}) { 8727 return %Type_Init; 8728 } 8729 } 8730 return (); 8731} 8732 8733sub find_alien_interface($) 8734{ 8735 my $TypeId = $_[0]; 8736 return "" if(not $TypeId); 8737 return "" if(get_PointerLevel($TypeId)!=1); 8738 my $StructId = get_FoundationTypeId($TypeId); 8739 return "" if(get_TypeType($StructId) ne "Struct"); 8740 my $Desirable = get_TypeName($StructId); 8741 $Desirable=~s/\Astruct //g; 8742 $Desirable=~s/\A[_]+//g; 8743 while($Desirable=~s/([a-z]+)([A-Z][a-z]+)/$1_$2/g){}; 8744 $Desirable = lc($Desirable); 8745 my @Cnadidates = ($Desirable."_new", $Desirable."_create"); 8746 foreach my $Candiate (@Cnadidates) 8747 { 8748 if(defined $CompleteSignature{$Candiate} 8749 and $CompleteSignature{$Candiate}{"Header"} 8750 and get_PointerLevel($CompleteSignature{$Candiate}{"Return"})==1) { 8751 return $Candiate; 8752 } 8753 } 8754 return ""; 8755} 8756 8757sub initializeByField(@) 8758{ # FIXME: write body of this function 8759 my %Init_Desc = @_; 8760 return (); 8761} 8762 8763sub initializeSubClass_Struct(@) 8764{ 8765 my %Init_Desc = @_; 8766 $Init_Desc{"TypeId_Changed"} = $Init_Desc{"TypeId"} if(not $Init_Desc{"TypeId_Changed"}); 8767 my $StructId = get_FoundationTypeId($Init_Desc{"TypeId"}); 8768 my $StructName = get_TypeName($StructId); 8769 my $PLevel = get_PointerLevel($Init_Desc{"TypeId"}); 8770 return () if(get_TypeType($StructId) ne "Struct" or $PLevel==0); 8771 foreach my $SubClassId (keys(%{$Struct_SubClasses{$StructId}})) 8772 { 8773 $Init_Desc{"TypeId"} = get_TypeId($SubClassId, $PLevel); 8774 next if(not $Init_Desc{"TypeId"}); 8775 $Init_Desc{"DoNotAssembly"} = 1; 8776 my %Type_Init = initializeType(%Init_Desc); 8777 if($Type_Init{"IsCorrect"}) { 8778 return %Type_Init; 8779 } 8780 } 8781 if(my $ParentId = get_TypeId($Struct_Parent{$StructId}, $PLevel)) 8782 { 8783 $Init_Desc{"TypeId"} = $ParentId; 8784 $Init_Desc{"DoNotAssembly"} = 1; 8785 $Init_Desc{"OnlyByInterface"} = 1; 8786 $Init_Desc{"KeyWords"} = $StructName; 8787 $Init_Desc{"KeyWords"}=~s/\Astruct //; 8788 my %Type_Init = initializeType(%Init_Desc); 8789 if($Type_Init{"IsCorrect"} 8790 and (not $Type_Init{"Interface"} or get_word_coinsidence($Type_Init{"Interface"}, $Init_Desc{"KeyWords"})>0)) { 8791 return %Type_Init; 8792 } 8793 } 8794} 8795 8796sub get_TypeId($$) 8797{ 8798 my ($BaseTypeId, $PLevel) = @_; 8799 return 0 if(not $BaseTypeId); 8800 if(my @DerivedTypes = sort {length($a)<=>length($b)} 8801 keys(%{$BaseType_PLevel_Type{$BaseTypeId}{$PLevel}})) { 8802 return $DerivedTypes[0]; 8803 } 8804 elsif(my $NewTypeId = register_new_type($BaseTypeId, $PLevel)) { 8805 return $NewTypeId; 8806 } 8807 else { 8808 return 0; 8809 } 8810} 8811 8812sub assembleUnion(@) 8813{ 8814 my %Init_Desc = @_; 8815 my %Type_Init = (); 8816 my %Type = get_Type($Init_Desc{"TypeId"}); 8817 my $Type_PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 8818 my $UnionId = get_FoundationTypeId($Init_Desc{"TypeId"}); 8819 my %UnionType = get_Type($UnionId); 8820 my $UnionName = $UnionType{"Name"}; 8821 return () if($OpaqueTypes{$UnionName}); 8822 return () if(not keys(%{$UnionType{"Memb"}})); 8823 my $Global_State = save_state(); 8824 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 8825 my $Var = $Init_Desc{"Var"}; 8826 if($Type_PointerLevel>0 or $Type{"Type"} eq "Ref" 8827 or not $Init_Desc{"InLine"}) { 8828 $Block_Variable{$CurrentBlock}{$Var} = 1; 8829 } 8830 $Type_Init{"Headers"} = addHeaders([$UnionType{"Header"}], $Type_Init{"Headers"}); 8831 my (%Memb_Init, $SelectedMember_Name) = (); 8832 foreach my $Member_Pos (sort {int($a)<=>int($b)} keys(%{$UnionType{"Memb"}})) 8833 { # initialize members 8834 my $Member_Name = $UnionType{"Memb"}{$Member_Pos}{"name"}; 8835 my $MemberType_Id = $UnionType{"Memb"}{$Member_Pos}{"type"}; 8836 my $Memb_Key = ""; 8837 if($Member_Name) { 8838 $Memb_Key = ($Init_Desc{"Key"})?$Init_Desc{"Key"}."_".$Member_Name:$Member_Name; 8839 } 8840 else { 8841 $Memb_Key = ($Init_Desc{"Key"})?$Init_Desc{"Key"}."_".($Member_Pos+1):"m".($Member_Pos+1); 8842 } 8843 %Memb_Init = initializeParameter(( 8844 "TypeId" => $MemberType_Id, 8845 "Key" => $Memb_Key, 8846 "InLine" => 1, 8847 "Value" => "no value", 8848 "ValueTypeId" => 0, 8849 "TargetTypeId" => 0, 8850 "CreateChild" => 0, 8851 "Usage" => "Common", 8852 "ParamName" => $Member_Name, 8853 "OuterType_Type" => "Union", 8854 "OuterType_Id" => $UnionId)); 8855 next if(not $Memb_Init{"IsCorrect"}); 8856 $SelectedMember_Name = $Member_Name; 8857 last; 8858 } 8859 if(not $Memb_Init{"IsCorrect"}) 8860 { 8861 restore_state($Global_State); 8862 return (); 8863 } 8864 $Type_Init{"Code"} .= $Memb_Init{"Code"}; 8865 $Type_Init{"Headers"} = addHeaders($Memb_Init{"Headers"}, $Type_Init{"Headers"}); 8866 $Type_Init{"Init"} .= $Memb_Init{"Init"}; 8867 $Type_Init{"Destructors"} .= $Memb_Init{"Destructors"}; 8868 $Memb_Init{"Call"} = alignCode($Memb_Init{"Call"}, get_paragraph($Memb_Init{"Call"}, 1)." ", 1); 8869 if(my $Typedef_Id = get_type_typedef($UnionId)) { 8870 $UnionName = get_TypeName($Typedef_Id); 8871 } 8872 # initialization 8873 if($Type_PointerLevel==0 and ($Type{"Type"} ne "Ref") and $Init_Desc{"InLine"}) 8874 { 8875 my $Conversion = (not isAnon($UnionName) and not isAnon($UnionType{"Name_Old"}))?"(".$Type{"Name"}.") ":""; 8876 if($TestedInterface=~/\A(_Z|\?)/) { # C++ 8877 $Type_Init{"Call"} = $Conversion."{".$Memb_Init{"Call"}."}"; 8878 } 8879 else { 8880 $Type_Init{"Call"} = $Conversion."{\.$SelectedMember_Name = ".$Memb_Init{"Call"}."}"; 8881 } 8882 $Type_Init{"TypeName"} = $Type{"Name"}; 8883 } 8884 else 8885 { 8886 if(not defined $DisableReuse) { 8887 $ValueCollection{$CurrentBlock}{$Var} = $UnionId; 8888 } 8889 if(isAnon($UnionName)) 8890 { 8891 my ($AnonUnion_Declarations, $AnonUnion_Headers) = declare_anon_union($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $UnionId); 8892 $Type_Init{"Code"} .= $AnonUnion_Declarations; 8893 $Type_Init{"Headers"} = addHeaders($AnonUnion_Headers, $Type_Init{"Headers"}); 8894 if($TestedInterface=~/\A(_Z|\?)/) { # C++ 8895 $Type_Init{"Init"} .= get_TypeName($UnionId)." $Var = {".$Memb_Init{"Call"}."};\n"; 8896 } 8897 else { 8898 $Type_Init{"Init"} .= get_TypeName($UnionId)." $Var = {\.$SelectedMember_Name = ".$Memb_Init{"Call"}."};\n"; 8899 } 8900 $Type_Init{"TypeName"} = "union ".get_TypeName($UnionId); 8901 foreach (1 .. $Type_PointerLevel) { 8902 $Type_Init{"TypeName"} .= "*"; 8903 } 8904 } 8905 else 8906 { 8907 if($TestedInterface=~/\A(_Z|\?)/) { # C++ 8908 $Type_Init{"Init"} .= $UnionName." $Var = {".$Memb_Init{"Call"}."};\n"; 8909 } 8910 else { 8911 $Type_Init{"Init"} .= $UnionName." $Var = {\.$SelectedMember_Name = ".$Memb_Init{"Call"}."};\n"; 8912 } 8913 $Type_Init{"TypeName"} = $Type{"Name"}; 8914 } 8915 #create call 8916 my ($Call, $TmpPreamble) = 8917 convertTypes(( 8918 "InputTypeName"=>get_TypeName($UnionId), 8919 "InputPointerLevel"=>0, 8920 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 8921 "Value"=>$Var, 8922 "Key"=>$Var, 8923 "Destination"=>"Param", 8924 "MustConvert"=>0)); 8925 $Type_Init{"Init"} .= $TmpPreamble; 8926 $Type_Init{"Call"} = $Call; 8927 #create call in constraint 8928 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 8929 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 8930 } 8931 else 8932 { 8933 my ($TargetCall, $Target_TmpPreamble) = 8934 convertTypes(( 8935 "InputTypeName"=>get_TypeName($UnionId), 8936 "InputPointerLevel"=>0, 8937 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 8938 "Value"=>$Var, 8939 "Key"=>$Var, 8940 "Destination"=>"Target", 8941 "MustConvert"=>0)); 8942 $Type_Init{"TargetCall"} = $TargetCall; 8943 $Type_Init{"Init"} .= $Target_TmpPreamble; 8944 } 8945 #ref handler 8946 if($Type{"Type"} eq "Ref") 8947 { 8948 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 8949 if(get_PointerLevel($BaseRefId) > 0) 8950 { 8951 my $BaseRefName = get_TypeName($BaseRefId); 8952 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 8953 $Type_Init{"Call"} = $Var."_ref"; 8954 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 8955 if(not defined $DisableReuse) { 8956 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 8957 } 8958 } 8959 } 8960 } 8961 $Type_Init{"IsCorrect"} = 1; 8962 return %Type_Init; 8963} 8964 8965sub initializeClass(@) 8966{ 8967 my %Init_Desc = @_; 8968 my %Type_Init = (); 8969 if($Init_Desc{"CreateChild"}) 8970 { 8971 $Init_Desc{"InheritingPriority"} = "High"; 8972 return assembleClass(%Init_Desc); 8973 } 8974 else 8975 { 8976 if((get_TypeType($Init_Desc{"TypeId"}) eq "Typedef")) 8977 { # try to initialize typedefs by interface return value 8978 %Type_Init = initializeByInterface(%Init_Desc); 8979 if($Type_Init{"IsCorrect"}) { 8980 return %Type_Init; 8981 } 8982 } 8983 $Init_Desc{"InheritingPriority"} = "Low"; 8984 %Type_Init = assembleClass(%Init_Desc); 8985 if($Type_Init{"IsCorrect"}) { 8986 return %Type_Init; 8987 } 8988 else 8989 { 8990 if(isAbstractClass(get_FoundationTypeId($Init_Desc{"TypeId"}))) 8991 { 8992 $Init_Desc{"InheritingPriority"} = "High"; 8993 %Type_Init = assembleClass(%Init_Desc); 8994 if($Type_Init{"IsCorrect"}) { 8995 return %Type_Init; 8996 } 8997 else { 8998 return initializeByInterface(%Init_Desc); 8999 } 9000 } 9001 else 9002 { 9003 %Type_Init = initializeByInterface(%Init_Desc); 9004 if($Type_Init{"IsCorrect"}) { 9005 return %Type_Init; 9006 } 9007 else 9008 { 9009 $Init_Desc{"InheritingPriority"} = "High"; 9010 %Type_Init = assembleClass(%Init_Desc); 9011 if($Type_Init{"IsCorrect"}) { 9012 return %Type_Init; 9013 } 9014 else { 9015 return initializeByInterface_OutParam(%Init_Desc); 9016 } 9017 } 9018 } 9019 } 9020 } 9021} 9022 9023sub has_public_destructor($$) 9024{ 9025 my ($ClassId, $DestrType) = @_; 9026 my $ClassName = get_TypeName($ClassId); 9027 return $Cache{"has_public_destructor"}{$ClassId}{$DestrType} if($Cache{"has_public_destructor"}{$ClassId}{$DestrType}); 9028 foreach my $Destructor (sort keys(%{$Class_Destructors{$ClassId}})) 9029 { 9030 if($Destructor=~/\Q$DestrType\E/) 9031 { 9032 if(not $CompleteSignature{$Destructor}{"Protected"}) 9033 { 9034 $Cache{"has_public_destructor"}{$ClassId}{$DestrType} = $Destructor; 9035 return $Destructor; 9036 } 9037 else { 9038 return ""; 9039 } 9040 } 9041 } 9042 $Cache{"has_public_destructor"}{$ClassId}{$DestrType} = "Default"; 9043 return "Default"; 9044} 9045 9046sub findConstructor($$) 9047{ 9048 my ($ClassId, $Key) = @_; 9049 return () if(not $ClassId); 9050 foreach my $Constructor (get_CompatibleInterfaces($ClassId, "Construct", "")) 9051 { 9052 my %Interface_Init = callInterfaceParameters(( 9053 "Interface"=>$Constructor, 9054 "Key"=>$Key, 9055 "ObjectCall"=>"no object")); 9056 if($Interface_Init{"IsCorrect"}) 9057 { 9058 $Interface_Init{"Interface"} = $Constructor; 9059 return %Interface_Init; 9060 } 9061 } 9062 return (); 9063} 9064 9065sub assembleClass(@) 9066{ 9067 my %Init_Desc = @_; 9068 my %Type_Init = (); 9069 my $Global_State = save_state(); 9070 my $CreateDestructor = 1; 9071 $Type_Init{"TypeName"} = get_TypeName($Init_Desc{"TypeId"}); 9072 my $ClassId = get_FoundationTypeId($Init_Desc{"TypeId"}); 9073 my $ClassName = get_TypeName($ClassId); 9074 my $PointerLevel = get_PointerLevel($Init_Desc{"TypeId"}); 9075 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 9076 my $Var = $Init_Desc{"Var"}; 9077 $Block_Variable{$CurrentBlock}{$Var} = 1; 9078 my %Obj_Init = findConstructor($ClassId, $Init_Desc{"Key"}); 9079 if(not $Obj_Init{"IsCorrect"}) { 9080 restore_state($Global_State); 9081 return (); 9082 } 9083 $Type_Init{"Init"} = $Obj_Init{"Init"}; 9084 $Type_Init{"Destructors"} = $Obj_Init{"Destructors"}; 9085 $Type_Init{"Code"} = $Obj_Init{"Code"}; 9086 $Type_Init{"Headers"} = addHeaders($Obj_Init{"Headers"}, $Type_Init{"Headers"}); 9087 my $NeedToInheriting = (isAbstractClass($ClassId) or $Init_Desc{"CreateChild"} or isNotInCharge($Obj_Init{"Interface"}) or $CompleteSignature{$Obj_Init{"Interface"}}{"Protected"}); 9088 if($Init_Desc{"InheritingPriority"} eq "Low" 9089 and $NeedToInheriting) { 9090 restore_state($Global_State); 9091 return (); 9092 } 9093 my $HeapStack = (($PointerLevel eq 0) and has_public_destructor($ClassId, "D1") and not $Init_Desc{"ObjectInit"} and (not $Init_Desc{"RetVal"} or get_TypeType($Init_Desc{"TypeId"}) ne "Ref"))?"Stack":"Heap"; 9094 my $ChildName = getSubClassName($ClassName); 9095 if($NeedToInheriting) 9096 { 9097 if($Obj_Init{"Call"}=~/\A(\Q$ClassName\E([\n]*)\()/) { 9098 substr($Obj_Init{"Call"}, index($Obj_Init{"Call"}, $1), pos($1) + length($1)) = $ChildName.$2."("; 9099 } 9100 $UsedConstructors{$ClassId}{$Obj_Init{"Interface"}} = 1; 9101 $IntSubClass{$TestedInterface}{$ClassId} = 1; 9102 $Create_SubClass{$ClassId} = 1; 9103 $SubClass_Instance{$Var} = 1; 9104 $SubClass_ObjInstance{$Var} = 1 if($Init_Desc{"ObjectInit"}); 9105 } 9106 my %AutoFinalCode_Init = (); 9107 my $Typedef_Id = detect_typedef($Init_Desc{"TypeId"}); 9108 if(get_TypeName($ClassId)=~/list/i or get_TypeName($Typedef_Id)=~/list/i) 9109 { # auto final code 9110 %AutoFinalCode_Init = get_AutoFinalCode($Obj_Init{"Interface"}, ($HeapStack eq "Stack")?$Var:"*".$Var); 9111 if($AutoFinalCode_Init{"IsCorrect"}) { 9112 $Init_Desc{"InLine"} = 0; 9113 } 9114 } 9115 if($Obj_Init{"PreCondition"} 9116 or $Obj_Init{"PostCondition"}) { 9117 $Init_Desc{"InLine"} = 0; 9118 } 9119 # check precondition 9120 if($Obj_Init{"PreCondition"}) { 9121 $Type_Init{"Init"} .= $Obj_Init{"PreCondition"}."\n"; 9122 } 9123 if($HeapStack eq "Stack") 9124 { 9125 $CreateDestructor = 0; 9126 if($Init_Desc{"InLine"} and ($PointerLevel eq 0)) 9127 { 9128 $Type_Init{"Call"} = $Obj_Init{"Call"}; 9129 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 9130 delete($Block_Variable{$CurrentBlock}{$Var}); 9131 } 9132 else 9133 { 9134 if(not defined $DisableReuse) { 9135 $ValueCollection{$CurrentBlock}{$Var} = $ClassId; 9136 } 9137 # $Type_Init{"Init"} .= "//parameter initialization\n"; 9138 my $ConstructedName = ($NeedToInheriting)?$ChildName:$ClassName; 9139 $Type_Init{"Init"} .= correct_init_stmt($ConstructedName." $Var = ".$Obj_Init{"Call"}.";\n", $ConstructedName, $Var); 9140 # create call 9141 my ($Call, $TmpPreamble) = 9142 convertTypes(( 9143 "InputTypeName"=>$ConstructedName, 9144 "InputPointerLevel"=>0, 9145 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 9146 "Value"=>$Var, 9147 "Key"=>$Var, 9148 "Destination"=>"Param", 9149 "MustConvert"=>0)); 9150 $Type_Init{"Init"} .= $TmpPreamble; 9151 $Type_Init{"Call"} = $Call; 9152 #call to constraint 9153 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 9154 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 9155 } 9156 else 9157 { 9158 my ($TargetCall, $Target_TmpPreamble) = 9159 convertTypes(( 9160 "InputTypeName"=>$ConstructedName, 9161 "InputPointerLevel"=>0, 9162 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 9163 "Value"=>$Var, 9164 "Key"=>$Var, 9165 "Destination"=>"Target", 9166 "MustConvert"=>0)); 9167 $Type_Init{"TargetCall"} = $TargetCall; 9168 $Type_Init{"Init"} .= $Target_TmpPreamble; 9169 } 9170 } 9171 } 9172 elsif($HeapStack eq "Heap") 9173 { 9174 if($Init_Desc{"InLine"} and ($PointerLevel eq 1)) 9175 { 9176 $Type_Init{"Call"} = "new ".$Obj_Init{"Call"}; 9177 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 9178 $CreateDestructor = 0; 9179 delete($Block_Variable{$CurrentBlock}{$Var}); 9180 } 9181 else 9182 { 9183 if(not defined $DisableReuse) { 9184 $ValueCollection{$CurrentBlock}{$Var} = get_TypeIdByName("$ClassName*"); 9185 } 9186 #$Type_Init{"Init"} .= "//parameter initialization\n"; 9187 if($NeedToInheriting) 9188 { 9189 if($Init_Desc{"ConvertToBase"}) { 9190 $Type_Init{"Init"} .= $ClassName."* $Var = ($ClassName*)new ".$Obj_Init{"Call"}.";\n"; 9191 } 9192 else { 9193 $Type_Init{"Init"} .= $ChildName."* $Var = new ".$Obj_Init{"Call"}.";\n"; 9194 } 9195 } 9196 else { 9197 $Type_Init{"Init"} .= $ClassName."* $Var = new ".$Obj_Init{"Call"}.";\n"; 9198 } 9199 #create call 9200 my ($Call, $TmpPreamble) = 9201 convertTypes(( 9202 "InputTypeName"=>"$ClassName*", 9203 "InputPointerLevel"=>1, 9204 "OutputTypeId"=>($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}, 9205 "Value"=>$Var, 9206 "Key"=>$Var, 9207 "Destination"=>"Param", 9208 "MustConvert"=>0)); 9209 $Type_Init{"Init"} .= $TmpPreamble; 9210 $Type_Init{"Call"} = $Call; 9211 #call to constraint 9212 if($Init_Desc{"TargetTypeId"}==$Init_Desc{"TypeId"}) { 9213 $Type_Init{"TargetCall"} = $Type_Init{"Call"}; 9214 } 9215 else 9216 { 9217 my ($TargetCall, $Target_TmpPreamble) = 9218 convertTypes(( 9219 "InputTypeName"=>"$ClassName*", 9220 "InputPointerLevel"=>1, 9221 "OutputTypeId"=>$Init_Desc{"TargetTypeId"}, 9222 "Value"=>$Var, 9223 "Key"=>$Var, 9224 "Destination"=>"Target", 9225 "MustConvert"=>0)); 9226 $Type_Init{"TargetCall"} = $TargetCall; 9227 $Type_Init{"Init"} .= $Target_TmpPreamble; 9228 } 9229 } 9230 # destructor for object 9231 if($CreateDestructor) # mayCallDestructors($ClassId) 9232 { 9233 if($HeapStack eq "Heap") 9234 { 9235 if($NeedToInheriting) 9236 { 9237 if(has_public_destructor($ClassId, "D2")) { 9238 $Type_Init{"Destructors"} .= "delete($Var);\n"; 9239 } 9240 } 9241 else 9242 { 9243 if(has_public_destructor($ClassId, "D0")) { 9244 $Type_Init{"Destructors"} .= "delete($Var);\n"; 9245 } 9246 } 9247 } 9248 } 9249 } 9250 # check postcondition 9251 if($Obj_Init{"PostCondition"}) { 9252 $Type_Init{"Init"} .= $Obj_Init{"PostCondition"}."\n"; 9253 } 9254 if($Obj_Init{"ReturnRequirement"}) 9255 { 9256 if($HeapStack eq "Stack") { 9257 $Obj_Init{"ReturnRequirement"}=~s/(\$0|\$obj)/$Var/gi; 9258 } 9259 else { 9260 $Obj_Init{"ReturnRequirement"}=~s/(\$0|\$obj)/*$Var/gi; 9261 } 9262 $Type_Init{"Init"} .= $Obj_Init{"ReturnRequirement"}."\n"; 9263 } 9264 if($Obj_Init{"FinalCode"}) 9265 { 9266 $Type_Init{"Init"} .= "//final code\n"; 9267 $Type_Init{"Init"} .= $Obj_Init{"FinalCode"}."\n"; 9268 } 9269 if(get_TypeType($Init_Desc{"TypeId"}) eq "Ref") 9270 { # obsolete 9271 my $BaseRefId = get_OneStep_BaseTypeId($Init_Desc{"TypeId"}); 9272 if($HeapStack eq "Heap") 9273 { 9274 if(get_PointerLevel($BaseRefId)>1) 9275 { 9276 my $BaseRefName = get_TypeName($BaseRefId); 9277 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 9278 $Type_Init{"Call"} = $Var."_ref"; 9279 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 9280 if(not defined $DisableReuse) { 9281 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 9282 } 9283 } 9284 } 9285 else 9286 { 9287 if(get_PointerLevel($BaseRefId)>0) 9288 { 9289 my $BaseRefName = get_TypeName($BaseRefId); 9290 $Type_Init{"Init"} .= $BaseRefName." ".$Var."_ref = ".$Type_Init{"Call"}.";\n"; 9291 $Type_Init{"Call"} = $Var."_ref"; 9292 $Block_Variable{$CurrentBlock}{$Var."_ref"} = 1; 9293 if(not defined $DisableReuse) { 9294 $ValueCollection{$CurrentBlock}{$Var."_ref"} = $Init_Desc{"TypeId"}; 9295 } 9296 } 9297 } 9298 } 9299 $Type_Init{"IsCorrect"} = 1; 9300 if($Typedef_Id) 9301 { 9302 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($Typedef_Id), $Type_Init{"Headers"}); 9303 foreach my $Elem ("Call", "Init") { 9304 $Type_Init{$Elem} = cover_by_typedef($Type_Init{$Elem}, $ClassId, $Typedef_Id); 9305 } 9306 } 9307 else { 9308 $Type_Init{"Headers"} = addHeaders(getTypeHeaders($ClassId), $Type_Init{"Headers"}); 9309 } 9310 if($AutoFinalCode_Init{"IsCorrect"}) 9311 { 9312 $Type_Init{"Init"} = $AutoFinalCode_Init{"Init"}.$Type_Init{"Init"}.$AutoFinalCode_Init{"PreCondition"}.$AutoFinalCode_Init{"Call"}.";\n".$AutoFinalCode_Init{"FinalCode"}.$AutoFinalCode_Init{"PostCondition"}; 9313 $Type_Init{"Code"} .= $AutoFinalCode_Init{"Code"}; 9314 $Type_Init{"Destructors"} .= $AutoFinalCode_Init{"Destructors"}; 9315 $Type_Init{"Headers"} = addHeaders($AutoFinalCode_Init{"Headers"}, $Type_Init{"Headers"}); 9316 } 9317 return %Type_Init; 9318} 9319 9320sub cover_by_typedef($$$) 9321{ 9322 my ($Code, $Type_Id, $Typedef_Id) = @_; 9323 if($Class_SubClassTypedef{$Type_Id}) { 9324 $Typedef_Id = $Class_SubClassTypedef{$Type_Id}; 9325 } 9326 return $Code if(not $Code or not $Type_Id or not $Typedef_Id); 9327 return $Code if(not $Type_Id or not $Typedef_Id); 9328 return $Code if(get_TypeType($Type_Id)!~/\A(Class|Struct)\Z/); 9329 my $Type_Name = get_TypeName($Type_Id); 9330 my $Typedef_Name = get_TypeName($Typedef_Id); 9331 if(length($Typedef_Name)>=length($Type_Name)) { 9332 return $Code; 9333 } 9334 my $Child_Name_Old = getSubClassName($Type_Name); 9335 my $Child_Name_New = getSubClassName($Typedef_Name); 9336 $Class_SubClassTypedef{$Type_Id}=$Typedef_Id; 9337 $Code=~s/(\W|\A)\Q$Child_Name_Old\E(\W|\Z)/$1$Child_Name_New$2/g; 9338 if($Type_Name=~/\W\Z/) 9339 { 9340 $Code=~s/(\W|\A)\Q$Type_Name\E(\W|\Z)/$1$Typedef_Name$2/g; 9341 $Code=~s/(\W|\A)\Q$Type_Name\E(\w|\Z)/$1$Typedef_Name $2/g; 9342 } 9343 else { 9344 $Code=~s/(\W|\A)\Q$Type_Name\E(\W|\Z)/$1$Typedef_Name$2/g; 9345 } 9346 return $Code; 9347} 9348 9349sub get_type_typedef($) 9350{ 9351 my $ClassId = $_[0]; 9352 if($Class_SubClassTypedef{$ClassId}) { 9353 return $Class_SubClassTypedef{$ClassId}; 9354 } 9355 my @Types = (keys(%{$Type_Typedef{$ClassId}})); 9356 @Types = sort {lc(get_TypeName($a)) cmp lc(get_TypeName($b))} @Types; 9357 @Types = sort {length(get_TypeName($a)) <=> length(get_TypeName($b))} @Types; 9358 if($#Types==0) { 9359 return $Types[0]; 9360 } 9361 else { 9362 return 0; 9363 } 9364} 9365 9366sub is_used_var($$) 9367{ 9368 my ($Block, $Var) = @_; 9369 return ($Block_Variable{$Block}{$Var} or $ValueCollection{$Block}{$Var} 9370 or not is_allowed_var_name($Var)); 9371} 9372 9373sub select_var_name($$) 9374{ 9375 my ($Var_Name, $SuffixCandidate) = @_; 9376 my $OtherVarPrefix = 1; 9377 my $Candidate = $Var_Name; 9378 if($Var_Name=~/\Ap\d+\Z/) 9379 { 9380 $Var_Name = "p"; 9381 while(is_used_var($CurrentBlock, $Candidate)) 9382 { 9383 $Candidate = $Var_Name.$OtherVarPrefix; 9384 $OtherVarPrefix += 1; 9385 } 9386 } 9387 else 9388 { 9389 if($SuffixCandidate) 9390 { 9391 $Candidate = $Var_Name."_".$SuffixCandidate; 9392 if(not is_used_var($CurrentBlock, $Candidate)) { 9393 return $Candidate; 9394 } 9395 } 9396 if($Var_Name eq "description" and is_used_var($CurrentBlock, $Var_Name) 9397 and not is_used_var($CurrentBlock, "desc")) { 9398 return "desc"; 9399 } 9400 elsif($Var_Name eq "system" and is_used_var($CurrentBlock, $Var_Name) 9401 and not is_used_var($CurrentBlock, "sys")) { 9402 return "sys"; 9403 } 9404 while(is_used_var($CurrentBlock, $Candidate)) 9405 { 9406 $Candidate = $Var_Name."_".$OtherVarPrefix; 9407 $OtherVarPrefix += 1; 9408 } 9409 } 9410 return $Candidate; 9411} 9412 9413sub select_type_name($) 9414{ 9415 my $Type_Name = $_[0]; 9416 my $OtherPrefix = 1; 9417 my $NameCandidate = $Type_Name; 9418 while($TName_Tid{$NameCandidate} 9419 or $TName_Tid{"struct ".$NameCandidate} 9420 or $TName_Tid{"union ".$NameCandidate}) 9421 { 9422 $NameCandidate = $Type_Name."_".$OtherPrefix; 9423 $OtherPrefix += 1; 9424 } 9425 return $NameCandidate; 9426} 9427 9428sub select_func_name($) 9429{ 9430 my $FuncName = $_[0]; 9431 my $OtherFuncPrefix = 1; 9432 my $Candidate = $FuncName; 9433 while(is_used_func_name($Candidate)) 9434 { 9435 $Candidate = $FuncName."_".$OtherFuncPrefix; 9436 $OtherFuncPrefix += 1; 9437 } 9438 return $Candidate; 9439} 9440 9441sub is_used_func_name($) 9442{ 9443 my $FuncName = $_[0]; 9444 return 1 if($FuncNames{$FuncName}); 9445 foreach my $FuncTypeId (keys(%AuxFunc)) 9446 { 9447 if($AuxFunc{$FuncTypeId} eq $FuncName) { 9448 return 1; 9449 } 9450 } 9451 return 0; 9452} 9453 9454sub get_TypeStackId($) 9455{ 9456 my $TypeId = $_[0]; 9457 my $FoundationId = get_FoundationTypeId($TypeId); 9458 if(get_TypeType($FoundationId) eq "Intrinsic") 9459 { 9460 my %BaseTypedef = goToFirst($TypeId, "Typedef"); 9461 if(get_TypeType($BaseTypedef{"Tid"}) eq "Typedef") { 9462 return $BaseTypedef{"Tid"}; 9463 } 9464 else { 9465 return $FoundationId; 9466 } 9467 } 9468 else { 9469 return $FoundationId; 9470 } 9471} 9472 9473sub initializeType(@) 9474{ 9475 my %Init_Desc = @_; 9476 return () if(not $Init_Desc{"TypeId"}); 9477 my %Type_Init = (); 9478 my $Global_State = save_state(); 9479 my $TypeName = get_TypeName($Init_Desc{"TypeId"}); 9480 my $SpecValue = $Init_Desc{"Value"}; 9481 %Init_Desc = add_VirtualSpecType(%Init_Desc); 9482 $Init_Desc{"Var"} = select_var_name($LongVarNames?$Init_Desc{"Key"}:$Init_Desc{"ParamName"}, $Init_Desc{"ParamNameExt"}); 9483 if(($TypeName eq "...") and (($Init_Desc{"Value"} eq "no value") or ($Init_Desc{"Value"} eq ""))) 9484 { 9485 $Type_Init{"IsCorrect"} = 1; 9486 $Type_Init{"Call"} = ""; 9487 return %Type_Init; 9488 } 9489 if($TypeName eq "struct __va_list_tag*") 9490 { # initialize va_list 9491 if(my $VaList_Tid = $TName_Tid{"va_list"}) { 9492 $Init_Desc{"TypeId"} = $VaList_Tid; 9493 } 9494 %Type_Init = emptyDeclaration(%Init_Desc); 9495 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9496 return %Type_Init; 9497 } 9498 my $FoundationId = get_FoundationTypeId($Init_Desc{"TypeId"}); 9499 if(not $Init_Desc{"FoundationType_Type"}) { 9500 $Init_Desc{"FoundationType_Type"} = get_TypeType($FoundationId); 9501 } 9502 my $TypeStackId = get_TypeStackId($Init_Desc{"TypeId"}); 9503 if(isCyclical(\@RecurTypeId, $TypeStackId)) 9504 { # initialize by null for cyclical types 9505 if($Init_Desc{"Value"} ne "no value" and $Init_Desc{"Value"} ne "") 9506 { 9507 return () if(get_TypeType($TypeStackId) eq "Typedef" and $TypeName!~/_t/); 9508 %Type_Init = initializeByValue(%Init_Desc); 9509 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9510 return %Type_Init; 9511 } 9512 else 9513 { 9514 %Init_Desc = add_NullSpecType(%Init_Desc); 9515 if($Init_Desc{"OnlyDecl"}) 9516 { 9517 %Type_Init = emptyDeclaration(%Init_Desc); 9518 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9519 return %Type_Init; 9520 } 9521 elsif(($Init_Desc{"Value"} ne "no value") and ($Init_Desc{"Value"} ne "")) 9522 { 9523 %Type_Init = initializeByValue(%Init_Desc); 9524 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9525 return %Type_Init; 9526 } 9527 else { 9528 return (); 9529 } 9530 } 9531 } 9532 else 9533 { 9534 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9535 push(@RecurTypeId, $TypeStackId); 9536 } 9537 } 9538 if(not $Init_Desc{"TargetTypeId"}) 9539 { # repair target type 9540 $Init_Desc{"TargetTypeId"} = $Init_Desc{"TypeId"}; 9541 } 9542 if($Init_Desc{"RetVal"} and get_PointerLevel($Init_Desc{"TypeId"})>=1 9543 and not $Init_Desc{"TypeType_Changed"} and $TypeName!~/(\W|\Z)const(\W|\Z)/) 9544 { # return value 9545 if(($Init_Desc{"Value"} ne "no value") and ($Init_Desc{"Value"} ne "")) 9546 { # try to initialize type by value 9547 %Type_Init = initializeByValue(%Init_Desc); 9548 if($Type_Init{"IsCorrect"}) 9549 { 9550 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9551 pop(@RecurTypeId); 9552 } 9553 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9554 return %Type_Init; 9555 } 9556 } 9557 else 9558 { 9559 %Type_Init = initializeRetVal(%Init_Desc); 9560 if($Type_Init{"IsCorrect"}) 9561 { 9562 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9563 pop(@RecurTypeId); 9564 } 9565 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9566 return %Type_Init; 9567 } 9568 } 9569 } 9570 if($Init_Desc{"OnlyDecl"}) 9571 { 9572 %Type_Init = emptyDeclaration(%Init_Desc); 9573 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9574 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9575 pop(@RecurTypeId); 9576 } 9577 return %Type_Init; 9578 } 9579 my $RealTypeId = ($Init_Desc{"TypeId_Changed"})?$Init_Desc{"TypeId_Changed"}:$Init_Desc{"TypeId"}; 9580 my $RealFTypeType = get_TypeType(get_FoundationTypeId($RealTypeId)); 9581 if(($RealFTypeType eq "Intrinsic") and not $SpecValue and not $Init_Desc{"Reuse"} and not $Init_Desc{"OnlyByValue"} and $Init_Desc{"ParamName"}!~/num|width|height/i) 9582 { # initializing intrinsics by the interface 9583 my %BaseTypedef = goToFirst($RealTypeId, "Typedef"); 9584 if(get_TypeType($BaseTypedef{"Tid"}) eq "Typedef" 9585 and $BaseTypedef{"Name"}!~/(int|short|long|error|real|float|double|bool|boolean|pointer|count|byte|len)\d*(_t|)\Z/i 9586 and $BaseTypedef{"Name"}!~/char|str|size|enum/i 9587 and $BaseTypedef{"Name"}!~/(\A|::)u(32|64)/i) 9588 { # try to initialize typedefs to intrinsic types 9589 my $Global_State1 = save_state(); 9590 my %Init_Desc_Copy = %Init_Desc; 9591 $Init_Desc_Copy{"InLine"} = 0 if($Init_Desc{"ParamName"}!~/\Ap\d+\Z/); 9592 $Init_Desc_Copy{"TypeId"} = $RealTypeId; 9593 restore_state($Global_State); 9594 %Type_Init = initializeIntrinsic(%Init_Desc_Copy); 9595 if($Type_Init{"IsCorrect"}) 9596 { 9597 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9598 pop(@RecurTypeId); 9599 } 9600 return %Type_Init; 9601 } 9602 else { 9603 restore_state($Global_State1); 9604 } 9605 } 9606 } 9607 if(($Init_Desc{"Value"} ne "no value") and ($Init_Desc{"Value"} ne "")) 9608 { # try to initialize type by value 9609 %Type_Init = initializeByValue(%Init_Desc); 9610 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9611 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9612 pop(@RecurTypeId); 9613 } 9614 return %Type_Init; 9615 } 9616 else { 9617 %Type_Init = selectInitializingWay(%Init_Desc); 9618 } 9619 if($Type_Init{"IsCorrect"}) 9620 { 9621 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9622 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9623 pop(@RecurTypeId); 9624 } 9625 return %Type_Init; 9626 } 9627 else { 9628 restore_state($Global_State); 9629 } 9630 if($Init_Desc{"TypeId_Changed"}) 9631 { 9632 $Init_Desc{"TypeId"} = $Init_Desc{"TypeId_Changed"}; 9633 %Init_Desc = add_VirtualSpecType(%Init_Desc); 9634 if(($Init_Desc{"Value"} ne "no value") and ($Init_Desc{"Value"} ne "")) 9635 { # try to initialize type by value 9636 %Type_Init = initializeByValue(%Init_Desc); 9637 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9638 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9639 pop(@RecurTypeId); 9640 } 9641 return %Type_Init; 9642 } 9643 } 9644 # finally initializing by null (0) 9645 %Init_Desc = add_NullSpecType(%Init_Desc); 9646 if($Init_Desc{"OnlyDecl"}) 9647 { 9648 %Type_Init = emptyDeclaration(%Init_Desc); 9649 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9650 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9651 pop(@RecurTypeId); 9652 } 9653 return %Type_Init; 9654 } 9655 elsif(($Init_Desc{"Value"} ne "no value") and ($Init_Desc{"Value"} ne "")) 9656 { 9657 %Type_Init = initializeByValue(%Init_Desc); 9658 $Type_Init{"Headers"} = addHeaders($Init_Desc{"Headers"}, $Type_Init{"Headers"}); 9659 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9660 pop(@RecurTypeId); 9661 } 9662 return %Type_Init; 9663 } 9664 else 9665 { 9666 if($Init_Desc{"FoundationType_Type"} ne "Array") { 9667 pop(@RecurTypeId); 9668 } 9669 return (); 9670 } 9671} 9672 9673sub selectInitializingWay(@) 9674{ 9675 my %Init_Desc = @_; 9676 if($Init_Desc{"FoundationType_Type"} eq "Class") { 9677 return initializeClass(%Init_Desc); 9678 } 9679 elsif($Init_Desc{"FoundationType_Type"} eq "Intrinsic") { 9680 return initializeIntrinsic(%Init_Desc); 9681 } 9682 elsif($Init_Desc{"FoundationType_Type"} eq "Struct") { 9683 return initializeStruct(%Init_Desc); 9684 } 9685 elsif($Init_Desc{"FoundationType_Type"} eq "Union") { 9686 return initializeUnion(%Init_Desc); 9687 } 9688 elsif($Init_Desc{"FoundationType_Type"} eq "Enum") { 9689 return initializeEnum(%Init_Desc); 9690 } 9691 elsif($Init_Desc{"FoundationType_Type"} eq "Array") { 9692 return initializeArray(%Init_Desc); 9693 } 9694 elsif($Init_Desc{"FoundationType_Type"} eq "FuncPtr") { 9695 return initializeFuncPtr(%Init_Desc); 9696 } 9697 else { 9698 return (); 9699 } 9700} 9701 9702sub is_const_type($) 9703{ # char const* 9704 #! char*const 9705 my $TypeName = uncover_typedefs($_[0]); 9706 return ($TypeName=~/(\W|\A)const(\W)/); 9707} 9708 9709sub clearSyntax($) 9710{ 9711 my $Expression = $_[0]; 9712 $Expression=~s/\*\&//g; 9713 $Expression=~s/\&\*//g; 9714 $Expression=~s/\(\*(\w+)\)\./$1\-\>/ig; 9715 $Expression=~s/\(\&(\w+)\)\-\>/$1\./ig; 9716 $Expression=~s/\*\(\&(\w+)\)/$1/ig; 9717 $Expression=~s/\*\(\(\&(\w+)\)\)/$1/ig; 9718 $Expression=~s/\&\(\*(\w+)\)/$1/ig; 9719 $Expression=~s/\&\(\(\*(\w+)\)\)/$1/ig; 9720 $Expression=~s/(?<=[\s()])\(([a-z_]\w*)\)[ ]*,/$1,/ig; 9721 $Expression=~s/,(\s*)\(([a-z_]\w*)\)[ ]*(\)|,)/,$1$2/ig; 9722 $Expression=~s/(?<=[^\$])\(\(([a-z_]\w*)\)\)/\($1\)/ig; 9723 return $Expression; 9724} 9725 9726sub apply_default_value($$) 9727{ 9728 my ($Interface, $ParamPos) = @_; 9729 return 0 if(defined $DisableDefaultValues); 9730 return 0 if(not defined $CompleteSignature{$Interface}{"Param"}{$ParamPos}); 9731 return 0 if(not $CompleteSignature{$Interface}{"Param"}{$ParamPos}{"default"}); 9732 if($Interface eq $TestedInterface 9733 or replace_c2c1($Interface) eq replace_c2c1($TestedInterface)) 9734 { # do not use defaults for target symbol 9735 return 0; 9736 } 9737 return 1; 9738} 9739 9740sub sort_AppendInsert(@) 9741{ 9742 my @Interfaces = @_; 9743 my (@Add, @Append, @Push, @Init, @Insert) = (); 9744 foreach my $Interface (@Interfaces) 9745 { 9746 if($CompleteSignature{$Interface}{"ShortName"}=~/add/i) { 9747 push(@Add, $Interface); 9748 } 9749 elsif($CompleteSignature{$Interface}{"ShortName"}=~/append/i) { 9750 push(@Append, $Interface); 9751 } 9752 elsif($CompleteSignature{$Interface}{"ShortName"}=~/push/i) { 9753 push(@Push, $Interface); 9754 } 9755 elsif($CompleteSignature{$Interface}{"ShortName"}=~/init/i) { 9756 push(@Init, $Interface); 9757 } 9758 elsif($CompleteSignature{$Interface}{"ShortName"}=~/insert/) { 9759 push(@Insert, $Interface); 9760 } 9761 } 9762 return (@Add, @Append, @Push, @Init, @Insert); 9763} 9764 9765sub get_AutoFinalCode($$) 9766{ 9767 my ($Interface, $ObjectCall) = @_; 9768 my (@AddMethods, @AppendMethods, @PushMethods, @InitMethods, @InsertMethods) = (); 9769 if($CompleteSignature{$Interface}{"Constructor"}) 9770 { 9771 my $ClassId = $CompleteSignature{$Interface}{"Class"}; 9772 my @Methods = sort_AppendInsert(keys(%{$Class_Method{$ClassId}})); 9773 return () if($#Methods<0); 9774 foreach my $Method (@Methods) 9775 { 9776 my %Method_Init = callInterface(( 9777 "Interface"=>$Method, 9778 "ObjectCall"=>$ObjectCall, 9779 "DoNotReuse"=>1, 9780 "InsertCall")); 9781 if($Method_Init{"IsCorrect"}) { 9782 return %Method_Init; 9783 } 9784 } 9785 return (); 9786 } 9787 else { 9788 return (); 9789 } 9790} 9791 9792sub initializeParameter(@) 9793{ 9794 my %ParamDesc = @_; 9795 my $ParamPos = $ParamDesc{"ParamPos"}; 9796 my ($TypeOfSpecType, $SpectypeCode, $SpectypeValue); 9797 my (%Param_Init, $PreCondition, $PostCondition, $InitCode, $DeclCode); 9798 my $ObjectCall = $ParamDesc{"AccessToParam"}->{"obj"}; 9799 my $FoundationType_Id = get_FoundationTypeId($ParamDesc{"TypeId"}); 9800 if((not $ParamDesc{"SpecType"}) and ($ObjectCall ne "create object") 9801 and not $Interface_OutParam_NoUsing{$ParamDesc{"Interface"}}{$ParamDesc{"ParamName"}} 9802 and not $Interface_OutParam{$ParamDesc{"Interface"}}{$ParamDesc{"ParamName"}}) { 9803 $ParamDesc{"SpecType"} = chooseSpecType($ParamDesc{"TypeId"}, "common_param", $ParamDesc{"Interface"}); 9804 } 9805 if($ParamDesc{"SpecType"} and not isCyclical(\@RecurSpecType, $ParamDesc{"SpecType"})) 9806 { 9807 $IntSpecType{$TestedInterface}{$ParamDesc{"SpecType"}} = 1; 9808 $SpectypeCode = $SpecType{$ParamDesc{"SpecType"}}{"GlobalCode"} if(not $SpecCode{$ParamDesc{"SpecType"}}); 9809 $SpecCode{$ParamDesc{"SpecType"}} = 1; 9810 push(@RecurSpecType, $ParamDesc{"SpecType"}); 9811 $TypeOfSpecType = get_TypeIdByName($SpecType{$ParamDesc{"SpecType"}}{"DataType"}); 9812 $SpectypeValue = $SpecType{$ParamDesc{"SpecType"}}{"Value"}; 9813 if($SpectypeValue=~/\A[A-Z_0-9]+\Z/ 9814 and get_TypeType($FoundationType_Id)=~/\A(Struct|Union)\Z/i) { 9815 $ParamDesc{"InLine"} = 1; 9816 } 9817 $DeclCode = $SpecType{$ParamDesc{"SpecType"}}{"DeclCode"}; 9818 if($DeclCode) 9819 { 9820 $DeclCode .= "\n"; 9821 if($DeclCode=~/\$0/ or $DeclCode=~/\$$ParamPos(\Z|\D)/) { 9822 $ParamDesc{"InLine"} = 0; 9823 } 9824 } 9825 $InitCode = $SpecType{$ParamDesc{"SpecType"}}{"InitCode"}; 9826 if($InitCode) 9827 { 9828 $InitCode .= "\n"; 9829 if($InitCode=~/\$0/ or $InitCode=~/\$$ParamPos(\Z|\D)/) { 9830 $ParamDesc{"InLine"} = 0; 9831 } 9832 } 9833 $Param_Init{"FinalCode"} = $SpecType{$ParamDesc{"SpecType"}}{"FinalCode"}; 9834 if($Param_Init{"FinalCode"}) 9835 { 9836 $Param_Init{"FinalCode"} .= "\n"; 9837 if($Param_Init{"FinalCode"}=~/\$0/ 9838 or $Param_Init{"FinalCode"}=~/\$$ParamPos(\Z|\D)/) { 9839 $ParamDesc{"InLine"} = 0; 9840 } 9841 } 9842 $PreCondition = $SpecType{$ParamDesc{"SpecType"}}{"PreCondition"}; 9843 if($PreCondition=~/\$0/ or $PreCondition=~/\$$ParamPos(\Z|\D)/) { 9844 $ParamDesc{"InLine"} = 0; 9845 } 9846 $PostCondition = $SpecType{$ParamDesc{"SpecType"}}{"PostCondition"}; 9847 if($PostCondition=~/\$0/ or $PostCondition=~/\$$ParamPos(\Z|\D)/) { 9848 $ParamDesc{"InLine"} = 0; 9849 } 9850 foreach my $Lib (keys(%{$SpecType{$ParamDesc{"SpecType"}}{"Libs"}})) { 9851 $SpecLibs{$Lib} = 1; 9852 } 9853 9854 } 9855 elsif(apply_default_value($ParamDesc{"Interface"}, $ParamDesc{"ParamPos"})) 9856 { 9857 $Param_Init{"IsCorrect"} = 1; 9858 $Param_Init{"Call"} = ""; 9859 return %Param_Init; 9860 } 9861 if(($ObjectCall ne "no object") and ($ObjectCall ne "create object")) 9862 { 9863 if(($ObjectCall=~/\A\*/) or ($ObjectCall=~/\A\&/)) { 9864 $ObjectCall = "(".$ObjectCall.")"; 9865 } 9866 $SpectypeValue=~s/\$obj/$ObjectCall/g; 9867 $SpectypeValue = clearSyntax($SpectypeValue); 9868 } 9869 if($ParamDesc{"Value"} ne "" 9870 and $ParamDesc{"Value"} ne "no value") { 9871 $SpectypeValue = $ParamDesc{"Value"}; 9872 } 9873 if($SpectypeValue=~/\$[^\(\[]/) 9874 { # access to other parameters 9875 foreach my $ParamKey (keys(%{$ParamDesc{"AccessToParam"}})) 9876 { 9877 my $AccessToParam_Value = $ParamDesc{"AccessToParam"}->{$ParamKey}; 9878 $SpectypeValue=~s/\$\Q$ParamKey\E([^0-9]|\Z)/$AccessToParam_Value$1/g; 9879 } 9880 } 9881 if($SpectypeValue) 9882 { 9883 my %ParsedValueCode = parseCode($SpectypeValue, "Value"); 9884 if(not $ParsedValueCode{"IsCorrect"}) 9885 { 9886 pop(@RecurSpecType); 9887 return (); 9888 } 9889 $Param_Init{"Init"} .= $ParsedValueCode{"CodeBefore"}; 9890 $Param_Init{"FinalCode"} .= $ParsedValueCode{"CodeAfter"}; 9891 $SpectypeValue = $ParsedValueCode{"Code"}; 9892 $Param_Init{"Headers"} = addHeaders($ParsedValueCode{"Headers"}, $ParsedValueCode{"Headers"}); 9893 $Param_Init{"Code"} .= $ParsedValueCode{"NewGlobalCode"}; 9894 } 9895 if(get_TypeType($FoundationType_Id)=~/\A(Struct|Class|Union)\Z/i 9896 and $CompleteSignature{$ParamDesc{"Interface"}}{"Constructor"} 9897 and get_PointerLevel($ParamDesc{"TypeId"})==0) { 9898 $ParamDesc{"InLine"} = 0; 9899 } 9900 if($DeclCode) 9901 { 9902 $Param_Init{"Headers"} = addHeaders(getTypeHeaders($ParamDesc{"TypeId"}), $Param_Init{"Headers"}); 9903 $Param_Init{"Call"} = select_var_name($ParamDesc{"ParamName"}, ""); 9904 $Param_Init{"TargetCall"} = $Param_Init{"Value"}?$Param_Init{"Value"}:$Param_Init{"Call"}; 9905 } 9906 elsif($ParamDesc{"Usage"} eq "Common") 9907 { 9908 my %Type_Init = initializeType(( 9909 "Interface" => $ParamDesc{"Interface"}, 9910 "TypeId" => $ParamDesc{"TypeId"}, 9911 "Key" => $ParamDesc{"Key"}, 9912 "InLine" => $ParamDesc{"InLine"}, 9913 "Value" => $SpectypeValue, 9914 "ValueTypeId" => $TypeOfSpecType, 9915 "TargetTypeId" => $TypeOfSpecType, 9916 "CreateChild" => $ParamDesc{"CreateChild"}, 9917 "ParamName" => $ParamDesc{"ParamName"}, 9918 "ParamPos" => $ParamDesc{"ParamPos"}, 9919 "ConvertToBase" => $ParamDesc{"ConvertToBase"}, 9920 "StrongConvert" => $ParamDesc{"StrongConvert"}, 9921 "ObjectInit" => $ParamDesc{"ObjectInit"}, 9922 "DoNotReuse" => $ParamDesc{"DoNotReuse"}, 9923 "RetVal" => $ParamDesc{"RetVal"}, 9924 "ParamNameExt" => $ParamDesc{"ParamNameExt"}, 9925 "MaxParamPos" => $ParamDesc{"MaxParamPos"}, 9926 "OuterType_Id" => $ParamDesc{"OuterType_Id"}, 9927 "OuterType_Type" => $ParamDesc{"OuterType_Type"}, 9928 "Index" => $ParamDesc{"Index"}, 9929 "InLineArray" => $ParamDesc{"InLineArray"}, 9930 "IsString" => $ParamDesc{"IsString"}, 9931 "FuncPtrName" => $ParamDesc{"FuncPtrName"}, 9932 "FuncPtrTypeId" => $ParamDesc{"FuncPtrTypeId"})); 9933 if(not $Type_Init{"IsCorrect"}) 9934 { 9935 pop(@RecurSpecType); 9936 return (); 9937 } 9938 $Param_Init{"Init"} .= $Type_Init{"Init"}; 9939 $Param_Init{"Call"} .= $Type_Init{"Call"}; 9940 $Param_Init{"TargetCall"} = $Type_Init{"TargetCall"}; 9941 $Param_Init{"Code"} .= $Type_Init{"Code"}; 9942 $Param_Init{"Destructors"} .= $Type_Init{"Destructors"}; 9943 $Param_Init{"FinalCode"} .= $Type_Init{"FinalCode"}; 9944 $Param_Init{"PreCondition"} .= $Type_Init{"PreCondition"}; 9945 $Param_Init{"PostCondition"} .= $Type_Init{"PostCondition"}; 9946 $Param_Init{"Headers"} = addHeaders($Type_Init{"Headers"}, $Param_Init{"Headers"}); 9947 $Param_Init{"ByNull"} = $Type_Init{"ByNull"}; 9948 } 9949 else 9950 { 9951 $Param_Init{"Headers"} = addHeaders(getTypeHeaders($ParamDesc{"TypeId"}), $Param_Init{"Headers"}); 9952 if(my $Target = $ParamDesc{"AccessToParam"}->{"0"}) { 9953 $Param_Init{"TargetCall"} = $Target; 9954 } 9955 } 9956 my $TargetCall = $Param_Init{"TargetCall"}; 9957 if($TargetCall=~/\A(\*|\&)/) { 9958 $TargetCall = "(".$TargetCall.")"; 9959 } 9960 if($SpectypeCode) 9961 { 9962 my $PreviousBlock = $CurrentBlock; 9963 $CurrentBlock = $CurrentBlock."_code_".$ParamDesc{"SpecType"}; 9964 my %ParsedCode = parseCode($SpectypeCode, "Code"); 9965 $CurrentBlock = $PreviousBlock; 9966 if(not $ParsedCode{"IsCorrect"}) 9967 { 9968 pop(@RecurSpecType); 9969 return (); 9970 } 9971 foreach my $Header (@{$ParsedCode{"Headers"}}) { 9972 $SpecTypeHeaders{get_filename($Header)}=1; 9973 } 9974 $Param_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Param_Init{"Headers"}); 9975 $Param_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}.$ParsedCode{"Code"}; 9976 } 9977 if($ObjectCall eq "create object") 9978 { 9979 $ObjectCall = $Param_Init{"Call"}; 9980 if($ObjectCall=~/\A\*/ or $ObjectCall=~/\A\&/) { 9981 $ObjectCall = "(".$ObjectCall.")"; 9982 } 9983 } 9984 if($DeclCode) 9985 { 9986 if($ObjectCall ne "no object") { 9987 $DeclCode=~s/\$obj/$ObjectCall/g; 9988 } 9989 $DeclCode=~s/\$0/$TargetCall/g; 9990 my %ParsedCode = parseCode($DeclCode, "Code"); 9991 if(not $ParsedCode{"IsCorrect"}) 9992 { 9993 pop(@RecurSpecType); 9994 return (); 9995 } 9996 $DeclCode = clearSyntax($DeclCode); 9997 $Param_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Param_Init{"Headers"}); 9998 $Param_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}; 9999 $DeclCode = $ParsedCode{"Code"}; 10000 $Param_Init{"Init"} .= "//decl code\n".$DeclCode."\n"; 10001 } 10002 if($InitCode) 10003 { 10004 if($ObjectCall ne "no object") { 10005 $InitCode=~s/\$obj/$ObjectCall/g; 10006 } 10007 $InitCode=~s/\$0/$TargetCall/g; 10008 my %ParsedCode = parseCode($InitCode, "Code"); 10009 if(not $ParsedCode{"IsCorrect"}) 10010 { 10011 pop(@RecurSpecType); 10012 return (); 10013 } 10014 $InitCode = clearSyntax($InitCode); 10015 $Param_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Param_Init{"Headers"}); 10016 $Param_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}; 10017 $InitCode = $ParsedCode{"Code"}; 10018 $Param_Init{"Init"} .= "//init code\n".$InitCode."\n"; 10019 } 10020 if($Param_Init{"FinalCode"}) 10021 { 10022 if($ObjectCall ne "no object") { 10023 $Param_Init{"FinalCode"}=~s/\$obj/$ObjectCall/g; 10024 } 10025 $Param_Init{"FinalCode"}=~s/\$0/$TargetCall/g; 10026 my %ParsedCode = parseCode($Param_Init{"FinalCode"}, "Code"); 10027 if(not $ParsedCode{"IsCorrect"}) 10028 { 10029 pop(@RecurSpecType); 10030 return (); 10031 } 10032 $Param_Init{"FinalCode"} = clearSyntax($Param_Init{"FinalCode"}); 10033 $Param_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Param_Init{"Headers"}); 10034 $Param_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}; 10035 $Param_Init{"FinalCode"} = $ParsedCode{"Code"}; 10036 } 10037 if(not defined $Template2Code or $ParamDesc{"Interface"} eq $TestedInterface) 10038 { 10039 $Param_Init{"PreCondition"} .= constraint_for_parameter($ParamDesc{"Interface"}, $SpecType{$ParamDesc{"SpecType"}}{"DataType"}, "precondition", $PreCondition, $ObjectCall, $TargetCall); 10040 $Param_Init{"PostCondition"} .= constraint_for_parameter($ParamDesc{"Interface"}, $SpecType{$ParamDesc{"SpecType"}}{"DataType"}, "postcondition", $PostCondition, $ObjectCall, $TargetCall); 10041 } 10042 pop(@RecurSpecType); 10043 $Param_Init{"IsCorrect"} = 1; 10044 return %Param_Init; 10045} 10046 10047sub constraint_for_parameter($$$$$$) 10048{ 10049 my ($Interface, $DataType, $ConditionType, $Condition, $ObjectCall, $TargetCall) = @_; 10050 return "" if(not $Interface or not $ConditionType or not $Condition); 10051 my $Condition_Comment = $Condition; 10052 $Condition_Comment=~s/\$obj/$ObjectCall/g if($ObjectCall ne "no object" and $ObjectCall ne ""); 10053 $Condition_Comment=~s/\$0/$TargetCall/g if($TargetCall ne ""); 10054 $Condition_Comment = clearSyntax($Condition_Comment); 10055 $Condition = $Condition_Comment; 10056 while($Condition_Comment=~s/([^\\])"/$1\\\"/g){} 10057 $ConstraintNum{$Interface}+=1; 10058 my $ParameterObject = ($ObjectCall eq "create object")?"object":"parameter"; 10059 $RequirementsCatalog{$Interface}{$ConstraintNum{$Interface}} = "$ConditionType for the $ParameterObject: \'$Condition_Comment\'"; 10060 my $ReqId = get_ShortName($Interface).".".normalize_num($ConstraintNum{$Interface}); 10061 if(my $Format = is_printable($DataType)) 10062 { 10063 my $Comment = "$ConditionType for the $ParameterObject failed: \'$Condition_Comment\', parameter value: $Format"; 10064 $TraceFunc{"REQva"}=1; 10065 return "REQva(\"$ReqId\",\n$Condition,\n\"$Comment\",\n$TargetCall);\n"; 10066 } 10067 else 10068 { 10069 my $Comment = "$ConditionType for the $ParameterObject failed: \'$Condition_Comment\'"; 10070 $TraceFunc{"REQ"}=1; 10071 return "REQ(\"$ReqId\",\n\"$Comment\",\n$Condition);\n"; 10072 } 10073} 10074 10075sub is_array_count($$) 10076{ 10077 my ($ParamName_Prev, $ParamName_Next) = @_; 10078 return ($ParamName_Next=~/\A(\Q$ParamName_Prev\E|)[_]*(n|l|c|s)[_]*(\Q$ParamName_Prev\E|)\Z/i 10079 or $ParamName_Next=~/len|size|amount|count|num|number/i); 10080} 10081 10082sub add_VirtualProxy($$$$) 10083{ 10084 my ($Interface, $OutParamPos, $Order, $Step) = @_; 10085 return if(keys(%{$CompleteSignature{$Interface}{"Param"}})<$Step+1); 10086 foreach my $Param_Pos (sort {($Order eq "forward")?int($a)<=>int($b):int($b)<=>int($a)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 10087 { 10088 if(apply_default_value($Interface, $Param_Pos)) { 10089 next; 10090 } 10091 my $Prev_Pos = ($Order eq "forward")?$Param_Pos-$Step:$Param_Pos+$Step; 10092 next if(($Order eq "forward")?$Prev_Pos<0:$Prev_Pos>keys(%{$CompleteSignature{$Interface}{"Param"}})-1); 10093 my $ParamName = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"name"}; 10094 my $ParamTypeId = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"type"}; 10095 my $ParamTypeName = get_TypeName($ParamTypeId); 10096 my $ParamName_Prev = $CompleteSignature{$Interface}{"Param"}{$Prev_Pos}{"name"}; 10097 my $ParamTypeId_Prev = $CompleteSignature{$Interface}{"Param"}{$Prev_Pos}{"type"}; 10098 if(not $InterfaceSpecType{$Interface}{"SpecParam"}{$Param_Pos}) 10099 { 10100 next if($OutParamPos ne "" and $OutParamPos==$Prev_Pos); 10101 my $ParamFTypeId = get_FoundationTypeId($ParamTypeId); 10102 if(isIntegerType(get_TypeName($ParamFTypeId)) and get_PointerLevel($ParamTypeId)==0 10103 and get_PointerLevel($ParamTypeId_Prev)>=1 and $ParamName_Prev 10104 and is_array_count($ParamName_Prev, $ParamName) and not isOutParam_NoUsing($ParamTypeId_Prev, $ParamName_Prev, $Interface) 10105 and not $OutParamInterface_Pos{$Interface}{$Prev_Pos} and not $OutParamInterface_Pos_NoUsing{$Interface}{$Prev_Pos}) 10106 { 10107 if(isArray($ParamTypeId_Prev, $ParamName_Prev, $Interface)) { 10108 $ProxyValue{$Interface}{$Param_Pos} = $DEFAULT_ARRAY_AMOUNT; 10109 } 10110 elsif(isBuffer($ParamTypeId_Prev, $ParamName_Prev, $Interface)) { 10111 $ProxyValue{$Interface}{$Param_Pos} = $BUFF_SIZE; 10112 } 10113 elsif(isString($ParamTypeId_Prev, $ParamName_Prev, $Interface)) 10114 { 10115 if($ParamName_Prev=~/file|src|uri|buf|dir|url/i) { 10116 $ProxyValue{$Interface}{$Param_Pos} = "1"; 10117 } 10118 elsif($ParamName_Prev!~/\Ap\d+\Z/i) { 10119 $ProxyValue{$Interface}{$Param_Pos} = length($ParamName_Prev); 10120 } 10121 } 10122 elsif($ParamName_Prev=~/buf/i) { 10123 $ProxyValue{$Interface}{$Param_Pos} = "1"; 10124 } 10125 } 10126 elsif($Order eq "forward" and isString($ParamTypeId_Prev, $ParamName_Prev, $Interface) 10127 and ($ParamName_Prev=~/\A[_0-9]*(format|fmt)[_0-9]*\Z/i) and ($ParamTypeName eq "...")) 10128 { 10129 $ProxyValue{$Interface}{$Param_Pos-1} = "\"\%d\""; 10130 $ProxyValue{$Interface}{$Param_Pos} = "1"; 10131 } 10132 } 10133 } 10134} 10135 10136sub isExactValueAble($) 10137{ 10138 my $TypeName = $_[0]; 10139 return $TypeName=~/\A(char const\*|wchar_t const\*|wint_t|int|bool|double|float|long double|char|long|long long|long long int|long int)\Z/; 10140} 10141 10142sub select_obj_name($$) 10143{ 10144 my ($Key, $ClassId) = @_; 10145 my $ClassName = get_TypeName($ClassId); 10146 if(my $NewName = getParamNameByTypeName($ClassName)) { 10147 return $NewName; 10148 } 10149 else { 10150 return (($Key)?"src":"obj"); 10151 } 10152} 10153 10154sub getParamNameByTypeName($) 10155{ 10156 my $TypeName = get_type_short_name(remove_quals($_[0])); 10157 return "" if(not $TypeName or $TypeName=~/\(|\)|<|>/); 10158 while($TypeName=~s/\A\w+\:\://g){ }; 10159 while($TypeName=~s/(\*|\&|\[|\])//g){ }; 10160 $TypeName=~s/(\A\s+|\s+\Z)//g; 10161 return "Db" if($TypeName eq "sqlite3"); 10162 return "tif" if($TypeName eq "TIFF"); 10163 my $ShortTypeName = cut_NamePrefix($TypeName); 10164 if($ShortTypeName ne $TypeName 10165 and is_allowed_var_name(lc($ShortTypeName))) 10166 { 10167 $TypeName = $ShortTypeName; 10168 return lc($ShortTypeName); 10169 } 10170 if($TypeName=~/[A-Z]+/) 10171 { 10172 if(is_allowed_var_name(lc($TypeName))) { 10173 return lc($TypeName); 10174 } 10175 } 10176 return ""; 10177} 10178 10179sub is_allowed_var_name($) 10180{ 10181 my $Candidate = $_[0]; 10182 return (not $IsKeyword{$Candidate} and not $TName_Tid{$Candidate} 10183 and not $NameSpaces{$Candidate} and not $EnumMembers{$Candidate} 10184 and not $GlobalDataNames{$Candidate} and not $FuncNames{$Candidate}); 10185} 10186 10187sub callInterfaceParameters_m(@) 10188{ 10189 my %Init_Desc = @_; 10190 my (@ParamList, %ParametersOrdered, %Params_Init, $IsWrapperCall); 10191 my ($Interface, $Key, $ObjectCall) = ($Init_Desc{"Interface"}, $Init_Desc{"Key"}, $Init_Desc{"ObjectCall"}); 10192 add_VirtualProxy($Interface, $Init_Desc{"OutParam"}, "forward", 1); 10193 add_VirtualProxy($Interface, $Init_Desc{"OutParam"}, "forward", 2); 10194 add_VirtualProxy($Interface, $Init_Desc{"OutParam"}, "backward", 1); 10195 add_VirtualProxy($Interface, $Init_Desc{"OutParam"}, "backward", 2); 10196 my (%KeyTable, %AccessToParam, %TargetAccessToParam, %InvOrder, %Interface_Init, $SubClasses_Before) = (); 10197 $AccessToParam{"obj"} = $ObjectCall; 10198 $TargetAccessToParam{"obj"} = $ObjectCall; 10199 return () if(needToInherit($Interface) and isInCharge($Interface)); 10200 $Interface_Init{"Headers"} = addHeaders([$CompleteSignature{$Interface}{"Header"}], $Interface_Init{"Headers"}); 10201 if(not $CompleteSignature{$Interface}{"Constructor"} 10202 and not $CompleteSignature{$Interface}{"Destructor"}) { 10203 $Interface_Init{"Headers"} = addHeaders(getTypeHeaders($CompleteSignature{$Interface}{"Return"}), $Interface_Init{"Headers"}); 10204 } 10205 my $ShortName = $CompleteSignature{$Interface}{"ShortName"}; 10206 if($CompleteSignature{$Interface}{"Constructor"}) { 10207 $Interface_Init{"Call"} .= get_TypeName($CompleteSignature{$Interface}{"Class"}); 10208 } 10209 else { 10210 $Interface_Init{"Call"} .= $ShortName; 10211 } 10212 my $IsWrapperCall = (($CompleteSignature{$Interface}{"Protected"}) and (not $CompleteSignature{$Interface}{"Constructor"})); 10213 if($IsWrapperCall) 10214 { 10215 $Interface_Init{"Call"} .= "_Wrapper"; 10216 $Interface_Init{"Call"} = cleanName($Interface_Init{"Call"}); 10217 @{$SubClasses_Before}{keys %Create_SubClass} = values %Create_SubClass; 10218 %Create_SubClass = (); 10219 } 10220 my $NumOfParams = getNumOfParams($Interface); 10221 # detecting inline parameters 10222 my %InLineParam = detectInLineParams($Interface); 10223 my %Order = detectParamsOrder($Interface); 10224 @InvOrder{values %Order} = keys %Order; 10225 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 10226 { 10227 $ParametersOrdered{$Order{$Param_Pos + 1} - 1}{"type"} = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"type"}; 10228 $ParametersOrdered{$Order{$Param_Pos + 1} - 1}{"name"} = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"name"}; 10229 } 10230 # initializing parameters 10231 if(keys(%{$CompleteSignature{$Interface}{"Param"}})>0 10232 and defined $CompleteSignature{$Interface}{"Param"}{0}) 10233 { 10234 my $MaxParamPos = keys(%{$CompleteSignature{$Interface}{"Param"}}) - 1; 10235 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 10236 { 10237 next if($Param_Pos eq ""); 10238 my $TruePos = $InvOrder{$Param_Pos + 1} - 1; 10239 my $TypeId = $ParametersOrdered{$Param_Pos}{"type"}; 10240 my $TypeName = get_TypeName($TypeId); 10241 10242 my $FTypeId = get_FoundationTypeId($TypeId); 10243 10244 my $Param_Name = $ParametersOrdered{$Param_Pos}{"name"}; 10245 if($Param_Name=~/\Ap\d+\Z/ 10246 and (my $NewParamName = getParamNameByTypeName($TypeName))) { 10247 $Param_Name = $NewParamName; 10248 } 10249 my $Param_Name_Ext = ""; 10250 if(is_used_var($CurrentBlock, $Param_Name) and not $LongVarNames 10251 and ($Key=~/(_|\A)\Q$Param_Name\E(_|\Z)/)) 10252 { 10253 if($TypeName=~/string/i) { 10254 $Param_Name_Ext="str"; 10255 } 10256 elsif($TypeName=~/char/i) { 10257 $Param_Name_Ext="ch"; 10258 } 10259 } 10260 $Param_Name = "p".($TruePos+1) if(not $Param_Name); 10261 my $TypeType = get_TypeType($TypeId); 10262 my $TypeName_Uncovered = uncover_typedefs($TypeName); 10263 my $InLine = $InLineParam{$TruePos+1}; 10264 my $StrongConvert = 0; 10265 if($OverloadedInterface{$Interface}) 10266 { 10267 if(not isExactValueAble($TypeName_Uncovered) 10268 and $TypeType ne "Enum") 10269 { 10270 # $InLine = 0; 10271 $StrongConvert = 1; 10272 } 10273 } 10274 $InLine = 0 if(uncover_typedefs($TypeName)=~/\&/); 10275 $InLine = 0 if(get_TypeType($FTypeId)!~/\A(Intrinsic|Enum)\Z/ and $Param_Name!~/\Ap\d+\Z/ 10276 and not isCyclical(\@RecurTypeId, get_TypeStackId($TypeId))); 10277 my $NewKey = ($Param_Name)? (($Key)?$Key."_".$Param_Name:$Param_Name) : ($Key)?$Key."_".($TruePos+1):"p".$InvOrder{$Param_Pos+1}; 10278 my $SpecTypeId = $InterfaceSpecType{$Interface}{"SpecParam"}{$TruePos}; 10279 my $ParamValue = "no value"; 10280 if(defined $ProxyValue{$Interface} 10281 and my $PValue = $ProxyValue{$Interface}{$TruePos}) { 10282 $ParamValue = $PValue; 10283 } 10284 # initialize parameter 10285 if(($Init_Desc{"OutParam"} ne "") and $Param_Pos==$Init_Desc{"OutParam"}) 10286 { # initializing out-parameter 10287 $AccessToParam{$TruePos+1} = $Init_Desc{"OutVar"}; 10288 $TargetAccessToParam{$TruePos+1} = $Init_Desc{"OutVar"}; 10289 if($SpecTypeId and ($SpecType{$SpecTypeId}{"InitCode"}.$SpecType{$SpecTypeId}{"FinalCode"}.$SpecType{$SpecTypeId}{"PreCondition"}.$SpecType{$SpecTypeId}{"PostCondition"})=~/\$0/) 10290 { 10291 if(is_equal_types(get_TypeName($TypeId), $SpecType{$SpecTypeId}{"DataType"})) 10292 { 10293 $AccessToParam{"0"} = $Init_Desc{"OutVar"}; 10294 $TargetAccessToParam{"0"} = $Init_Desc{"OutVar"}; 10295 } 10296 else 10297 { 10298 my ($TargetCall, $Preamble)= 10299 convertTypes(( 10300 "InputTypeName"=>get_TypeName($TypeId), 10301 "InputPointerLevel"=>get_PointerLevel($TypeId), 10302 "OutputTypeId"=>get_TypeIdByName($SpecType{$SpecTypeId}{"DataType"}), 10303 "Value"=>$Init_Desc{"OutVar"}, 10304 "Key"=>$NewKey, 10305 "Destination"=>"Target", 10306 "MustConvert"=>0)); 10307 $Params_Init{"Init"} .= $Preamble; 10308 $AccessToParam{"0"} = $TargetCall; 10309 $TargetAccessToParam{"0"} = $TargetCall; 10310 } 10311 } 10312 my %Param_Init = initializeParameter(( 10313 "Interface" => $Interface, 10314 "AccessToParam" => \%TargetAccessToParam, 10315 "TypeId" => $TypeId, 10316 "Key" => $NewKey, 10317 "SpecType" => $SpecTypeId, 10318 "Usage" => "OnlySpecType", 10319 "ParamName" => $Param_Name, 10320 "ParamPos" => $TruePos)); 10321 $Params_Init{"Init"} .= $Param_Init{"Init"}; 10322 $Params_Init{"Code"} .= $Param_Init{"Code"}; 10323 $Params_Init{"FinalCode"} .= $Param_Init{"FinalCode"}; 10324 $Params_Init{"PreCondition"} .= $Param_Init{"PreCondition"}; 10325 $Params_Init{"PostCondition"} .= $Param_Init{"PostCondition"}; 10326 $Interface_Init{"Headers"} = addHeaders($Param_Init{"Headers"}, $Interface_Init{"Headers"}); 10327 } 10328 else 10329 { 10330 my $CreateChild = ($ShortName eq "operator=" and get_TypeName($FTypeId) eq get_TypeName($CompleteSignature{$Interface}{"Class"}) and $CompleteSignature{$Interface}{"Protected"}); 10331 if($IsWrapperCall 10332 and $CompleteSignature{$Interface}{"Class"}) { 10333 # push(@RecurTypeId, $CompleteSignature{$Interface}{"Class"}); 10334 } 10335 my %Param_Init = initializeParameter(( 10336 "Interface" => $Interface, 10337 "AccessToParam" => \%TargetAccessToParam, 10338 "TypeId" => $TypeId, 10339 "Key" => $NewKey, 10340 "InLine" => $InLine, 10341 "Value" => $ParamValue, 10342 "CreateChild" => $CreateChild, 10343 "SpecType" => $SpecTypeId, 10344 "Usage" => "Common", 10345 "ParamName" => $Param_Name, 10346 "ParamPos" => $TruePos, 10347 "StrongConvert" => $StrongConvert, 10348 "DoNotReuse" => $Init_Desc{"DoNotReuse"}, 10349 "ParamNameExt" => $Param_Name_Ext, 10350 "MaxParamPos" => $MaxParamPos)); 10351 if($IsWrapperCall 10352 and $CompleteSignature{$Interface}{"Class"}) { 10353 # pop(@RecurTypeId); 10354 } 10355 if(not $Param_Init{"IsCorrect"}) 10356 { 10357 foreach my $ClassId (keys(%{$SubClasses_Before})) { 10358 $Create_SubClass{$ClassId} = 1; 10359 } 10360 return (); 10361 } 10362 my $RetParam = $Init_Desc{"RetParam"}; 10363 if($Param_Init{"ByNull"} and ($Interface ne $TestedInterface) 10364 and (($ShortName=~/(\A|_)\Q$RetParam\E(\Z|_)/i and $ShortName!~/(\A|_)init(\Z|_)/i and $Param_Name!~/out|error/i) 10365 or is_transit_function($CompleteSignature{$Interface}{"ShortName"}))) { 10366 return (); 10367 } 10368 if($Param_Init{"ByNull"} 10369 and $Param_Init{"InsertCall"}) { 10370 return (); 10371 } 10372 $Params_Init{"Init"} .= $Param_Init{"Init"}; 10373 $Params_Init{"Code"} .= $Param_Init{"Code"}; 10374 $Params_Init{"Destructors"} .= $Param_Init{"Destructors"}; 10375 $Params_Init{"FinalCode"} .= $Param_Init{"FinalCode"}; 10376 $Params_Init{"PreCondition"} .= $Param_Init{"PreCondition"}; 10377 $Params_Init{"PostCondition"} .= $Param_Init{"PostCondition"}; 10378 $Interface_Init{"Headers"} = addHeaders($Param_Init{"Headers"}, $Interface_Init{"Headers"}); 10379 $AccessToParam{$TruePos+1} = $Param_Init{"Call"}; 10380 $TargetAccessToParam{$TruePos+1} = $Param_Init{"TargetCall"}; 10381 } 10382 } 10383 foreach my $Param_Pos (sort {int($a)<=>int($b)} keys(%{$CompleteSignature{$Interface}{"Param"}})) 10384 { 10385 next if($Param_Pos eq ""); 10386 my $Param_Call = $AccessToParam{$Param_Pos + 1}; 10387 my $ParamType_Id = $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"type"}; 10388 if((get_TypeName($ParamType_Id) ne "..." and not $CompleteSignature{$Interface}{"Param"}{$Param_Pos}{"default"}) 10389 or $Param_Call ne "") { 10390 push(@ParamList, $Param_Call); 10391 } 10392 } 10393 my $LastParamPos = keys(%{$CompleteSignature{$Interface}{"Param"}})-1; 10394 my $LastTypeId = $CompleteSignature{$Interface}{"Param"}{$LastParamPos}{"type"}; 10395 my $LastParamCall = $AccessToParam{$LastParamPos+1}; 10396 if(get_TypeName($LastTypeId) eq "..." and $LastParamCall ne "0" and $LastParamCall ne "NULL") 10397 { # add sentinel to function call 10398 # http://www.linuxonly.nl/docs/2/2_GCC_4_warnings_about_sentinels.html 10399 push(@ParamList, "(char*)0"); 10400 } 10401 my $Parameters_Call = "(".create_list(\@ParamList, " ").")"; 10402 if($IsWrapperCall) 10403 { 10404 $Interface_Init{"Call"} .= "()"; 10405 $Wrappers{$Interface}{"Init"} = $Params_Init{"Init"}; 10406 $Wrappers{$Interface}{"Code"} = $Params_Init{"Code"}; 10407 $Wrappers{$Interface}{"Destructors"} = $Params_Init{"Destructors"}; 10408 $Wrappers{$Interface}{"FinalCode"} = $Params_Init{"FinalCode"}; 10409 $Wrappers{$Interface}{"PreCondition"} = $Params_Init{"PreCondition"}; 10410 $Wrappers{$Interface}{"PostCondition"} = $Params_Init{"PostCondition"}; 10411 $Wrappers{$Interface}{"Parameters_Call"} = $Parameters_Call; 10412 foreach my $ClassId (keys(%Create_SubClass)) { 10413 $Wrappers_SubClasses{$Interface}{$ClassId} = 1; 10414 } 10415 } 10416 else 10417 { 10418 $Interface_Init{"Call"} .= $Parameters_Call; 10419 $Interface_Init{"Init"} .= $Params_Init{"Init"}; 10420 $Interface_Init{"Code"} .= $Params_Init{"Code"}; 10421 $Interface_Init{"Destructors"} .= $Params_Init{"Destructors"}; 10422 $Interface_Init{"FinalCode"} .= $Params_Init{"FinalCode"}; 10423 $Interface_Init{"PreCondition"} .= $Params_Init{"PreCondition"}; 10424 $Interface_Init{"PostCondition"} .= $Params_Init{"PostCondition"}; 10425 } 10426 } 10427 elsif($CompleteSignature{$Interface}{"Data"}) 10428 { 10429 if($IsWrapperCall) { 10430 $Interface_Init{"Call"} .= "()"; 10431 } 10432 } 10433 else 10434 { 10435 $Interface_Init{"Call"} .= "()"; 10436 $Wrappers{$Interface}{"Parameters_Call"} = "()"; 10437 } 10438 if($IsWrapperCall) 10439 { 10440 foreach my $ClassId (keys(%{$SubClasses_Before})) { 10441 $Create_SubClass{$ClassId} = 1; 10442 } 10443 } 10444 # check requirement for return value 10445 my $SpecReturnType = $InterfaceSpecType{$Interface}{"SpecReturn"}; 10446 if(not $SpecReturnType) { 10447 $SpecReturnType = chooseSpecType($CompleteSignature{$Interface}{"Return"}, "common_retval", $Interface); 10448 } 10449 $Interface_Init{"ReturnRequirement"} = requirementReturn($Interface, $CompleteSignature{$Interface}{"Return"}, $SpecReturnType, $ObjectCall); 10450 if($SpecReturnType) 10451 { 10452 if(my $ReturnInitCode = $SpecType{$SpecReturnType}{"InitCode"}) 10453 { 10454 my %ParsedCode = parseCode($ReturnInitCode, "Code"); 10455 if($ParsedCode{"IsCorrect"}) 10456 { 10457 $Interface_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Interface_Init{"Headers"}); 10458 $Interface_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}; 10459 $Interface_Init{"Init"} .= $ParsedCode{"Code"}; 10460 } 10461 } 10462 if(my $ReturnFinalCode = $SpecType{$SpecReturnType}{"FinalCode"}) 10463 { 10464 my %ParsedCode = (); 10465 if($Init_Desc{"RetParam"}) 10466 { 10467 my $LastId = pop(@RecurTypeId); 10468 # add temp $retval 10469 $ValueCollection{$CurrentBlock}{"\$retval"} = $CompleteSignature{$Interface}{"Return"}; 10470 # parse code using temp $retval 10471 %ParsedCode = parseCode($ReturnFinalCode, "Code"); 10472 # remove temp $retval 10473 delete($ValueCollection{$CurrentBlock}{"\$retval"}); 10474 push(@RecurTypeId, $LastId); 10475 } 10476 else { 10477 %ParsedCode = parseCode($ReturnFinalCode, "Code"); 10478 } 10479 if($ParsedCode{"IsCorrect"}) 10480 { 10481 $Interface_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Interface_Init{"Headers"}); 10482 $Interface_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}; 10483 $Interface_Init{"ReturnFinalCode"} = $ParsedCode{"Code"}; 10484 } 10485 else { 10486 $Interface_Init{"ReturnFinalCode"} = ""; 10487 } 10488 } 10489 } 10490 foreach my $ParamId (keys %AccessToParam) 10491 { 10492 if($TargetAccessToParam{$ParamId} and ($TargetAccessToParam{$ParamId} ne "no object")) 10493 { 10494 my $AccessValue = $TargetAccessToParam{$ParamId}; 10495 foreach my $Attr (keys(%Interface_Init)) { 10496 $Interface_Init{$Attr}=~s/\$\Q$ParamId\E([^0-9]|\Z)/$AccessValue$1/g; 10497 } 10498 } 10499 } 10500 $Interface_Init{"IsCorrect"} = 1; 10501 return %Interface_Init; 10502} 10503 10504sub parse_param_name($$) 10505{ 10506 my ($String, $Place) = @_; 10507 if($String=~/(([a-z_]\w+)[ ]*\(.+\))/i) 10508 { 10509 my ($Call, $Interface_ShortName) = ($1, $2); 10510 my $Pos = 0; 10511 foreach my $Part (get_Signature_Parts($Call, 0)) 10512 { 10513 $Part=~s/(\A\s+|\s+\Z)//g; 10514 if($Part eq $Place) 10515 { 10516 if($CompleteSignature{$Interface_ShortName}) { 10517 return ($CompleteSignature{$Interface_ShortName}{"Param"}{$Pos}{"name"}, $Pos, $Interface_ShortName); 10518 } 10519 else { 10520 return (0, 0, ""); 10521 } 10522 } 10523 $Pos+=1; 10524 } 10525 } 10526 return (0, 0, ""); 10527} 10528 10529sub parseCode_m($$) 10530{ 10531 my ($Code, $Mode) = @_; 10532 return ("IsCorrect"=>1) if(not $Code or not $Mode); 10533 my ($Bracket_Num, $Code_Inlined, $NotEnded) = (0, "", 0); 10534 foreach my $Line (split(/\n/, $Code)) 10535 { 10536 foreach my $Pos (0 .. length($Line) - 1) 10537 { 10538 my $Symbol = substr($Line, $Pos, 1); 10539 $Bracket_Num += 1 if($Symbol eq "("); 10540 $Bracket_Num -= 1 if($Symbol eq ")"); 10541 } 10542 if($NotEnded and $Bracket_Num!=0) { 10543 $Line=~s/\A\s+/ /g; 10544 } 10545 $Code_Inlined .= $Line; 10546 if($Bracket_Num==0) { 10547 $Code_Inlined .= "\n"; 10548 } 10549 else { 10550 $NotEnded = 1; 10551 } 10552 } 10553 $Code = $Code_Inlined; 10554 my ($AllSubCode, $ParsedCode, $Headers) = (); 10555 $Block_InsNum{$CurrentBlock} = 1 if(not defined $Block_InsNum{$CurrentBlock}); 10556 if($Mode eq "Value") { 10557 $Code=~s/\n//g; 10558 } 10559 foreach my $String (split(/\n/, $Code)) 10560 { 10561 if($String=~/\#[ \t]*include[ \t]*\<[ \t]*([^ \t]+)[ \t]*\>/) 10562 { 10563 $Headers = addHeaders($Headers, [$1]); 10564 next; 10565 } 10566 my ($CodeBefore, $CodeAfter) = (); 10567 while($String=~/(\$\(([^\$\(\)]+)\))/) 10568 { # parsing $(Type) constructions 10569 my $Replace = $1; 10570 my $TypeName = $2; 10571 my $TypeId = get_TypeIdByName($TypeName); 10572 my $FTypeId = get_FoundationTypeId($TypeId); 10573 my $NewKey = "_var".$Block_InsNum{$CurrentBlock}; 10574 my ($FuncParamName, $FuncParamPos, $InterfaceShortName) = parse_param_name($String, $Replace); 10575 if($FuncParamName) { 10576 $NewKey = $FuncParamName; 10577 } 10578 my $InLine = 1; 10579 $InLine = 0 if(uncover_typedefs($TypeName)=~/\&/); 10580 $InLine = 0 if(get_TypeType($FTypeId)!~/\A(Intrinsic|Enum)\Z/ and $FuncParamName and $FuncParamName!~/\Ap\d+\Z/ 10581 and not isCyclical(\@RecurTypeId, get_TypeStackId($TypeId))); 10582 my %Param_Init = initializeParameter(( 10583 "AccessToParam" => {"obj"=>"no object"}, 10584 "TypeId" => $TypeId, 10585 "Key" => $NewKey, 10586 "InLine" => $InLine, 10587 "Value" => "no value", 10588 "CreateChild" => 0, 10589 "SpecType" => ($FuncParamName and $InterfaceShortName)?$InterfaceSpecType{$InterfaceShortName}{"SpecParam"}{$FuncParamPos}:0, 10590 "Usage" => "Common", 10591 "ParamName" => $NewKey, 10592 "Interface" => $InterfaceShortName)); 10593 return () if(not $Param_Init{"IsCorrect"} or $Param_Init{"ByNull"}); 10594 $Block_InsNum{$CurrentBlock} += 1 if(($Param_Init{"Init"}.$Param_Init{"FinalCode"}.$Param_Init{"Code"})=~/\Q$NewKey\E/); 10595 $Param_Init{"Init"} = alignCode($Param_Init{"Init"}, $String, 0); 10596 $Param_Init{"PreCondition"} = alignCode($Param_Init{"PreCondition"}, $String, 0); 10597 $Param_Init{"PostCondition"} = alignCode($Param_Init{"PostCondition"}, $String, 0); 10598 $Param_Init{"Call"} = alignCode($Param_Init{"Call"}, $String, 1); 10599 substr($String, index($String, $Replace), pos($Replace) + length($Replace)) = $Param_Init{"Call"}; 10600 $String = clearSyntax($String); 10601 $AllSubCode .= $Param_Init{"Code"}; 10602 $Headers = addHeaders($Param_Init{"Headers"}, $Headers); 10603 $CodeBefore .= $Param_Init{"Init"}.$Param_Init{"PreCondition"}; 10604 $CodeAfter .= $Param_Init{"PostCondition"}.$Param_Init{"FinalCode"}; 10605 } 10606 while($String=~/(\$\[([^\$\[\]]+)\])/) 10607 { # parsing $[Interface] constructions 10608 my $Replace = $1; 10609 my $InterfaceName = $2; 10610 my $RetvalName = ""; 10611 if($InterfaceName=~/\A(.+):(\w+?)\Z/) 10612 { # $[al_create_display:allegro_display] 10613 ($InterfaceName, $RetvalName) = ($1, $2); 10614 } 10615 my $NewKey = "_var".$Block_InsNum{$CurrentBlock}; 10616 my %Interface_Init = (); 10617 return () if(not $InterfaceName or not $CompleteSignature{$InterfaceName}); 10618 if($InterfaceName eq $TestedInterface) 10619 { # recursive call of the target interface 10620 substr($String, index($String, $Replace), pos($Replace) + length($Replace)) = ""; 10621 $String = "" if($String eq ";"); 10622 next; 10623 } 10624 if($CompleteSignature{$InterfaceName}{"Constructor"}) 10625 { 10626 push(@RecurTypeId, $CompleteSignature{$InterfaceName}{"Class"}); 10627 %Interface_Init = callInterface(( 10628 "Interface"=>$InterfaceName, 10629 "Key"=>$NewKey)); 10630 pop(@RecurTypeId); 10631 } 10632 else 10633 { 10634 if($RetvalName) { 10635 push(@RecurTypeId, get_TypeStackId($CompleteSignature{$InterfaceName}{"Return"})); 10636 } 10637 %Interface_Init = callInterface(( 10638 "Interface"=>$InterfaceName, 10639 "Key"=>$NewKey, 10640 "RetParam"=>$RetvalName)); 10641 if($RetvalName) 10642 { 10643 pop(@RecurTypeId); 10644 $Interface_Init{"ReturnFinalCode"}=~s/\$retval/$RetvalName/; 10645 } 10646 } 10647 return () if(not $Interface_Init{"IsCorrect"}); 10648 $Block_InsNum{$CurrentBlock} += 1 if(($Interface_Init{"Init"}.$Interface_Init{"FinalCode"}.$Interface_Init{"ReturnFinalCode"}.$Interface_Init{"Code"})=~/\Q$NewKey\E/); 10649 if(($CompleteSignature{$InterfaceName}{"Constructor"}) and (needToInherit($InterfaceName))) 10650 { # for constructors in abstract classes 10651 my $ClassName = get_TypeName($CompleteSignature{$InterfaceName}{"Class"}); 10652 my $ClassNameChild = getSubClassName($ClassName); 10653 if($Interface_Init{"Call"}=~/\A(\Q$ClassName\E([\n]*)\()/) { 10654 substr($Interface_Init{"Call"}, index($Interface_Init{"Call"}, $1), pos($1) + length($1)) = $ClassNameChild.$2."("; 10655 } 10656 $UsedConstructors{$CompleteSignature{$InterfaceName}{"Class"}}{$InterfaceName} = 1; 10657 $IntSubClass{$TestedInterface}{$CompleteSignature{$InterfaceName}{"Class"}} = 1; 10658 $Create_SubClass{$CompleteSignature{$InterfaceName}{"Class"}} = 1; 10659 } 10660 $Interface_Init{"Init"} = alignCode($Interface_Init{"Init"}, $String, 0); 10661 $Interface_Init{"PreCondition"} = alignCode($Interface_Init{"PreCondition"}, $String, 0); 10662 $Interface_Init{"PostCondition"} = alignCode($Interface_Init{"PostCondition"}, $String, 0); 10663 $Interface_Init{"FinalCode"} = alignCode($Interface_Init{"FinalCode"}, $String, 0); 10664 $Interface_Init{"ReturnFinalCode"} = alignCode($Interface_Init{"ReturnFinalCode"}, $String, 0); 10665 $Interface_Init{"Call"} = alignCode($Interface_Init{"Call"}, $String, 1); 10666 if($RetvalName) 10667 { 10668 $Block_Variable{$CurrentBlock}{$RetvalName} = 1; 10669 $ValueCollection{$CurrentBlock}{$RetvalName} = $CompleteSignature{$InterfaceName}{"Return"}; 10670 $UseVarEveryWhere{$CurrentBlock}{$RetvalName} = 1; 10671 $Interface_Init{"Call"} = get_TypeName($CompleteSignature{$InterfaceName}{"Return"})." $RetvalName = ".$Interface_Init{"Call"}; 10672 } 10673 substr($String, index($String, $Replace), pos($Replace) + length($Replace)) = $Interface_Init{"Call"}; 10674 $AllSubCode .= $Interface_Init{"Code"}; 10675 $Headers = addHeaders($Interface_Init{"Headers"}, $Headers); 10676 $CodeBefore .= $Interface_Init{"Init"}.$Interface_Init{"PreCondition"}; 10677 $CodeAfter .= $Interface_Init{"PostCondition"}.$Interface_Init{"FinalCode"}.$Interface_Init{"ReturnFinalCode"}; 10678 } 10679 $ParsedCode .= $CodeBefore.$String."\n".$CodeAfter; 10680 if($Mode eq "Value") 10681 { 10682 return ("NewGlobalCode" => $AllSubCode, 10683 "Code" => $String, 10684 "CodeBefore" => $CodeBefore, 10685 "CodeAfter" => $CodeAfter, 10686 "Headers" => $Headers, 10687 "IsCorrect" => 1); 10688 } 10689 } 10690 return ("NewGlobalCode" => $AllSubCode, "Code" => clearSyntax($ParsedCode), "Headers" => $Headers, "IsCorrect" => 1); 10691} 10692 10693sub callInterface_m(@) 10694{ 10695 my %Init_Desc = @_; 10696 my ($Interface, $Key) = ($Init_Desc{"Interface"}, $Init_Desc{"Key"}); 10697 my $SpecObjectType = $InterfaceSpecType{$Interface}{"SpecObject"}; 10698 my $SpecReturnType = $InterfaceSpecType{$Interface}{"SpecReturn"}; 10699 my %Interface_Init = (); 10700 my $ClassName = get_TypeName($CompleteSignature{$Interface}{"Class"}); 10701 my ($CreateChild, $CallAsGlobalData, $MethodToInitObj) = (0, 0, "Common"); 10702 10703 if(needToInherit($Interface) and isInCharge($Interface)) 10704 { # impossible testing 10705 return (); 10706 } 10707 if($CompleteSignature{$Interface}{"Protected"}) 10708 { 10709 if(not $CompleteSignature{$Interface}{"Constructor"}) { 10710 $UsedProtectedMethods{$CompleteSignature{$Interface}{"Class"}}{$Interface} = 1; 10711 } 10712 $IntSubClass{$TestedInterface}{$CompleteSignature{$Interface}{"Class"}} = 1; 10713 $Create_SubClass{$CompleteSignature{$Interface}{"Class"}} = 1; 10714 $CreateChild = 1; 10715 } 10716 if(($CompleteSignature{$Interface}{"Static"}) and (not $CompleteSignature{$Interface}{"Protected"})) 10717 { 10718 $MethodToInitObj = "OnlySpecType"; 10719 $CallAsGlobalData = 1; 10720 } 10721 if($SpecReturnType and not isCyclical(\@RecurSpecType, $SpecReturnType)) 10722 { 10723 my $SpecReturnCode = $SpecType{$SpecReturnType}{"Code"}; 10724 if($SpecReturnCode) { 10725 push(@RecurSpecType, $SpecReturnType); 10726 } 10727 my $PreviousBlock = $CurrentBlock; 10728 $CurrentBlock = $CurrentBlock."_code_".$SpecReturnType; 10729 my %ParsedCode = parseCode($SpecType{$SpecReturnType}{"Code"}, "Code"); 10730 $CurrentBlock = $PreviousBlock; 10731 if(not $ParsedCode{"IsCorrect"}) 10732 { 10733 if($SpecReturnCode) { 10734 pop(@RecurSpecType); 10735 } 10736 return (); 10737 } 10738 $SpecCode{$SpecReturnType} = 1 if($ParsedCode{"Code"}); 10739 $Interface_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}.$ParsedCode{"Code"}; 10740 $Interface_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Interface_Init{"Headers"}); 10741 if($SpecReturnCode) { 10742 pop(@RecurSpecType); 10743 } 10744 } 10745 if($CompleteSignature{$Interface}{"Class"} 10746 and not $CompleteSignature{$Interface}{"Constructor"}) 10747 { 10748 # initialize object 10749 my $ParamName = select_obj_name($Key, $CompleteSignature{$Interface}{"Class"}); 10750 my $NewKey = ($Key)?$Key."_".$ParamName:$ParamName; 10751 if(not $SpecObjectType) { 10752 $SpecObjectType = chooseSpecType($CompleteSignature{$Interface}{"Class"}, "common_param", $Init_Desc{"Interface"}); 10753 } 10754 my %Obj_Init = (not $Init_Desc{"ObjectCall"})?initializeParameter(( 10755 "ParamName" => $ParamName, 10756 "Interface" => $Interface, 10757 "AccessToParam" => {"obj"=>"create object"}, 10758 "TypeId" => $CompleteSignature{$Interface}{"Class"}, 10759 "Key" => $NewKey, 10760 "InLine" => 0, 10761 "Value" => "no value", 10762 "CreateChild" => $CreateChild, 10763 "SpecType" => $SpecObjectType, 10764 "Usage" => $MethodToInitObj, 10765 "ConvertToBase" => (not $CompleteSignature{$Interface}{"Protected"}), 10766 "ObjectInit" =>1 )):("IsCorrect"=>1, "Call"=>$Init_Desc{"ObjectCall"}); 10767 if(not $Obj_Init{"IsCorrect"}) 10768 { 10769 if($Debug) { 10770 $DebugInfo{"Init_Class"}{get_TypeName($CompleteSignature{$Interface}{"Class"})} = 1; 10771 } 10772 return (); 10773 } 10774 $Obj_Init{"Call"} = "no object" if($CallAsGlobalData); 10775 # initialize parameters 10776 pop(@RecurInterface); 10777 $Init_Desc{"ObjectCall"} = $Obj_Init{"Call"} if(not $Init_Desc{"ObjectCall"}); 10778 my %Params_Init = callInterfaceParameters(%Init_Desc); 10779 push(@RecurInterface, $Interface); 10780 return () if(not $Params_Init{"IsCorrect"}); 10781 $Interface_Init{"ReturnRequirement"} .= $Params_Init{"ReturnRequirement"}; 10782 $Interface_Init{"ReturnFinalCode"} .= $Params_Init{"ReturnFinalCode"}; 10783 $Interface_Init{"Init"} .= $Obj_Init{"Init"}.$Params_Init{"Init"}; 10784 $Interface_Init{"Destructors"} .= $Params_Init{"Destructors"}.$Obj_Init{"Destructors"}; 10785 $Interface_Init{"Headers"} = addHeaders($Params_Init{"Headers"}, $Interface_Init{"Headers"}); 10786 $Interface_Init{"Headers"} = addHeaders($Obj_Init{"Headers"}, $Interface_Init{"Headers"}); 10787 $Interface_Init{"Code"} .= $Obj_Init{"Code"}.$Params_Init{"Code"}; 10788 $Interface_Init{"PreCondition"} .= $Obj_Init{"PreCondition"}.$Params_Init{"PreCondition"}; 10789 $Interface_Init{"PostCondition"} .= $Obj_Init{"PostCondition"}.$Params_Init{"PostCondition"}; 10790 $Interface_Init{"FinalCode"} .= $Obj_Init{"FinalCode"}.$Params_Init{"FinalCode"}; 10791 # target call 10792 if($CallAsGlobalData) { 10793 $Interface_Init{"Call"} = $ClassName."::".$Params_Init{"Call"}; 10794 } 10795 else 10796 { 10797 if(($Obj_Init{"Call"}=~/\A\*/) or ($Obj_Init{"Call"}=~/\A\&/)) { 10798 $Obj_Init{"Call"} = "(".$Obj_Init{"Call"}.")"; 10799 } 10800 $Interface_Init{"Call"} = $Obj_Init{"Call"}.".".$Params_Init{"Call"}; 10801 $Interface_Init{"Call"}=~s/\(\*(\w+)\)\./$1\-\>/; 10802 $Interface_Init{"Call"}=~s/\(\&(\w+)\)\-\>/$1\./; 10803 } 10804 #simplify operators 10805 $Interface_Init{"Call"} = simplifyOperator($Interface_Init{"Call"}); 10806 $Interface_Init{"IsCorrect"} = 1; 10807 return %Interface_Init; 10808 } 10809 else 10810 { 10811 pop(@RecurInterface); 10812 $Init_Desc{"ObjectCall"} = "no object"; 10813 my %Params_Init = callInterfaceParameters(%Init_Desc); 10814 push(@RecurInterface, $Interface); 10815 return () if(not $Params_Init{"IsCorrect"}); 10816 $Interface_Init{"ReturnRequirement"} .= $Params_Init{"ReturnRequirement"}; 10817 $Interface_Init{"ReturnFinalCode"} .= $Params_Init{"ReturnFinalCode"}; 10818 $Interface_Init{"Init"} .= $Params_Init{"Init"}; 10819 $Interface_Init{"Destructors"} .= $Params_Init{"Destructors"}; 10820 $Interface_Init{"Headers"} = addHeaders($Params_Init{"Headers"}, $Interface_Init{"Headers"}); 10821 $Interface_Init{"Code"} .= $Params_Init{"Code"}; 10822 $Interface_Init{"PreCondition"} .= $Params_Init{"PreCondition"}; 10823 $Interface_Init{"PostCondition"} .= $Params_Init{"PostCondition"}; 10824 $Interface_Init{"FinalCode"} .= $Params_Init{"FinalCode"}; 10825 $Interface_Init{"Call"} = $Params_Init{"Call"}; 10826 if($CompleteSignature{$Interface}{"NameSpace"} 10827 and not $CompleteSignature{$Interface}{"Class"}) { 10828 $Interface_Init{"Call"} = $CompleteSignature{$Interface}{"NameSpace"}."::".$Interface_Init{"Call"}; 10829 } 10830 $Interface_Init{"IsCorrect"} = 1; 10831 return %Interface_Init; 10832 } 10833} 10834 10835sub simplifyOperator($) 10836{ 10837 my $String = $_[0]; 10838 if($String!~/\.operator/) { 10839 return $String; 10840 } 10841 return $String if($String!~/(.*)\.operator[ ]*([^()]+)\((.*)\)/); 10842 my $Target = $1; 10843 my $Operator = $2; 10844 my $Params = $3; 10845 if($Params eq "") 10846 { 10847 #prefix operator 10848 if($Operator=~/[a-z]/i) { 10849 return $String; 10850 } 10851 else { 10852 return $Operator.$Target; 10853 } 10854 } 10855 else 10856 { 10857 #postfix operator 10858 if($Params!~/\,/) 10859 { 10860 $Params = "" if(($Operator eq "++") or ($Operator eq "--")); 10861 if($Operator eq "[]") { 10862 return $Target."[$Params]"; 10863 } 10864 else { 10865 return $Target.$Operator."$Params"; 10866 } 10867 } 10868 else { 10869 return $Target.$Operator."($Params)"; 10870 } 10871 } 10872} 10873 10874sub callInterface(@) 10875{ 10876 my %Init_Desc = @_; 10877 my $Interface = $Init_Desc{"Interface"}; 10878 return () if(not $Interface); 10879 return () if($SkipInterfaces{$Interface}); 10880 foreach my $SkipPattern (keys(%SkipInterfaces_Pattern)) { 10881 return () if($Interface=~/$SkipPattern/); 10882 } 10883 if(defined $MakeIsolated and $Symbol_Library{$Interface} 10884 and keys(%InterfacesList) and not $InterfacesList{$Interface}) { 10885 return (); 10886 } 10887 my $Global_State = save_state(); 10888 return () if(isCyclical(\@RecurInterface, $Interface)); 10889 push(@RecurInterface, $Interface); 10890 $UsedInterfaces{$Interface} = 1; 10891 my %Interface_Init = callInterface_m(%Init_Desc); 10892 if(not $Interface_Init{"IsCorrect"}) 10893 { 10894 pop(@RecurInterface); 10895 restore_state($Global_State); 10896 return (); 10897 } 10898 pop(@RecurInterface); 10899 $Interface_Init{"ReturnTypeId"} = $CompleteSignature{$Interface}{"Return"}; 10900 return %Interface_Init; 10901} 10902 10903sub get_REQ_define($) 10904{ 10905 my $Interface = $_[0]; 10906 my $Code = "#define REQ(id, failure_comment, constraint) { \\\n"; 10907 $Code .= " if(!(constraint)) { \\\n"; 10908 $Code .= " printf(\"\%s: \%s\\n\", id, failure_comment); \\\n } \\\n"; 10909 $Code .= "}\n"; 10910 $FuncNames{"REQ"} = 1; 10911 $Block_Variable{"REQ"}{"id"} = 1; 10912 $Block_Variable{"REQ"}{"failure_comment"} = 1; 10913 $Block_Variable{"REQ"}{"constraint"} = 1; 10914 return $Code; 10915} 10916 10917sub get_REQva_define($) 10918{ 10919 my $Interface = $_[0]; 10920 my $Code = "#define REQva(id, constraint, failure_comment_fmt, ...) { \\\n"; 10921 $Code .= " if(!(constraint)) { \\\n"; 10922 $Code .= " printf(\"\%s: \"failure_comment_fmt\"\\n\", id, __VA_ARGS__); \\\n } \\\n"; 10923 $Code .= "}\n"; 10924 $FuncNames{"REQva"} = 1; 10925 $Block_Variable{"REQva"}{"id"} = 1; 10926 $Block_Variable{"REQva"}{"failure_comment"} = 1; 10927 $Block_Variable{"REQva"}{"constraint"} = 1; 10928 return $Code; 10929} 10930 10931sub add_lines($$) 10932{ 10933 my ($Code, $AdditionalLines) = @_; 10934 my @Lines = split(/\n/, $Code); 10935 my $NewCode_LineNumbers = "\@LT\@table\@SP\@class='l_num'\@SP\@border='0'\@SP\@cellpadding='0'\@SP\@cellspacing='0'\@GT\@\@NL\@"; 10936 my $NewCode_Lines = "\@LT\@table\@SP\@class='code_lines'\@SP\@border='0'\@SP\@cellpadding='0'\@SP\@cellspacing='0'\@GT\@\@NL\@"; 10937 my $NewCode = "\@LT\@table\@SP\@border='0'\@SP\@cellpadding='0'\@SP\@cellspacing='0'\@GT\@\@NL\@"; 10938 my $MaxLineNum = 0; 10939 foreach my $LineNum (0 .. $#Lines) 10940 { 10941 my $Line = $Lines[$LineNum]; 10942 $Line = " " if(not $Line); 10943 my $Color = ""; 10944 #if(index($Line, "'targ'")!=-1) { 10945 # $Color = "\@SP\@class='targ'"; 10946 #} 10947 $NewCode_LineNumbers .= "\@LT\@tr\@GT\@\@LT\@td\@GT\@".($LineNum+1)."\@LT\@/td\@GT\@\@LT\@/tr\@GT\@\@NL\@"; 10948 $NewCode_Lines .= "\@LT\@tr\@GT\@\@LT\@td$Color\@GT\@$Line\@LT\@/td\@GT\@\@LT\@/tr\@GT\@\@NL\@"; 10949 $MaxLineNum = $LineNum; 10950 } 10951 foreach my $LineNum (1 .. $AdditionalLines) { 10952 $NewCode_LineNumbers .= "\@LT\@tr\@GT\@\@LT\@td\@GT\@".($MaxLineNum+$LineNum+1)."\@LT\@/td\@GT\@\@LT\@/tr\@GT\@\@NL\@"; 10953 } 10954 $NewCode_LineNumbers .= "\@LT\@/table\@GT\@\@NL\@"; 10955 $NewCode_Lines .= "\@LT\@/table\@GT\@\@NL\@"; 10956 $NewCode .= "\@LT\@tr\@GT\@\@LT\@td\@SP\@valign='top'\@GT\@$NewCode_LineNumbers\@LT\@/td\@GT\@\@LT\@td\@SP\@valign='top'\@GT\@$NewCode_Lines\@LT\@/td\@GT\@\@LT\@/tr\@GT\@\@LT\@/table\@GT\@\@NL\@"; 10957 return $NewCode; 10958} 10959 10960sub parse_variables($) 10961{ 10962 my $Code = $_[0]; 10963 return () if(not $Code); 10964 my $Code_Copy = $Code; 10965 my (%Variables, %LocalFuncNames, %LocalMethodNames) = (); 10966 while($Code=~s/([a-z_]\w*)[ ]*\([^;{}]*\)[ \n]*\{//io) { 10967 $LocalFuncNames{$1} = 1; 10968 } 10969 $Code = $Code_Copy; 10970 while($Code=~s/\:\:([a-z_]\w*)[ ]*\([^;{}]*\)[ \n]*\{//io) { 10971 $LocalMethodNames{$1} = 1; 10972 } 10973 foreach my $Block (sort keys(%Block_Variable)) 10974 { 10975 foreach my $Variable (sort {length($b)<=>length($a)} keys(%{$Block_Variable{$Block}})) 10976 { 10977 next if(not $Variable); 10978 if($Code_Copy=~/\W$Variable[ ]*(,|(\n[ ]*|)\))/) { 10979 $Variables{$Variable}=1; 10980 } 10981 else 10982 { 10983 next if(is_not_variable($Variable, $Code_Copy)); 10984 next if($LocalFuncNames{$Variable} and ($Code_Copy=~/\W\Q$Variable\E[ ]*\(/ or $Code_Copy=~/\&\Q$Variable\E\W/)); 10985 next if($LocalMethodNames{$Variable} and $Code_Copy=~/\W\Q$Variable\E[ ]*\(/); 10986 $Variables{$Variable}=1; 10987 } 10988 } 10989 } 10990 while($Code=~s/[ ]+([a-z_]\w*)([ ]*=|;)//io) 10991 { 10992 my $Variable = $1; 10993 next if(is_not_variable($Variable, $Code_Copy)); 10994 next if($LocalFuncNames{$Variable} and ($Code_Copy=~/\W\Q$Variable\E[ ]*\(/ or $Code_Copy=~/\&\Q$Variable\E\W/)); 10995 next if($LocalMethodNames{$Variable} and $Code_Copy=~/\W\Q$Variable\E[ ]*\(/); 10996 $Variables{$Variable}=1; 10997 } 10998 while($Code=~s/(\(|,)[ ]*([a-z_]\w*)[ ]*(\)|,)//io) 10999 { 11000 my $Variable = $2; 11001 next if(is_not_variable($Variable, $Code_Copy)); 11002 next if($LocalFuncNames{$Variable} and ($Code_Copy=~/\W\Q$Variable\E[ ]*\(/ or $Code_Copy=~/\&\Q$Variable\E\W/)); 11003 next if($LocalMethodNames{$Variable} and $Code_Copy=~/\W\Q$Variable\E[ ]*\(/); 11004 $Variables{$Variable}=1; 11005 } 11006 my @Variables = keys(%Variables); 11007 return @Variables; 11008} 11009 11010sub is_not_variable($$) 11011{ 11012 my ($Variable, $Code) = @_; 11013 return 1 if($Variable=~/\A[A-Z_]+\Z/); 11014 # FIXME: more appropriate constants check 11015 return 1 if($TName_Tid{$Variable}); 11016 return 1 if($EnumMembers{$Variable}); 11017 return 1 if($NameSpaces{$Variable} 11018 and ($Code=~/\W\Q$Variable\E\:\:/ or $Code=~/\s+namespace\s+\Q$Variable\E\s*;/)); 11019 return 1 if($IsKeyword{$Variable} or $Variable=~/\A(\d+)\Z|_SubClass/); 11020 return 1 if($Constants{$Variable}); 11021 return 1 if($GlobalDataNames{$Variable}); 11022 return 1 if($FuncNames{$Variable} and ($Code=~/\W\Q$Variable\E[ ]*\(/ or $Code=~/\&\Q$Variable\E\W/)); 11023 return 1 if($MethodNames{$Variable} and $Code=~/\W\Q$Variable\E[ ]*\(/); 11024 return 1 if($Code=~/(\-\>|\.|\:\:)\Q$Variable\E[ ]*\(/); 11025 return 0; 11026} 11027 11028sub highlight_code($$) 11029{ 11030 my ($Code, $Interface) = @_; 11031 my $Signature = get_Signature($Interface); 11032 my %Preprocessor = (); 11033 my $PreprocessorNum = 1; 11034 my @Lines = split(/\n/, $Code); 11035 foreach my $LineNum (0 .. $#Lines) 11036 { 11037 my $Line = $Lines[$LineNum]; 11038 if($Line=~/\A[ \t]*(#.+)\Z/) 11039 { 11040 my $LineNum_Define = $LineNum; 11041 my $Define = $1; 11042 while($Define=~/\\[ \t]*\Z/) 11043 { 11044 $LineNum_Define+=1; 11045 $Define .= "\n".$Lines[$LineNum_Define]; 11046 } 11047 if($Code=~s/\Q$Define\E/\@PREPROC_$PreprocessorNum\@/) 11048 { 11049 $Preprocessor{$PreprocessorNum} = $Define; 11050 $PreprocessorNum+=1; 11051 } 11052 } 11053 } 11054 my %Strings_DQ = (); 11055 my $StrNum_DQ = 1; 11056 while($Code=~s/((L|)"[^"]*")/\@STR_DQ_$StrNum_DQ\@/) 11057 { 11058 $Strings_DQ{$StrNum_DQ} = $1; 11059 $StrNum_DQ += 1; 11060 } 11061 my %Strings = (); 11062 my $StrNum = 1; 11063 while($Code=~s/((?<=\W)(L|)'[^']*')/\@STR_$StrNum\@/) 11064 { 11065 $Strings{$StrNum} = $1; 11066 $StrNum += 1; 11067 } 11068 my %Comments = (); 11069 my $CommentNum = 1; 11070 while($Code=~s/([^:]|\A)(\/\/[^\n]*)\n/$1\@COMMENT_$CommentNum\@\n/) 11071 { 11072 $Comments{$CommentNum} = $2; 11073 $CommentNum += 1; 11074 } 11075 if(my $ShortName = ($CompleteSignature{$Interface}{"Constructor"})?get_TypeName($CompleteSignature{$Interface}{"Class"}):$CompleteSignature{$Interface}{"ShortName"}) 11076 { # target interface 11077 if($CompleteSignature{$Interface}{"Class"}) 11078 { 11079 while($ShortName=~s/\A\w+\:\://g){ }; 11080 if($CompleteSignature{$Interface}{"Constructor"}) { 11081 $Code=~s!(\:| new |\n )(\Q$ShortName\E)([ \n]*\()!$1\@LT\@span\@SP\@class='targ'\@GT\@$2\@LT\@/span\@GT\@$3!g; 11082 } 11083 elsif($CompleteSignature{$Interface}{"Destructor"}) { 11084 $Code=~s!(\n )(delete)([ \n]*\()!$1\@LT\@span\@SP\@class='targ'\@GT\@$2\@LT\@/span\@GT\@$3!g; 11085 } 11086 else { 11087 $Code=~s!(\-\>|\.|\:\:| new )(\Q$ShortName\E)([ \n]*\()!$1\@LT\@span\@SP\@class='targ'\@GT\@$2\@LT\@/span\@GT\@$3!g; 11088 } 11089 } 11090 else { 11091 $Code=~s!( )(\Q$ShortName\E)([ \n]*\()!$1\@LT\@span\@SP\@class='targ'\@GT\@$2\@LT\@/span\@GT\@$3!g; 11092 } 11093 } 11094 my %Variables = (); 11095 foreach my $Variable (parse_variables($Code)) 11096 { 11097 if($Code=~s#(?<=[^\w\n.:>])($Variable)(?=\W)#\@LT\@span\@SP\@class='var'\@GT\@$1\@LT\@/span\@GT\@#g) { 11098 $Variables{$Variable}=1; 11099 } 11100 } 11101 $Code=~s!(?<=[^.\w])(bool|_Bool|_Complex|complex|void|const|int|long|short|float|double|volatile|restrict|char|unsigned|signed)(?=[^\w\=])!\@LT\@span\@SP\@class='type'\@GT\@$1\@LT\@/span\@GT\@!g; 11102 $Code=~s!(?<=[^.\w])(false|true|namespace|return|struct|static|enum|union|public|protected|private|delete|typedef)(?=[^\w\=])!\@LT\@span\@SP\@class='keyw'\@GT\@$1\@LT\@/span\@GT\@!g; 11103 if(not $Variables{"class"}) { 11104 $Code=~s!(?<=[^.\w])(class)(?=[^\w\=])!\@LT\@span\@SP\@class='keyw'\@GT\@$1\@LT\@/span\@GT\@!g; 11105 } 11106 if(not $Variables{"new"}) { 11107 $Code=~s!(?<=[^.\w])(new)(?=[^\w\=])!\@LT\@span\@SP\@class='keyw'\@GT\@$1\@LT\@/span\@GT\@!g; 11108 } 11109 $Code=~s!(?<=[^.\w])(for|if|else if)([ \n]*\()(?=[^\w\=])!\@LT\@span\@SP\@class='keyw'\@GT\@$1\@LT\@/span\@GT\@$2!g; 11110 $Code=~s!(?<=[^.\w])else([ \n\{]+)(?=[^\w\=])!\@LT\@span\@SP\@class='keyw'\@GT\@else\@LT\@/span\@GT\@$1!g; 11111 $Code=~s!(?<=[^\w\@\$])(\d+(f|L|LL|)|NULL)(?=[^\w\@\$])!\@LT\@span\@SP\@class='num'\@GT\@$1\@LT\@/span\@GT\@!g; 11112 $Code=~s!(?<=[^\w\@\$])(0x[a-fA-F\d]{4})(?=[^\w\@\$])!\@LT\@span\@SP\@class='num'\@GT\@$1\@LT\@/span\@GT\@!g; 11113 foreach my $Num (keys(%Comments)) 11114 { 11115 my $String = $Comments{$Num}; 11116 $Code=~s!\@COMMENT_$Num\@!\@LT\@span\@SP\@class='comm'\@GT\@$String\@LT\@/span\@GT\@!g; 11117 } 11118 my $AdditionalLines = 0; 11119 foreach my $Num (keys(%Preprocessor)) 11120 { 11121 my $Define = $Preprocessor{$Num}; 11122 while($Define=~s/\n//) { 11123 $AdditionalLines+=1; 11124 } 11125 } 11126 $Code = add_lines($Code, $AdditionalLines); 11127 # $Code=~s/\n/\@LT\@br\/\@GT\@\n/g; 11128 foreach my $Num (keys(%Preprocessor)) 11129 { 11130 my $Define = $Preprocessor{$Num}; 11131 $Code=~s!\@PREPROC_$Num\@!\@LT\@span\@SP\@class='prepr'\@GT\@$Define\@LT\@/span\@GT\@!g; 11132 } 11133 foreach my $Num (keys(%Strings_DQ)) 11134 { 11135 my $String = $Strings_DQ{$Num}; 11136 $Code=~s!\@STR_DQ_$Num\@!\@LT\@span\@SP\@class='str'\@GT\@$String\@LT\@/span\@GT\@!g; 11137 } 11138 foreach my $Num (keys(%Strings)) 11139 { 11140 my $String = $Strings{$Num}; 11141 $Code=~s!\@STR_$Num\@!\@LT\@span\@SP\@class='str'\@GT\@$String\@LT\@/span\@GT\@!g; 11142 } 11143 $Code =~ s!\[\]![\@LT\@span\@SP\@style='padding-left:2px;'\@GT\@]\@LT\@/span\@GT\@!g; 11144 $Code =~ s!\(\)!(\@LT\@span\@SP\@style='padding-left:2px;'\@GT\@)\@LT\@/span\@GT\@!g; 11145 return $Code; 11146} 11147 11148sub is_process_running($) 11149{ 11150 my ($PID, $procname) = @_; 11151 if (!-e "/proc/$PID") { 11152 return 0; 11153 } 11154 open(FILE, "/proc/$PID/stat") or return 0; 11155 my $info = <FILE>; 11156 close(FILE); 11157 if ($info=~/^\d+\s+\((.*)\)\s+(\S)\s+[^\(\)]+$/) { 11158 return ($2 ne 'Z'); 11159 } 11160 else { 11161 return 0; 11162 } 11163} 11164 11165sub kill_all_childs($) 11166{ 11167 my $root_pid = $_[0]; 11168 return if(not $root_pid); 11169 # Build the list of processes to be killed. 11170 # Sub-tree of this particular process is excluded so that it could finish its work. 11171 my %children = (); 11172 my %parent = (); 11173 # Read list of all currently running processes 11174 if(!opendir(PROC_DIR, "/proc")) 11175 { 11176 kill(9, $root_pid); 11177 return; 11178 } 11179 my @all_pids = grep(/^\d+$/, readdir(PROC_DIR)); 11180 closedir(PROC_DIR); 11181 # Build the parent-child tree and get command lines 11182 foreach my $pid (@all_pids) 11183 { 11184 if (open(PID_FILE, "/proc/$pid/stat")) 11185 { 11186 my $info = <PID_FILE>; 11187 close(PID_FILE); 11188 if ($info=~/^\d+\s+\((.*)\)\s+\S\s+(\d+)\s+[^\(\)]+$/) 11189 { 11190 my $ppid = $2; 11191 $parent{$pid} = $ppid; 11192 if (!defined($children{$ppid})) { 11193 $children{$ppid} = []; 11194 } 11195 push @{$children{$ppid}}, $pid; 11196 } 11197 } 11198 } 11199 # Get the plain list of processes to kill (breadth-first tree-walk) 11200 my @kill_list = ($root_pid); 11201 for (my $i = 0; $i < scalar(@kill_list); ++$i) 11202 { 11203 my $pid = $kill_list[$i]; 11204 if ($children{$pid}) 11205 { 11206 foreach (@{$children{$pid}}) { 11207 push @kill_list, $_; 11208 } 11209 } 11210 } 11211 # Send TERM signal to all processes 11212 foreach (@kill_list) { 11213 kill("SIGTERM", $_); 11214 } 11215 # Try 20 times, waiting 0.3 seconds each time, for all the processes to be really dead. 11216 my %death_check = map { $_ => 1 } @kill_list; 11217 for (my $i = 0; $i < 20; ++$i) 11218 { 11219 foreach (keys %death_check) 11220 { 11221 if (!is_process_running($_)) { 11222 delete $death_check{$_}; 11223 } 11224 } 11225 if (scalar(keys %death_check) == 0) { 11226 last; 11227 } 11228 else { 11229 select(undef, undef, undef, 0.3); 11230 } 11231 } 11232} 11233 11234sub filt_output($) 11235{ 11236 my $Output = $_[0]; 11237 return $Output if(not keys(%SkipWarnings) and not keys(%SkipWarnings_Pattern)); 11238 my @NewOutput = (); 11239 foreach my $Line (split(/\n/, $Output)) 11240 { 11241 my $IsMatched = 0; 11242 foreach my $Warning (keys(%SkipWarnings)) 11243 { 11244 if($Line=~/\Q$Warning\E/) { 11245 $IsMatched = 1; 11246 } 11247 } 11248 foreach my $Warning (keys(%SkipWarnings_Pattern)) 11249 { 11250 if($Line=~/$Warning/) { 11251 $IsMatched = 1; 11252 } 11253 } 11254 if(not $IsMatched) { 11255 push(@NewOutput, $Line); 11256 } 11257 } 11258 my $FinalOut = join("\n", @NewOutput); 11259 $FinalOut=~s/\A[\n]+//g; 11260 return $FinalOut; 11261} 11262 11263sub createTestRunner() 11264{ # C-utility to run tests under Windows 11265 11266 # remove old stuff 11267 rmtree("test_runner/"); 11268 11269 writeFile("test_runner/test_runner.cpp"," 11270 #include <windows.h> 11271 #include <stdio.h> 11272 int main(int argc, char *argv[]) 11273 { 11274 char* cmd = argv[1]; 11275 char* directory = argv[2]; 11276 char* res = argv[3]; 11277 STARTUPINFO si; 11278 PROCESS_INFORMATION pi; 11279 ZeroMemory( &si, sizeof(STARTUPINFO)); 11280 si.cb = sizeof(STARTUPINFO); 11281 ZeroMemory( &pi, sizeof(PROCESS_INFORMATION)); 11282 if(CreateProcess(NULL, cmd, NULL, NULL, FALSE, DEBUG_PROCESS, 11283 NULL, directory, &si, &pi) == 0) { 11284 return 1; 11285 } 11286 FILE * result = fopen(res, \"w+\"); 11287 if(result==NULL) { 11288 return 1; 11289 } 11290 DEBUG_EVENT de; 11291 DWORD ecode; 11292 int done = 0; 11293 for(;;) 11294 { 11295 if(WaitForDebugEvent(&de, INFINITE)==0) 11296 break; 11297 switch (de.dwDebugEventCode) 11298 { 11299 case EXCEPTION_DEBUG_EVENT: 11300 ecode = de.u.Exception.ExceptionRecord.ExceptionCode; 11301 if (ecode!=EXCEPTION_BREAKPOINT && 11302 ecode!=EXCEPTION_SINGLE_STEP) 11303 { 11304 fprintf(result, \"\%x;0\", ecode); 11305 printf(\"\%x\\n\", ecode); 11306 TerminateProcess(pi.hProcess, 0); 11307 done = 1; 11308 } 11309 break; 11310 case EXIT_PROCESS_DEBUG_EVENT: 11311 done = 1; 11312 } 11313 if(done==1) 11314 break; 11315 ContinueDebugEvent(de.dwProcessId, de.dwThreadId, DBG_CONTINUE); 11316 } 11317 fclose(result); 11318 return 0; 11319 } 11320 "); 11321 chdir("test_runner"); 11322 system("cl test_runner.cpp >build_log 2>&1"); 11323 chdir($ORIG_DIR); 11324 if($?) { 11325 exitStatus("Error", "can't compile test runner\n"); 11326 } 11327} 11328 11329my %WindowsExceptions=( 11330 "c0000005" => "ACCESS_VIOLATION", 11331 "c00002c5" => "DATATYPE_MISALIGNMENT", 11332 "c000008c" => "ARRAY_BOUNDS_EXCEEDED", 11333 "c000008d" => "FLOAT_DENORMAL_OPERAND", 11334 "c000008e" => "FLOAT_DIVIDE_BY_ZERO", 11335 "c000008f" => "FLOAT_INEXACT_RESULT", 11336 "c0000090" => "FLOAT_INVALID_OPERATION", 11337 "c0000091" => "FLOAT_OVERFLOW", 11338 "c0000092" => "FLOAT_STACK_CHECK", 11339 "c0000093" => "FLOAT_UNDERFLOW", 11340 "c0000094" => "INTEGER_DIVIDE_BY_ZERO", 11341 "c0000095" => "INTEGER_OVERFLOW", 11342 "c0000096" => "PRIVILEGED_INSTRUCTION", 11343 "c0000006" => "IN_PAGE_ERROR", 11344 "c000001d" => "ILLEGAL_INSTRUCTION", 11345 "c0000025" => "NONCONTINUABLE_EXCEPTION", 11346 "c00000fd" => "STACK_OVERFLOW", 11347 "c0000026" => "INVALID_DISPOSITION", 11348 "80000001" => "GUARD_PAGE_VIOLATION", 11349 "c0000008" => "INVALID_HANDLE", 11350 "c0000135" => "DLL_NOT_FOUND" 11351); 11352 11353sub run_sanity_test($) 11354{ 11355 my $Interface = $_[0]; 11356 my $TestDir = $Interface_TestDir{$Interface}; 11357 if(not $TestDir) 11358 { 11359 $ResultCounter{"Run"}{"Fail"} += 1; 11360 $RunResult{$Interface}{"IsCorrect"} = 0; 11361 $RunResult{$Interface}{"TestNotExists"} = 1; 11362 if($TargetInterfaceName) 11363 { 11364 printMsg("INFO", "fail"); 11365 exitStatus("Error", "test is not generated yet"); 11366 } 11367 return 1; 11368 } 11369 elsif(not -f $TestDir."/test" and not -f $TestDir."/test.exe") 11370 { 11371 $ResultCounter{"Run"}{"Fail"} += 1; 11372 $RunResult{$Interface}{"IsCorrect"} = 0; 11373 $RunResult{$Interface}{"TestNotExists"} = 1; 11374 if($TargetInterfaceName) 11375 { 11376 printMsg("INFO", "fail"); 11377 exitStatus("Error", "test is not built yet"); 11378 } 11379 return 1; 11380 } 11381 unlink($TestDir."/result"); 11382 my $pid = fork(); 11383 unless($pid) 11384 { 11385 if($OSgroup eq "windows") 11386 { 11387 my $ProcCmd = "test_runner/test_runner.exe \"".abs_path($TestDir)."/run_test.bat\" \"$TestDir\" \"".abs_path($TestDir)."/result\" >nul 2>&1"; 11388 $ProcCmd=~s/[\/\\]/\\/g; 11389 system($ProcCmd); 11390 } 11391 else 11392 { 11393 open(STDIN,"$TMP_DIR/null"); 11394 open(STDOUT,"$TMP_DIR/null"); 11395 open(STDERR,"$TMP_DIR/null"); 11396 setsid(); # to remove signals printing on the terminal screen 11397 chdir($TestDir); 11398 system("sh run_test.sh 2>stderr"); 11399 chdir($ORIG_DIR); 11400 writeFile("$TestDir/result", $?.";".$!); 11401 } 11402 exit(0); 11403 } 11404 my $Hang = 0; 11405 $SIG{ALRM} = sub { 11406 $Hang=1; 11407 if($OSgroup eq "windows") { 11408 kill(9, $pid); 11409 } 11410 else { 11411 kill_all_childs($pid); 11412 } 11413 }; 11414 alarm $HANGED_EXECUTION_TIME; 11415 waitpid($pid, 0); 11416 alarm 0; 11417 my $Result = readFile("$TestDir/result"); 11418 unlink($TestDir."/result"); 11419 unlink("$TestDir/output") if(not readFile("$TestDir/output")); 11420 unlink("$TestDir/stderr") if(not readFile("$TestDir/stderr")); 11421 my ($R_1, $R_2) = split(";", $Result); 11422 my $ErrorOut = readFile("$TestDir/output");#checking test output 11423 $ErrorOut = filt_output($ErrorOut); 11424 if($ErrorOut) 11425 { # reduce length of the test output 11426 if(length($ErrorOut)>1200) { 11427 $ErrorOut = substr($ErrorOut, 0, 1200)." ..."; 11428 } 11429 } 11430 if($Hang) 11431 { 11432 $ResultCounter{"Run"}{"Fail"} += 1; 11433 $RunResult{$Interface}{"IsCorrect"} = 0; 11434 $RunResult{$Interface}{"Type"} = "Hanged_Execution"; 11435 $RunResult{$Interface}{"Info"} = "hanged execution (more than $HANGED_EXECUTION_TIME seconds)"; 11436 $RunResult{$Interface}{"Info"} .= "\n".$ErrorOut if($ErrorOut); 11437 } 11438 elsif($R_1) 11439 { 11440 if($OSgroup eq "windows") 11441 { 11442 my $ExceptionName = $WindowsExceptions{$R_1}; 11443 $RunResult{$Interface}{"Info"} = "received exception $ExceptionName\n"; 11444 $RunResult{$Interface}{"Type"} = "Received_Exception"; 11445 $RunResult{$Interface}{"Value"} = $ExceptionName; 11446 } 11447 else 11448 { 11449 if ($R_1 == -1) 11450 { 11451 $RunResult{$Interface}{"Info"} = "failed to execute: $R_2\n"; 11452 $RunResult{$Interface}{"Type"} = "Other_Problems"; 11453 } 11454 elsif (my $Signal_Num = ($R_1 & 127)) 11455 { 11456 my $Signal_Name = $SigName{$Signal_Num}; 11457 $RunResult{$Interface}{"Info"} = "received signal $Signal_Name, ".(($R_1 & 128)?"with":"without")." coredump\n"; 11458 $RunResult{$Interface}{"Type"} = "Received_Signal"; 11459 $RunResult{$Interface}{"Value"} = ($R_1 & 127); 11460 } 11461 else 11462 { 11463 my $Signal_Num = ($R_1 >> 8)-128; 11464 my $Signal_Name = $SigName{$Signal_Num}; 11465 if($Signal_Name) 11466 { 11467 $RunResult{$Interface}{"Info"} = "received signal $Signal_Name\n"; 11468 $RunResult{$Interface}{"Type"} = "Received_Signal"; 11469 $RunResult{$Interface}{"Value"} = $Signal_Name; 11470 } 11471 else 11472 { 11473 $RunResult{$Interface}{"Info"} = "exited with value ".($R_1 >> 8)."\n"; 11474 $RunResult{$Interface}{"Type"} = "Exited_With_Value"; 11475 $RunResult{$Interface}{"Value"} = ($R_1 >> 8); 11476 } 11477 } 11478 } 11479 $ResultCounter{"Run"}{"Fail"} += 1; 11480 $RunResult{$Interface}{"IsCorrect"} = 0; 11481 $RunResult{$Interface}{"Info"} .= "\n".$ErrorOut if($ErrorOut); 11482 } 11483 elsif(readFile($TestDir."/output")=~/(constraint|postcondition|precondition) for the (return value|object|environment|parameter) failed/i) 11484 { 11485 $ResultCounter{"Run"}{"Fail"} += 1; 11486 $RunResult{$Interface}{"IsCorrect"} = 0; 11487 $RunResult{$Interface}{"Type"} = "Requirement_Failed"; 11488 $RunResult{$Interface}{"Info"} .= "\n".$ErrorOut if($ErrorOut); 11489 } 11490 elsif($ErrorOut) 11491 { 11492 $ResultCounter{"Run"}{"Fail"} += 1; 11493 $RunResult{$Interface}{"Unexpected_Output"} = $ErrorOut; 11494 $RunResult{$Interface}{"Type"} = "Unexpected_Output"; 11495 $RunResult{$Interface}{"Info"} = $ErrorOut; 11496 } 11497 else 11498 { 11499 $ResultCounter{"Run"}{"Success"} += 1; 11500 $RunResult{$Interface}{"IsCorrect"} = 1; 11501 } 11502 if(not $RunResult{$Interface}{"IsCorrect"}) 11503 { 11504 return 0 if(not -e $TestDir."/test.c" and not -e $TestDir."/test.cpp"); 11505 my $ReadingStarted = 0; 11506 foreach my $Line (split(/\n/, readFile($TestDir."/view.html"))) 11507 { 11508 if($ReadingStarted) { 11509 $RunResult{$Interface}{"Test"} .= $Line."\n"; 11510 } 11511 if($Line eq "<!--Test-->") { 11512 $ReadingStarted = 1; 11513 } 11514 if($Line eq "<!--Test_End-->") { 11515 last; 11516 } 11517 } 11518 my $Test_Info = readFile($TestDir."/info"); 11519 foreach my $Str (split(/\n/, $Test_Info)) 11520 { 11521 if($Str=~/\A[ ]*([^:]*?)[ ]*\:[ ]*(.*)[ ]*\Z/i) 11522 { 11523 my ($Attr, $Value) = ($1, $2); 11524 if(lc($Attr) eq "header") { 11525 $RunResult{$Interface}{"Header"} = $Value; 11526 } 11527 elsif(lc($Attr) eq "shared object") { 11528 $RunResult{$Interface}{"SharedObject"} = $Value; 11529 } 11530 elsif(lc($Attr) eq "interface") { 11531 $RunResult{$Interface}{"Signature"} = $Value; 11532 } 11533 elsif(lc($Attr) eq "short name") { 11534 $RunResult{$Interface}{"ShortName"} = $Value; 11535 } 11536 elsif(lc($Attr) eq "namespace") { 11537 $RunResult{$Interface}{"NameSpace"} = $Value; 11538 } 11539 } 11540 } 11541 $RunResult{$Interface}{"ShortName"} = $Interface if(not $RunResult{$Interface}{"ShortName"}); 11542 # filtering problems 11543 if($RunResult{$Interface}{"Type"} eq "Exited_With_Value") 11544 { 11545 if($RunResult{$Interface}{"ShortName"}=~/exit|die|assert/i) { 11546 skip_problem($Interface); 11547 } 11548 else { 11549 mark_as_warning($Interface); 11550 } 11551 } 11552 elsif($RunResult{$Interface}{"Type"} eq "Hanged_Execution") 11553 { 11554 if($RunResult{$Interface}{"ShortName"}=~/call|exec|acquire|start|run|loop|blocking|startblock|wait|time|show|suspend|pause/i 11555 or ($Interface=~/internal|private/ and $RunResult{$Interface}{"ShortName"}!~/private(.*)key/i)) { 11556 mark_as_warning($Interface); 11557 } 11558 } 11559 elsif($RunResult{$Interface}{"Type"} eq "Received_Signal") 11560 { 11561 if($RunResult{$Interface}{"ShortName"}=~/badalloc|bad_alloc|fatal|assert/i) { 11562 skip_problem($Interface); 11563 } 11564 elsif($Interface=~/internal|private/ and $RunResult{$Interface}{"ShortName"}!~/private(.*)key/i) { 11565 mark_as_warning($Interface); 11566 } 11567 elsif($RunResult{$Interface}{"Value"}!~/\A(SEGV|FPE|BUS|ILL|PIPE|SYS|XCPU|XFSZ)\Z/) { 11568 mark_as_warning($Interface); 11569 } 11570 } 11571 elsif($RunResult{$Interface}{"Type"} eq "Unexpected_Output") 11572 { 11573 if($Interface=~/print|debug|warn|message|error|fatal/i) { 11574 skip_problem($Interface); 11575 } 11576 else { 11577 mark_as_warning($Interface); 11578 } 11579 } 11580 elsif($RunResult{$Interface}{"Type"} eq "Other_Problems") { 11581 mark_as_warning($Interface); 11582 } 11583 } 11584 return 0; 11585} 11586 11587sub mark_as_warning($) 11588{ 11589 my $Interface = $_[0]; 11590 $RunResult{$Interface}{"Warnings"} = 1; 11591 $ResultCounter{"Run"}{"Warnings"} += 1; 11592 $ResultCounter{"Run"}{"Fail"} -= 1; 11593 $ResultCounter{"Run"}{"Success"} += 1; 11594 $RunResult{$Interface}{"IsCorrect"} = 1; 11595} 11596 11597sub skip_problem($) 11598{ 11599 my $Interface = $_[0]; 11600 $ResultCounter{"Run"}{"Fail"} -= 1; 11601 $ResultCounter{"Run"}{"Success"} += 1; 11602 delete($RunResult{$Interface}); 11603 $RunResult{$Interface}{"IsCorrect"} = 1; 11604} 11605 11606sub readScenario() 11607{ 11608 foreach my $TestCase (split(/\n/, readFile($TEST_SUITE_PATH."/scenario"))) 11609 { 11610 if($TestCase=~/\A(.*);(.*)\Z/) { 11611 $Interface_TestDir{$1} = $2; 11612 } 11613 } 11614} 11615 11616sub write_scenario() 11617{ 11618 my $TestCases = ""; 11619 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%Interface_TestDir)) { 11620 $TestCases .= $Interface.";".$Interface_TestDir{$Interface}."\n"; 11621 } 11622 writeFile("$TEST_SUITE_PATH/scenario", $TestCases); 11623} 11624 11625sub buildTest($) 11626{ 11627 my $Interface = $_[0]; 11628 my $TestDir = $Interface_TestDir{$Interface}; 11629 if(not $TestDir or not -f "$TestDir/Makefile") 11630 { 11631 $BuildResult{$Interface}{"TestNotExists"} = 1; 11632 if($TargetInterfaceName) 11633 { 11634 printMsg("INFO", "fail"); 11635 exitStatus("Error", "test is not generated yet"); 11636 } 11637 return 0; 11638 } 11639 my $MakeCmd = ($OSgroup eq "windows")?"nmake":"make"; 11640 chdir($TestDir); 11641 system("$MakeCmd clean -f Makefile 2>build_log >$TMP_DIR/null && $MakeCmd -f Makefile 2>build_log >$TMP_DIR/null"); 11642 chdir($ORIG_DIR); 11643 if($?) 11644 { 11645 $ResultCounter{"Build"}{"Fail"} += 1; 11646 $BuildResult{$Interface}{"IsCorrect"} = 0; 11647 } 11648 else 11649 { 11650 $ResultCounter{"Build"}{"Success"} += 1; 11651 $BuildResult{$Interface}{"IsCorrect"} = 1; 11652 } 11653 unlink("$TestDir/test.o"); 11654 unlink("$TestDir/test.obj"); 11655 if(not readFile("$TestDir/build_log")) { 11656 unlink("$TestDir/build_log"); 11657 } 11658 elsif($BuildResult{$Interface}{"IsCorrect"}) { 11659 $BuildResult{$Interface}{"Warnings"} = 1; 11660 } 11661} 11662 11663sub cleanTest($) 11664{ 11665 my $Interface = $_[0]; 11666 my $TestDir = $Interface_TestDir{$Interface}; 11667 if(not $TestDir or not -f "$TestDir/Makefile") 11668 { 11669 $BuildResult{$Interface}{"TestNotExists"} = 1; 11670 if($TargetInterfaceName) 11671 { 11672 printMsg("INFO", "fail"); 11673 exitStatus("Error", "test is not generated yet"); 11674 } 11675 return 0; 11676 } 11677 unlink("$TestDir/test.o"); 11678 unlink("$TestDir/test.obj"); 11679 unlink("$TestDir/test"); 11680 unlink("$TestDir/test.exe"); 11681 unlink("$TestDir/build_log"); 11682 unlink("$TestDir/output"); 11683 unlink("$TestDir/stderr"); 11684 rmtree("$TestDir/testdata"); 11685 if($CleanSources) 11686 { 11687 foreach my $Path (cmd_find($TestDir,"f","","")) 11688 { 11689 if(get_filename($Path) ne "view.html") { 11690 unlink($Path); 11691 } 11692 } 11693 } 11694 return 1; 11695} 11696 11697sub testForDestructor($) 11698{ 11699 my $Interface = $_[0]; 11700 my $ClassId = $CompleteSignature{$Interface}{"Class"}; 11701 my $ClassName = get_TypeName($ClassId); 11702 my %Interface_Init = (); 11703 my $Var = select_obj_name("", $ClassId); 11704 $Block_Variable{$CurrentBlock}{$Var} = 1; 11705 if($Interface=~/D2/) 11706 { 11707 # push(@RecurTypeId, $ClassId); 11708 my %Obj_Init = findConstructor($ClassId, ""); 11709 # pop(@RecurTypeId); 11710 return () if(not $Obj_Init{"IsCorrect"}); 11711 my $ClassNameChild = getSubClassName($ClassName); 11712 if($Obj_Init{"Call"}=~/\A(\Q$ClassName\E([\n]*)\()/) { 11713 substr($Obj_Init{"Call"}, index($Obj_Init{"Call"}, $1), pos($1) + length($1)) = $ClassNameChild.$2."("; 11714 } 11715 $ClassName = $ClassNameChild; 11716 $UsedConstructors{$ClassId}{$Obj_Init{"Interface"}} = 1; 11717 $IntSubClass{$TestedInterface}{$ClassId} = 1; 11718 $Create_SubClass{$ClassId} = 1; 11719 $Interface_Init{"Init"} .= $Obj_Init{"Init"}; 11720 # $Interface_Init{"Init"} .= "//parameter initialization\n"; 11721 if($Obj_Init{"PreCondition"}) { 11722 $Interface_Init{"Init"} .= $Obj_Init{"PreCondition"}; 11723 } 11724 $Interface_Init{"Init"} .= "$ClassName *$Var = new ".$Obj_Init{"Call"}.";\n"; 11725 if($Obj_Init{"PostCondition"}) { 11726 $Interface_Init{"Init"} .= $Obj_Init{"PostCondition"}; 11727 } 11728 if($Obj_Init{"ReturnRequirement"}) 11729 { 11730 $Obj_Init{"ReturnRequirement"}=~s/(\$0|\$obj)/*$Var/gi; 11731 $Interface_Init{"Init"} .= $Obj_Init{"ReturnRequirement"}; 11732 } 11733 if($Obj_Init{"FinalCode"}) 11734 { 11735 $Interface_Init{"Init"} .= "//final code\n"; 11736 $Interface_Init{"Init"} .= $Obj_Init{"FinalCode"}."\n"; 11737 } 11738 $Interface_Init{"Headers"} = addHeaders($Obj_Init{"Headers"}, $Interface_Init{"Headers"}); 11739 $Interface_Init{"Code"} .= $Obj_Init{"Code"}; 11740 $Interface_Init{"Call"} = "delete($Var)"; 11741 $UsedInterfaces{$Interface} = 1; 11742 } 11743 elsif($Interface=~/D0/) 11744 { 11745 if(isAbstractClass($ClassId)) 11746 { # Impossible to call in-charge-deleting (D0) destructor in abstract class 11747 return (); 11748 } 11749 if($CompleteSignature{$Interface}{"Protected"}) 11750 { # Impossible to call protected in-charge-deleting (D0) destructor 11751 return (); 11752 } 11753 # push(@RecurTypeId, $ClassId); 11754 my %Obj_Init = findConstructor($ClassId, ""); 11755 # pop(@RecurTypeId); 11756 return () if(not $Obj_Init{"IsCorrect"}); 11757 if($CompleteSignature{$Obj_Init{"Interface"}}{"Protected"}) 11758 { # Impossible to call in-charge-deleting (D0) destructor in class with protected constructor 11759 return (); 11760 } 11761 $Interface_Init{"Init"} .= $Obj_Init{"Init"}; 11762 if($Obj_Init{"PreCondition"}) { 11763 $Interface_Init{"Init"} .= $Obj_Init{"PreCondition"}; 11764 } 11765 # $Interface_Init{"Init"} .= "//parameter initialization\n"; 11766 $Interface_Init{"Init"} .= $ClassName." *$Var = new ".$Obj_Init{"Call"}.";\n"; 11767 if($Obj_Init{"PostCondition"}) { 11768 $Interface_Init{"Init"} .= $Obj_Init{"PostCondition"}; 11769 } 11770 if($Obj_Init{"ReturnRequirement"}) 11771 { 11772 $Obj_Init{"ReturnRequirement"}=~s/(\$0|\$obj)/*$Var/gi; 11773 $Interface_Init{"Init"} .= $Obj_Init{"ReturnRequirement"} 11774 } 11775 if($Obj_Init{"FinalCode"}) 11776 { 11777 $Interface_Init{"Init"} .= "//final code\n"; 11778 $Interface_Init{"Init"} .= $Obj_Init{"FinalCode"}."\n"; 11779 } 11780 $Interface_Init{"Headers"} = addHeaders($Obj_Init{"Headers"}, $Interface_Init{"Headers"}); 11781 $Interface_Init{"Code"} .= $Obj_Init{"Code"}; 11782 $Interface_Init{"Call"} = "delete($Var)"; 11783 $UsedInterfaces{$Interface} = 1; 11784 } 11785 elsif($Interface=~/D1/) 11786 { 11787 if(isAbstractClass($ClassId)) 11788 { # Impossible to call in-charge (D1) destructor in abstract class 11789 return (); 11790 } 11791 if($CompleteSignature{$Interface}{"Protected"}) 11792 { # Impossible to call protected in-charge (D1) destructor 11793 return (); 11794 } 11795 # push(@RecurTypeId, $ClassId); 11796 my %Obj_Init = findConstructor($ClassId, ""); 11797 # pop(@RecurTypeId); 11798 return () if(not $Obj_Init{"IsCorrect"}); 11799 if($CompleteSignature{$Obj_Init{"Interface"}}{"Protected"}) 11800 { # Impossible to call in-charge (D1) destructor in class with protected constructor 11801 return (); 11802 } 11803 $Interface_Init{"Init"} .= $Obj_Init{"Init"}; 11804 # $Interface_Init{"Init"} .= "//parameter initialization\n"; 11805 if($Obj_Init{"PreCondition"}) { 11806 $Interface_Init{"Init"} .= $Obj_Init{"PreCondition"}; 11807 } 11808 $Interface_Init{"Init"} .= correct_init_stmt("$ClassName $Var = ".$Obj_Init{"Call"}.";\n", $ClassName, $Var); 11809 if($Obj_Init{"PostCondition"}) { 11810 $Interface_Init{"Init"} .= $Obj_Init{"PostCondition"}; 11811 } 11812 if($Obj_Init{"ReturnRequirement"}) 11813 { 11814 $Obj_Init{"ReturnRequirement"}=~s/(\$0|\$obj)/$Var/gi; 11815 $Interface_Init{"Init"} .= $Obj_Init{"ReturnRequirement"} 11816 } 11817 if($Obj_Init{"FinalCode"}) 11818 { 11819 $Interface_Init{"Init"} .= "//final code\n"; 11820 $Interface_Init{"Init"} .= $Obj_Init{"FinalCode"}."\n"; 11821 } 11822 $Interface_Init{"Headers"} = addHeaders($Obj_Init{"Headers"}, $Interface_Init{"Headers"}); 11823 $Interface_Init{"Code"} .= $Obj_Init{"Code"}; 11824 $Interface_Init{"Call"} = ""; # auto call after construction 11825 $UsedInterfaces{$Interface} = 1; 11826 } 11827 $Interface_Init{"Headers"} = addHeaders([$CompleteSignature{$Interface}{"Header"}], $Interface_Init{"Headers"}); 11828 $Interface_Init{"IsCorrect"} = 1; 11829 if(my $Typedef_Id = get_type_typedef($ClassId)) 11830 { 11831 $Interface_Init{"Headers"} = addHeaders(getTypeHeaders($Typedef_Id), $Interface_Init{"Headers"}); 11832 foreach my $Elem ("Call", "Init") { 11833 $Interface_Init{$Elem} = cover_by_typedef($Interface_Init{$Elem}, $ClassId, $Typedef_Id); 11834 } 11835 } 11836 else { 11837 $Interface_Init{"Headers"} = addHeaders(getTypeHeaders($ClassId), $Interface_Init{"Headers"}); 11838 } 11839 return %Interface_Init; 11840} 11841 11842sub testForConstructor($) 11843{ 11844 my $Interface = $_[0]; 11845 my $Ispecobjecttype = $InterfaceSpecType{$Interface}{"SpecObject"}; 11846 my $PointerLevelTarget = get_PointerLevel($SpecType{$Ispecobjecttype}{"TypeId"}); 11847 my $ClassId = $CompleteSignature{$Interface}{"Class"}; 11848 my $ClassName = get_TypeName($ClassId); 11849 my $Var = select_obj_name("", $ClassId); 11850 $Block_Variable{$CurrentBlock}{$Var} = 1; 11851 if(isInCharge($Interface)) 11852 { 11853 if(isAbstractClass($ClassId)) 11854 { # Impossible to call in-charge constructor in abstract class 11855 return (); 11856 } 11857 if($CompleteSignature{$Interface}{"Protected"}) 11858 { # Impossible to call in-charge protected constructor 11859 return (); 11860 } 11861 } 11862 my $HeapStack = ($SpecType{$Ispecobjecttype}{"TypeId"} and ($PointerLevelTarget eq 0))?"Stack":"Heap"; 11863 my $ObjectCall = ($HeapStack eq "Stack")?$Var:"(*$Var)"; 11864 my %Interface_Init = callInterfaceParameters(( 11865 "Interface"=>$Interface, 11866 "Key"=>"", 11867 "ObjectCall"=>$ObjectCall)); 11868 return () if(not $Interface_Init{"IsCorrect"}); 11869 my $PreviousBlock = $CurrentBlock; 11870 $CurrentBlock = $CurrentBlock."_code_".$Ispecobjecttype; 11871 my %ParsedCode = parseCode($SpecType{$Ispecobjecttype}{"Code"}, "Code"); 11872 $CurrentBlock = $PreviousBlock; 11873 return () if(not $ParsedCode{"IsCorrect"}); 11874 $SpecCode{$Ispecobjecttype} = 1 if($ParsedCode{"Code"}); 11875 $Interface_Init{"Code"} .= $ParsedCode{"NewGlobalCode"}.$ParsedCode{"Code"}; 11876 $Interface_Init{"Headers"} = addHeaders($ParsedCode{"Headers"}, $Interface_Init{"Headers"}); 11877 if(isAbstractClass($ClassId) or isNotInCharge($Interface) or ($CompleteSignature{$Interface}{"Protected"})) 11878 { 11879 my $ClassNameChild = getSubClassName($ClassName); 11880 if($Interface_Init{"Call"}=~/\A($ClassName([\n]*)\()/) 11881 { 11882 substr($Interface_Init{"Call"}, index($Interface_Init{"Call"}, $1), pos($1) + length($1)) = $ClassNameChild.$2."("; 11883 } 11884 $ClassName = $ClassNameChild; 11885 $UsedConstructors{$ClassId}{$Interface} = 1; 11886 $IntSubClass{$TestedInterface}{$ClassId} = 1; 11887 $Create_SubClass{$ClassId} = 1; 11888 } 11889 if($HeapStack eq "Stack") { 11890 $Interface_Init{"Call"} = correct_init_stmt($ClassName." $Var = ".$Interface_Init{"Call"}, $ClassName, $Var); 11891 } 11892 elsif($HeapStack eq "Heap") { 11893 $Interface_Init{"Call"} = $ClassName."* $Var = new ".$Interface_Init{"Call"}; 11894 } 11895 if(my $Typedef_Id = get_type_typedef($ClassId)) 11896 { 11897 $Interface_Init{"Headers"} = addHeaders(getTypeHeaders($Typedef_Id), $Interface_Init{"Headers"}); 11898 foreach my $Elem ("Call", "Init") { 11899 $Interface_Init{$Elem} = cover_by_typedef($Interface_Init{$Elem}, $ClassId, $Typedef_Id); 11900 } 11901 } 11902 else { 11903 $Interface_Init{"Headers"} = addHeaders(getTypeHeaders($ClassId), $Interface_Init{"Headers"}); 11904 } 11905 if($Ispecobjecttype and my $PostCondition = $SpecType{$Ispecobjecttype}{"PostCondition"} 11906 and $ObjectCall ne "" and (not defined $Template2Code or $Interface eq $TestedInterface)) 11907 { # postcondition 11908 $PostCondition=~s/(\$0|\$obj)/$ObjectCall/gi; 11909 $PostCondition = clearSyntax($PostCondition); 11910 my $NormalResult = $PostCondition; 11911 while($PostCondition=~s/([^\\])"/$1\\\"/g){} 11912 $ConstraintNum{$Interface}+=1; 11913 my $ReqId = get_ShortName($Interface).".".normalize_num($ConstraintNum{$Interface}); 11914 $RequirementsCatalog{$Interface}{$ConstraintNum{$Interface}} = "postcondition for the object: \'$PostCondition\'"; 11915 my $Comment = "postcondition for the object failed: \'$PostCondition\'"; 11916 $Interface_Init{"ReturnRequirement"} .= "REQ(\"$ReqId\",\n\"$Comment\",\n$NormalResult);\n"; 11917 $TraceFunc{"REQ"}=1; 11918 } 11919 # init code 11920 my $InitCode = $SpecType{$Ispecobjecttype}{"InitCode"}; 11921 $Interface_Init{"Init"} .= clearSyntax($InitCode); 11922 # final code 11923 my $ObjFinalCode = $SpecType{$Ispecobjecttype}{"FinalCode"}; 11924 $ObjFinalCode=~s/(\$0|\$obj)/$ObjectCall/gi; 11925 $Interface_Init{"FinalCode"} .= clearSyntax($ObjFinalCode); 11926 return %Interface_Init; 11927} 11928 11929sub add_VirtualTestData($$) 11930{ 11931 my ($Code, $Path) = @_; 11932 my $RelPath = test_data_relpath("sample.txt"); 11933 if($Code=~s/TG_TEST_DATA_(PLAIN|TEXT)_FILE/$RelPath/g) 11934 { # plain text files 11935 mkpath($Path); 11936 writeFile($Path."/sample.txt", "Where there's a will there's a way."); 11937 } 11938 $RelPath = test_data_abspath("sample", $Path); 11939 if($Code=~s/TG_TEST_DATA_ABS_FILE/$RelPath/g) 11940 { 11941 mkpath($Path); 11942 writeFile($Path."/sample", "Where there's a will there's a way."); 11943 } 11944 $RelPath = test_data_relpath("sample.xml"); 11945 if($Code=~s/TG_TEST_DATA_XML_FILE/$RelPath/g) 11946 { 11947 mkpath($Path); 11948 writeFile($Path."/sample.xml", getXMLSample()); 11949 } 11950 $RelPath = test_data_relpath("sample.html"); 11951 if($Code=~s/TG_TEST_DATA_HTML_FILE/$RelPath/g) 11952 { 11953 mkpath($Path); 11954 writeFile($Path."/sample.html", getHTMLSample()); 11955 } 11956 $RelPath = test_data_relpath("sample.dtd"); 11957 if($Code=~s/TG_TEST_DATA_DTD_FILE/$RelPath/g) 11958 { 11959 mkpath($Path); 11960 writeFile($Path."/sample.dtd", getDTDSample()); 11961 } 11962 $RelPath = test_data_relpath("sample.db"); 11963 if($Code=~s/TG_TEST_DATA_DB/$RelPath/g) 11964 { 11965 mkpath($Path); 11966 writeFile($Path."/sample.db", ""); 11967 } 11968 $RelPath = test_data_relpath("sample.audio"); 11969 if($Code=~s/TG_TEST_DATA_AUDIO/$RelPath/g) 11970 { 11971 mkpath($Path); 11972 writeFile($Path."/sample.audio", ""); 11973 } 11974 $RelPath = test_data_relpath("sample.asoundrc"); 11975 if($Code=~s/TG_TEST_DATA_ASOUNDRC_FILE/$RelPath/g) 11976 { 11977 mkpath($Path); 11978 writeFile($Path."/sample.asoundrc", getASoundRCSample()); 11979 } 11980 $RelPath = test_data_relpath(""); 11981 if($Code=~s/TG_TEST_DATA_DIRECTORY/$RelPath/g) 11982 { 11983 mkpath($Path); 11984 writeFile($Path."/sample.txt", "Where there's a will there's a way."); 11985 } 11986 while($Code=~/TG_TEST_DATA_FILE_([A-Z]+)/) 11987 { 11988 my ($Type, $Ext) = ($1, lc($1)); 11989 $RelPath = test_data_relpath("sample.$Ext"); 11990 $Code=~s/TG_TEST_DATA_FILE_$Type/$RelPath/g; 11991 mkpath($Path); 11992 writeFile($Path."/sample.$Ext", ""); 11993 } 11994 return $Code; 11995} 11996 11997sub test_data_relpath($) 11998{ 11999 my $File = $_[0]; 12000 if(defined $Template2Code) { 12001 return "T2C_GET_DATA_PATH(\"$File\")"; 12002 } 12003 else { 12004 return "\"testdata/$File\""; 12005 } 12006} 12007 12008sub test_data_abspath($$) 12009{ 12010 my ($File, $Path) = @_; 12011 if(defined $Template2Code) { 12012 return "T2C_GET_DATA_PATH(\"$File\")"; 12013 } 12014 else { 12015 return "\"".abs_path("./")."/".$Path.$File."\""; 12016 } 12017} 12018 12019sub getXMLSample() 12020{ 12021 return "<?xml version=\"1.0\" encoding=\"UTF-8\"?> 12022<note> 12023 <to>Tove</to> 12024 <from>Jani</from> 12025 <heading>Reminder</heading> 12026 <body>Don't forget me this weekend!</body> 12027</note>"; 12028} 12029 12030sub getHTMLSample() 12031{ 12032 return "<html> 12033<body> 12034Where there's a will there's a way. 12035</body> 12036</html>"; 12037} 12038 12039sub getDTDSample() 12040{ 12041 return "<!ELEMENT note (to,from,heading,body)> 12042<!ELEMENT to (#PCDATA)> 12043<!ELEMENT from (#PCDATA)> 12044<!ELEMENT heading (#PCDATA)> 12045<!ELEMENT body (#PCDATA)>"; 12046} 12047 12048sub getASoundRCSample() 12049{ 12050 if(my $Sample = readFile("/usr/share/alsa/alsa.conf")) 12051 { 12052 return $Sample; 12053 } 12054 elsif(my $Sample = readFile("/etc/asound-pulse.conf")) 12055 { 12056 return $Sample; 12057 } 12058 elsif(my $Sample = readFile("/etc/asound.conf")) 12059 { 12060 return $Sample; 12061 } 12062 else 12063 { 12064 return "pcm.card0 { 12065 type hw 12066 card 0 12067} 12068ctl.card0 { 12069 type hw 12070 card 0 12071}"; 12072 } 12073} 12074 12075sub add_TestData($$) 12076{ 12077 my ($Code, $Path) = @_; 12078 my %CopiedFiles = (); 12079 if($Code=~/TEST_DATA_PATH/) 12080 { 12081 if(not $TestDataPath) 12082 { 12083 printMsg("ERROR", "test data directory is not specified"); 12084 return $Code; 12085 } 12086 } 12087 while($Code=~s/TEST_DATA_PATH[ ]*\([ ]*"([^\(\)]+)"[ ]*\)/test_data_relpath($1)/ge) 12088 { 12089 my $FileName = $1; 12090 next if($CopiedFiles{$FileName}); 12091 mkpath($Path); 12092 next if(not -e $TestDataPath."/".$FileName); 12093 copy($TestDataPath."/".$FileName, $Path); 12094 $CopiedFiles{$FileName} = 1; 12095 } 12096 return $Code; 12097} 12098 12099sub constraint_for_environment($$$) 12100{ 12101 my ($Interface, $ConditionType, $Condition) = @_; 12102 $ConstraintNum{$Interface}+=1; 12103 my $ReqId = get_ShortName($Interface).".".normalize_num($ConstraintNum{$Interface}); 12104 $RequirementsCatalog{$Interface}{$ConstraintNum{$Interface}} = "$ConditionType for the environment: \'$Condition\'"; 12105 my $Comment = "$ConditionType for the environment failed: \'$Condition\'"; 12106 $TraceFunc{"REQ"}=1; 12107 return "REQ(\"$ReqId\",\n\"$Comment\",\n$Condition);\n"; 12108} 12109 12110sub get_env_conditions($$) 12111{ 12112 my ($Interface, $SpecEnv_Id) = @_; 12113 my %Conditions = (); 12114 if(my $InitCode = $SpecType{$SpecEnv_Id}{"InitCode"}) { 12115 $Conditions{"Preamble"} .= $InitCode."\n"; 12116 } 12117 if(my $FinalCode = $SpecType{$SpecEnv_Id}{"FinalCode"}) { 12118 $Conditions{"Finalization"} .= $FinalCode."\n"; 12119 } 12120 if(my $GlobalCode = $SpecType{$SpecEnv_Id}{"GlobalCode"}) { 12121 $Conditions{"Env_CommonCode"} .= $GlobalCode."\n"; 12122 $SpecCode{$SpecEnv_Id} = 1; 12123 } 12124 if(my $PreCondition = $SpecType{$SpecEnv_Id}{"PreCondition"}) { 12125 $Conditions{"Env_PreRequirements"} .= constraint_for_environment($Interface, "precondition", $PreCondition); 12126 } 12127 if(my $PostCondition = $SpecType{$SpecEnv_Id}{"PostCondition"}) { 12128 $Conditions{"Env_PostRequirements"} .= constraint_for_environment($Interface, "postcondition", $PostCondition); 12129 } 12130 foreach my $Lib (keys(%{$SpecType{$SpecEnv_Id}{"Libs"}})) { 12131 $SpecLibs{$Lib} = 1; 12132 } 12133 return %Conditions; 12134} 12135 12136sub path_format($$) 12137{ 12138 my ($Path, $Fmt) = @_; 12139 $Path=~s/[\/\\]+\.?\Z//g; 12140 if($Fmt eq "windows") 12141 { 12142 $Path=~s/\//\\/g; 12143 $Path=lc($Path); 12144 } 12145 else 12146 { # forward slash to pass into MinGW GCC 12147 $Path=~s/\\/\//g; 12148 } 12149 return $Path; 12150} 12151 12152sub inc_opt($$) 12153{ 12154 my ($Path, $Style) = @_; 12155 $Path=~s/\A\"//; 12156 $Path=~s/\"\Z//; 12157 return "" if(not $Path); 12158 if($Style eq "GCC") 12159 { # GCC options 12160 if($OSgroup eq "windows") 12161 { # to MinGW GCC 12162 return "-I\"".path_format($Path, "unix")."\""; 12163 } 12164 elsif($OSgroup eq "macos" 12165 and $Path=~/\.framework\Z/) 12166 { # to Apple's GCC 12167 return "-F".esc(get_dirname($Path)); 12168 } 12169 else { 12170 return "-I".esc($Path); 12171 } 12172 } 12173 elsif($Style eq "CL") { 12174 return "/I \"$Path\""; 12175 } 12176 return ""; 12177} 12178 12179sub esc_option($$) 12180{ 12181 my ($Path, $Style) = @_; 12182 return "" if(not $Path); 12183 if($Style eq "GCC") 12184 { # GCC options 12185 if($OSgroup eq "windows") 12186 { # to MinGW GCC 12187 return "\"".path_format($Path, "unix")."\""; 12188 } 12189 else { 12190 return esc($Path); 12191 } 12192 } 12193 elsif($Style eq "CL") { 12194 return "\"".$Path."\""; 12195 } 12196 return ""; 12197} 12198 12199sub generateTest($) 12200{ 12201 my %Result = (); 12202 my $Interface = $_[0]; 12203 return () if(not $Interface); 12204 my $CommonCode = ""; 12205 my %TestComponents = (); 12206 $TestedInterface = $Interface; 12207 $CurrentBlock = "main"; 12208 $ValueCollection{$CurrentBlock}{"argc"} = get_TypeIdByName("int"); 12209 $Block_Param{$CurrentBlock}{"argc"} = get_TypeIdByName("int"); 12210 $Block_Variable{$CurrentBlock}{"argc"} = 1; 12211 $ValueCollection{$CurrentBlock}{"argv"} = get_TypeIdByName("char**"); 12212 $Block_Param{$CurrentBlock}{"argv"} = get_TypeIdByName("char**"); 12213 $Block_Variable{$CurrentBlock}{"argv"} = 1; 12214 12215 my ($CommonPreamble, $Preamble, $Finalization, $Env_CommonCode, $Env_PreRequirements, $Env_PostRequirements) = (); 12216 foreach my $SpecEnv_Id (sort {int($a)<=>int($b)} (keys(%Common_SpecEnv))) 12217 { # common environments 12218 next if($Common_SpecType_Exceptions{$Interface}{$SpecEnv_Id}); 12219 my %Conditions = get_env_conditions($Interface, $SpecEnv_Id); 12220 $CommonPreamble .= $Conditions{"Preamble"};# in the direct order 12221 $Finalization = $Conditions{"Finalization"}.$Finalization;# in the backward order 12222 $Env_CommonCode .= $Conditions{"Env_CommonCode"}; 12223 $Env_PreRequirements .= $Conditions{"Env_PreRequirements"};# in the direct order 12224 $Env_PostRequirements = $Conditions{"Env_PostRequirements"}.$Env_PostRequirements;# in the backward order 12225 } 12226 12227 # parsing of common preamble code for using 12228 # created variables in the following test case 12229 my %CommonPreamble_Parsed = parseCode($CommonPreamble, "Code"); 12230 $CommonPreamble = $CommonPreamble_Parsed{"Code"}; 12231 $CommonCode = $CommonPreamble_Parsed{"NewGlobalCode"}.$CommonCode; 12232 $TestComponents{"Headers"} = addHeaders($CommonPreamble_Parsed{"Headers"}, $TestComponents{"Headers"}); 12233 12234 # creating test case 12235 if($CompleteSignature{$Interface}{"Constructor"}) 12236 { 12237 %TestComponents = testForConstructor($Interface); 12238 $CommonCode .= $TestComponents{"Code"}; 12239 } 12240 elsif($CompleteSignature{$Interface}{"Destructor"}) 12241 { 12242 %TestComponents = testForDestructor($Interface); 12243 $CommonCode .= $TestComponents{"Code"}; 12244 } 12245 else 12246 { 12247 %TestComponents = callInterface(( 12248 "Interface"=>$Interface)); 12249 $CommonCode .= $TestComponents{"Code"}; 12250 } 12251 if(not $TestComponents{"IsCorrect"}) 12252 { 12253 $ResultCounter{"Gen"}{"Fail"} += 1; 12254 $GenResult{$Interface}{"IsCorrect"} = 0; 12255 return (); 12256 } 12257 if($TraceFunc{"REQ"} and not defined $Template2Code) { 12258 $CommonCode = get_REQ_define($Interface)."\n".$CommonCode; 12259 } 12260 if($TraceFunc{"REQva"} and not defined $Template2Code) { 12261 $CommonCode = get_REQva_define($Interface)."\n".$CommonCode; 12262 } 12263 12264 foreach my $SpecEnv_Id (sort {int($a)<=>int($b)} (keys(%SpecEnv))) 12265 { # environments used in the test case 12266 my %Conditions = get_env_conditions($Interface, $SpecEnv_Id); 12267 $Preamble .= $Conditions{"Preamble"};# in the direct order 12268 $Finalization = $Conditions{"Finalization"}.$Finalization;# in the backward order 12269 $Env_CommonCode .= $Conditions{"Env_CommonCode"}; 12270 $Env_PreRequirements .= $Conditions{"Env_PreRequirements"};# in the direct order 12271 $Env_PostRequirements = $Conditions{"Env_PostRequirements"}.$Env_PostRequirements;# in the backward order 12272 } 12273 12274 my %Preamble_Parsed = parseCode($Preamble, "Code"); 12275 $Preamble = $Preamble_Parsed{"Code"}; 12276 $CommonCode = $Preamble_Parsed{"NewGlobalCode"}.$CommonCode; 12277 $TestComponents{"Headers"} = addHeaders($Preamble_Parsed{"Headers"}, $TestComponents{"Headers"}); 12278 12279 my %Finalization_Parsed = parseCode($Finalization, "Code"); 12280 $Finalization = $Finalization_Parsed{"Code"}; 12281 $CommonCode = $Finalization_Parsed{"NewGlobalCode"}.$CommonCode; 12282 $TestComponents{"Headers"} = addHeaders($Finalization_Parsed{"Headers"}, $TestComponents{"Headers"}); 12283 12284 my %Env_ParsedCode = parseCode($Env_CommonCode, "Code"); 12285 $CommonCode = $Env_ParsedCode{"NewGlobalCode"}.$Env_ParsedCode{"Code"}.$CommonCode; 12286 $TestComponents{"Headers"} = addHeaders($Env_ParsedCode{"Headers"}, $TestComponents{"Headers"}); 12287 foreach my $Header (@{$Env_ParsedCode{"Headers"}}) { 12288 $SpecTypeHeaders{get_filename($Header)}=1; 12289 } 12290 # insert subclasses 12291 my ($SubClasses_Code, $SubClasses_Headers) = create_SubClasses(keys(%Create_SubClass)); 12292 $TestComponents{"Headers"} = addHeaders($SubClasses_Headers, $TestComponents{"Headers"}); 12293 $CommonCode = $SubClasses_Code.$CommonCode; 12294 # close streams 12295 foreach my $Stream (keys(%{$OpenStreams{"main"}})) { 12296 $Finalization .= "fclose($Stream);\n"; 12297 } 12298 # assemble test 12299 my ($SanityTest, $SanityTestMain, $SanityTestBody) = (); 12300 if($CommonPreamble.$Preamble) 12301 { 12302 $SanityTestMain .= "//preamble\n"; 12303 $SanityTestMain .= $CommonPreamble.$Preamble."\n"; 12304 } 12305 if($Env_PreRequirements) { 12306 $SanityTestMain .= $Env_PreRequirements."\n"; 12307 } 12308 if($TestComponents{"Init"}) { 12309 $SanityTestBody .= $TestComponents{"Init"}; 12310 } 12311 # precondition for parameters 12312 if($TestComponents{"PreCondition"}) { 12313 $SanityTestBody .= $TestComponents{"PreCondition"}; 12314 } 12315 if($TestComponents{"Call"}) 12316 { 12317 if($TestComponents{"ReturnRequirement"} and $CompleteSignature{$Interface}{"Return"}) 12318 { # call interface and check return value 12319 my $ReturnType_Id = $CompleteSignature{$Interface}{"Return"}; 12320 my $ReturnType_Name = $TypeInfo{$ReturnType_Id}{"Name"}; 12321 my $ReturnType_PointerLevel = get_PointerLevel($ReturnType_Id); 12322 my $ReturnFType_Id = get_FoundationTypeId($ReturnType_Id); 12323 my $ReturnFType_Name = get_TypeName($ReturnFType_Id); 12324 if($ReturnFType_Name eq "void" and $ReturnType_PointerLevel==1) 12325 { 12326 my $RetVal = select_var_name("retval", ""); 12327 $TestComponents{"ReturnRequirement"}=~s/(\$0|\$retval)/$RetVal/gi; 12328 $SanityTestBody .= "int* $RetVal = (int*)".$TestComponents{"Call"}."; //target call\n"; 12329 $Block_Variable{$CurrentBlock}{$RetVal} = 1; 12330 } 12331 elsif($ReturnFType_Name eq "void" and $ReturnType_PointerLevel==0) { 12332 $SanityTestBody .= $TestComponents{"Call"}."; //target call\n"; 12333 } 12334 else 12335 { 12336 my $RetVal = select_var_name("retval", ""); 12337 $TestComponents{"ReturnRequirement"}=~s/(\$0|\$retval)/$RetVal/gi; 12338 my ($InitializedEType_Id, $Declarations, $Headers) = get_ExtTypeId($RetVal, $ReturnType_Id); 12339 my $InitializedType_Name = get_TypeName($InitializedEType_Id); 12340 $TestComponents{"Code"} .= $Declarations; 12341 $TestComponents{"Headers"} = addHeaders($Headers, $TestComponents{"Headers"}); 12342 my $Break = ((length($InitializedType_Name)>20)?"\n":" "); 12343 my $InitializedFType_Id = get_FoundationTypeId($ReturnType_Id); 12344 if(($InitializedType_Name eq $ReturnType_Name)) { 12345 $SanityTestBody .= $ReturnType_Name.$Break.$RetVal." = ".$TestComponents{"Call"}."; //target call\n"; 12346 } 12347 else { 12348 $SanityTestBody .= $InitializedType_Name.$Break.$RetVal." = "."(".$InitializedType_Name.")".$TestComponents{"Call"}."; //target call\n"; 12349 } 12350 $Block_Variable{$CurrentBlock}{$RetVal} = 1; 12351 $TestComponents{"Headers"} = addHeaders(getTypeHeaders($InitializedFType_Id), $TestComponents{"Headers"}); 12352 } 12353 } 12354 else { 12355 $SanityTestBody .= $TestComponents{"Call"}."; //target call\n"; 12356 } 12357 } 12358 elsif($CompleteSignature{$Interface}{"Destructor"}) { 12359 $SanityTestBody .= "//target interface will be called at the end of main() function automatically\n"; 12360 } 12361 if($TestComponents{"ReturnRequirement"}) { 12362 $SanityTestBody .= $TestComponents{"ReturnRequirement"}."\n"; 12363 } 12364 # postcondition for parameters 12365 if($TestComponents{"PostCondition"}) { 12366 $SanityTestBody .= $TestComponents{"PostCondition"}."\n"; 12367 } 12368 if($TestComponents{"FinalCode"}) 12369 { 12370 $SanityTestBody .= "//final code\n"; 12371 $SanityTestBody .= $TestComponents{"FinalCode"}."\n"; 12372 } 12373 $SanityTestMain .= $SanityTestBody; 12374 if($Finalization) 12375 { 12376 $SanityTestMain .= "\n//finalization\n"; 12377 $SanityTestMain .= $Finalization."\n"; 12378 } 12379 if($Env_PostRequirements) { 12380 $SanityTestMain .= $Env_PostRequirements."\n"; 12381 } 12382 if(my $AddDefines = $Descriptor{"Defines"}) 12383 { 12384 $AddDefines=~s/\n\s+/\n/g; 12385 $SanityTest .= $AddDefines."\n"; 12386 } 12387 # clear code syntax 12388 $SanityTestMain = alignCode($SanityTestMain, " ", 0); 12389 @{$TestComponents{"Headers"}} = reverse(@{$TestComponents{"Headers"}}); 12390 if(keys(%ConstraintNum)>0) 12391 { 12392 if(getTestLang($Interface) eq "C++") 12393 { 12394 $TestComponents{"Headers"} = addHeaders(["iostream"], $TestComponents{"Headers"}); 12395 $AuxHeaders{"iostream"} = 1; 12396 } 12397 else 12398 { 12399 $TestComponents{"Headers"} = addHeaders(["stdio.h"], $TestComponents{"Headers"}); 12400 $AuxHeaders{"stdio.h"} = 1; 12401 } 12402 } 12403 @{$TestComponents{"Headers"}} = (@Include_Preamble, @{$TestComponents{"Headers"}}); 12404 12405 if(keys(%Include_Order)) 12406 { 12407 if(grep {defined $Include_Order{$_}} @{$TestComponents{"Headers"}}) { 12408 $TestComponents{"Headers"} = orderHeaders($TestComponents{"Headers"}); 12409 } 12410 } 12411 12412 my ($Headers, $IncPaths) = prepareHeaders(@{$TestComponents{"Headers"}}); 12413 12414 $Result{"Headers"} = []; 12415 my $HList = ""; 12416 foreach my $Header (@{$Headers}) 12417 { 12418 $HList .= "#include <".$Header.">\n"; 12419 push(@{$Result{"Headers"}}, $Header); 12420 if($Header=~/\+\+(\.h|)\Z/) { 12421 $UsedInterfaces{"__gxx_personality"} = 1; 12422 } 12423 } 12424 $SanityTest .= $HList; 12425 12426 my %UsedNameSpaces = (); 12427 foreach my $NameSpace (add_namespaces(\$CommonCode), add_namespaces(\$SanityTestMain)) { 12428 $UsedNameSpaces{$NameSpace} = 1; 12429 } 12430 if(keys(%UsedNameSpaces)) 12431 { 12432 $SanityTest .= "\n"; 12433 foreach my $NameSpace (sort {get_depth($a,"::")<=>get_depth($b,"::")} keys(%UsedNameSpaces)) { 12434 $SanityTest .= "using namespace $NameSpace;\n"; 12435 } 12436 $SanityTest .= "\n"; 12437 } 12438 if($CommonCode) 12439 { 12440 $SanityTest .= "\n$CommonCode\n\n"; 12441 $Result{"Code"} = $CommonCode; 12442 } 12443 $SanityTest .= "int main(int argc, char *argv[])\n"; 12444 $SanityTest .= "{\n"; 12445 $Result{"main"} = correct_spaces($SanityTestMain); 12446 $SanityTestMain .= " return 0;\n"; 12447 $SanityTest .= $SanityTestMain; 12448 $SanityTest .= "}\n"; 12449 $SanityTest = correct_spaces($SanityTest); # cleaning code 12450 if(getTestLang($Interface) eq "C++" and getSymLang($Interface) eq "C") 12451 { # removing extended initializer lists 12452 $SanityTest=~s/({\s*|\s)\.[a-z_][a-z_\d]*\s*=\s*/$1 /ig; 12453 } 12454 if(defined $Standalone) 12455 { # create stuff for building and running test 12456 my $TestFileName = (getTestLang($Interface) eq "C++")?"test.cpp":"test.c"; 12457 my $TestPath = getTestPath($Interface); 12458 if(-e $TestPath) { 12459 rmtree($TestPath); 12460 } 12461 mkpath($TestPath); 12462 $Interface_TestDir{$Interface} = $TestPath; 12463 $SanityTest = add_VirtualTestData($SanityTest, $TestPath."/testdata/"); 12464 $SanityTest = add_TestData($SanityTest, $TestPath."/testdata/"); 12465 writeFile("$TestPath/$TestFileName", $SanityTest); 12466 my $SharedObject = $Symbol_Library{$Interface}; 12467 $SharedObject = $DepSymbol_Library{$Interface} if(not $SharedObject); 12468 my $TestInfo = "Library: $TargetLibraryName-".$Descriptor{"Version"}; 12469 $TestInfo .= "\nInterface: ".get_Signature($Interface); 12470 $TestInfo .= "\nSymbol: $Interface"; 12471 12472 my %SInfo = %{$CompleteSignature{$Interface}}; 12473 12474 if($Interface=~/\A(_Z|\?)/) { 12475 $TestInfo .= "\nShort Name: ".$SInfo{"ShortName"}; 12476 } 12477 $TestInfo .= "\nHeader: ".$SInfo{"Header"}; 12478 if($SharedObject) { 12479 $TestInfo .= "\nShared Object: ".get_filename($SharedObject); 12480 } 12481 my $NameSpace = select_Symbol_NS($Interface); 12482 if($NameSpace) { 12483 $TestInfo .= "\nNamespace: ".$NameSpace; 12484 } 12485 writeFile("$TestPath/info", $TestInfo); 12486 my $Signature = get_Signature($Interface); 12487 12488 $Signature=~s/\s+:.+\Z//; # return value 12489 $Signature=~s/\s*\[[a-z\-]+\]//g; # [in-charge], [static], etc. 12490 if($NameSpace) { 12491 $Signature=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12492 } 12493 12494 my $Title = "Test for ".htmlSpecChars($Signature); 12495 my $Keywords = htmlSpecChars($SInfo{"ShortName"}).", unit test"; 12496 my $Description = "Sanity test for ".htmlSpecChars($Signature); 12497 12498 my $View = ""; 12499 12500 if(my $Class = $SInfo{"Class"}) 12501 { 12502 my $ClassName = get_TypeName($Class); 12503 if($NameSpace) { 12504 $ClassName=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12505 } 12506 if($SInfo{"Constructor"}) 12507 { # c-tor 12508 $View .= "<h1>Test for c-tor of <span style='color:Red'>".htmlSpecChars($ClassName)."</span> class</h1>\n"; 12509 } 12510 elsif($SInfo{"Destructor"}) 12511 { # d-tor 12512 $View .= "<h1>Test for d-tor of <span style='color:Red'>".htmlSpecChars($ClassName)."</span> class</h1>\n"; 12513 } 12514 else 12515 { # method 12516 $View .= "<h1>Test for <span style='color:Red'>".htmlSpecChars($SInfo{"ShortName"})."</span> method of <span style='color:Blue'>".htmlSpecChars($ClassName)."</span> class</h1>\n"; 12517 } 12518 } 12519 else { 12520 $View .= "<h1>Test for <span style='color:Red'>".htmlSpecChars($SInfo{"ShortName"})."</span> function</h1>\n"; 12521 } 12522 # $View .= highLight_Signature_Italic_Color($Signature)."\n"; 12523 my $Unmangled = $tr_name{$Interface}; 12524 if($NameSpace) { 12525 $Unmangled=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12526 } 12527 $View .= "<span class='yellow'>".highLight_Signature_Italic_Color($Signature)."</span>\n"; 12528 if($Interface=~/\A(_Z|\?)/) { 12529 $View .= "<br/><i><span class='yellow'>$Interface</span></i>\n"; 12530 } 12531 12532 # summary 12533 $View .= "<h2>Symbol Info</h2><hr/>\n"; 12534 12535 $View .= "<table class='summary'>\n"; 12536 $View .= "<tr><th>Header File</th><td>".$SInfo{"Header"}."</td></tr>\n"; 12537 12538# my $SharedObject = get_filename($Symbol_Library{$Interface}); 12539# $SharedObject = get_filename($DepSymbol_Library{$Interface}) if(not $SharedObject); 12540# 12541# if($SharedObject) { 12542# $View .= "<tr><th>Library</th><td>".$SharedObject."</td></tr>\n"; 12543# } 12544 12545 if($NameSpace) { 12546 $View .= "<tr><th>Namespace</th><td>".$NameSpace."</td></tr>\n"; 12547 } 12548 if(my $Class = $SInfo{"Class"}) 12549 { 12550 my $ClassName = get_TypeName($Class); 12551 if($NameSpace) { 12552 $ClassName=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12553 } 12554 $View .= "<tr><th>Class</th><td>".htmlSpecChars($ClassName)."</td></tr>\n"; 12555 if($SInfo{"Constructor"}) 12556 { # c-tor 12557 $View .= "<tr><th>Method</th><td>Constructor</td></tr>\n"; 12558 if(my $ChargeLevel = get_ChargeLevel($Interface)) { 12559 $View .= "<tr><th>Kind</th><td>$ChargeLevel</td></tr>\n"; 12560 } 12561 } 12562 elsif($SInfo{"Destructor"}) 12563 { # d-tor 12564 $View .= "<tr><th>Method</th><td>Destructor</td></tr>\n"; 12565 if(my $ChargeLevel = get_ChargeLevel($Interface)) { 12566 $View .= "<tr><th>Kind</th><td>$ChargeLevel</td></tr>\n"; 12567 } 12568 } 12569 else 12570 { # method 12571 $View .= "<tr><th>Method</th><td>".htmlSpecChars($SInfo{"ShortName"})."</td></tr>\n"; 12572 } 12573 } 12574 else 12575 { 12576 $View .= "<tr><th>Function</th><td>".htmlSpecChars($SInfo{"ShortName"})."</td></tr>\n"; 12577 } 12578 if(my $Return = $SInfo{"Return"}) 12579 { 12580 my $ReturnType = get_TypeName($Return); 12581 if($NameSpace) { 12582 $ReturnType=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12583 } 12584 $View .= "<tr><th>Return Type</th><td>".htmlSpecChars($ReturnType)."</td></tr>\n"; 12585 } 12586 if(my @Params = keys(%{$SInfo{"Param"}})) { 12587 $View .= "<tr><th>Parameters</th><td><a href='#Params'>".($#Params+1)."</a></td></tr>\n"; 12588 } 12589 else { 12590 # $View .= "<tr><th>Parameters</th><td>none</td></tr>\n"; 12591 } 12592 12593 $View .= "</table>\n"; 12594 12595 if(keys(%{$SInfo{"Param"}})) 12596 { 12597 $View .= "<a name='Params'></a>\n"; 12598 $View .= "<h2>Parameters</h2><hr/>\n"; 12599 $View .= "<table class='summary'>\n"; 12600 $View .= "<tr><th width='20px'>#</th><th>Name</th><th>Type</th></tr>\n"; 12601 foreach my $Pos (sort {int($a)<=>int($b)} keys(%{$SInfo{"Param"}})) 12602 { 12603 my $TName = get_TypeName($SInfo{"Param"}{$Pos}{"type"}); 12604 if($NameSpace) { 12605 $TName=~s/(\W|\A)\Q$NameSpace\E\:\:(\w)/$1$2/g; 12606 } 12607 $View .= "<tr><td>$Pos</td><td><span class='color_p'>".$SInfo{"Param"}{$Pos}{"name"}."</span></td><td>".htmlSpecChars($TName)."</td></tr>\n"; 12608 } 12609 $View .= "</table>\n"; 12610 } 12611 12612 # code 12613 $View .= "<h2>Code</h2><hr/>\n"; 12614 $View .= "<!--Test-->\n".get_TestView($SanityTest, $Interface)."<!--Test_End-->\n"; 12615 12616 my $CssStyles = readModule("Styles", "Test.css"); 12617 $View = composeHTML_Head($Title, $Keywords, $Description, $CssStyles, "")."<body>\n".$View.$TOOL_SIGNATURE."\n<div style='height:700px;'></div>\n</body>\n</html>\n"; 12618 writeFile("$TestPath/view.html", $View); 12619 12620 %UsedSharedObjects = (); 12621 12622 foreach my $Sym (keys(%UsedInterfaces)) 12623 { # add v-tables 12624 if(index($Sym, "C1E")!=-1 12625 or index($Sym, "C2E")!=-1) 12626 { 12627 if(my $VTable = getVTSymbol($Sym)) 12628 { # guess v-table name 12629 $UsedInterfaces{$VTable} = 1; 12630 12631 $VTable=~s/\A_ZTVN/_ZTV/; 12632 $VTable=~s/E\Z//; 12633 $UsedInterfaces{$VTable} = 1; 12634 } 12635 if(my $TInfo = getTISymbol($Sym)) 12636 { # guess typeinfo name 12637 $UsedInterfaces{$TInfo} = 1; 12638 12639 $TInfo=~s/\A_ZTIN/_ZTI/; 12640 $UsedInterfaces{$TInfo} = 1; 12641 } 12642 } 12643 } 12644 12645 # used symbols 12646 foreach my $Sym (keys(%UsedInterfaces)) 12647 { 12648 if(my $Path = $Symbol_Library{$Sym}) { 12649 $UsedSharedObjects{$Path} = 1; 12650 } 12651 elsif(my $Path = $DepSymbol_Library{$Sym}) 12652 { 12653 if(index(get_filename($Path), "libstdc++")!=-1) 12654 { # will be included by the compiler automatically 12655 next; 12656 } 12657 $UsedSharedObjects{$Path} = 1; 12658 } 12659 else 12660 { 12661 # TODO 12662 } 12663 } 12664 12665 # undefined symbols 12666 foreach my $Path (keys(%UsedSharedObjects)) 12667 { 12668 foreach my $Dep (getLib_Deps($Path)) 12669 { # required libraries 12670 $UsedSharedObjects{$Dep} = 1; 12671 } 12672 } 12673 12674 # needed libs 12675 my %LibName_P = (); 12676 foreach my $Path (keys(%UsedSharedObjects)) { 12677 $LibName_P{get_filename($Path)}{$Path} = 1; 12678 } 12679 12680 foreach my $Path (keys(%UsedSharedObjects)) 12681 { 12682 my $Name = get_filename($Path); 12683 foreach my $Dep (keys(%{$Library_Needed{$Name}})) 12684 { 12685 $Dep = identifyLibrary($Dep); 12686 if(is_abs($Dep)) 12687 { # links 12688 $Dep = realpath($Dep); 12689 } 12690 $Dep = get_filename($Dep); 12691 if(defined $LibName_P{$Dep}) 12692 { 12693 my @Paths = keys(%{$LibName_P{$Dep}}); 12694 if($#Paths==0) 12695 { 12696 my $Dir = get_dirname($Paths[0]); 12697 if(not grep {$Dir eq $_} @DefaultLibPaths) 12698 { # non-default 12699 next; 12700 } 12701 delete($UsedSharedObjects{$Paths[0]}); 12702 } 12703 } 12704 } 12705 } 12706 12707 writeFile("$TestPath/Makefile", get_Makefile($Interface, $IncPaths)); 12708 12709 my $RunScript = ($OSgroup eq "windows")?"run_test.bat":"run_test.sh"; 12710 writeFile("$TestPath/$RunScript", get_RunScript($Interface)); 12711 chmod(0775, $TestPath."/$RunScript"); 12712 } 12713 else 12714 { # t2c 12715 } 12716 $GenResult{$Interface}{"IsCorrect"} = 1; 12717 $ResultCounter{"Gen"}{"Success"} += 1; 12718 $Result{"IsCorrect"} = 1; 12719 return %Result; 12720} 12721 12722sub getLib_Deps($) 12723{ 12724 my $Path = $_[0]; 12725 12726 if(grep {$Path eq $_} @RecurLib) 12727 { # lock 12728 return (); 12729 } 12730 push(@RecurLib, $Path); 12731 12732 my %Deps = (); 12733 foreach my $Sym (keys(%{$UndefinedSymbols{get_filename($Path)}})) 12734 { 12735 if(my $P = $Symbol_Library{$Sym}) { 12736 $Deps{$P} = 1; 12737 } 12738 elsif(my $P = $DepSymbol_Library{$Sym}) { 12739 $Deps{$P} = 1; 12740 } 12741 elsif(index($Sym, '@')!=-1) 12742 { 12743 $Sym=~s/\@/\@\@/; 12744 if(my $P = $Symbol_Library{$Sym}) { 12745 $Deps{$P} = 1; 12746 } 12747 elsif(my $P = $DepSymbol_Library{$Sym}) { 12748 $Deps{$P} = 1; 12749 } 12750 } 12751 } 12752 foreach my $P (keys(%Deps)) 12753 { 12754 foreach my $Dep (getLib_Deps($P)) 12755 { # recursive 12756 $Deps{$Dep} = 1; 12757 } 12758 } 12759 12760 pop(@RecurLib); 12761 return keys(%Deps); 12762} 12763 12764sub getVTSymbol($) 12765{ 12766 my $Symbol = $_[0]; 12767 $Symbol=~s/\A_ZN/_ZTVN/; 12768 $Symbol=~s/(C1E|C2E).*?\Z/E/; 12769 return $Symbol; 12770} 12771 12772sub getTISymbol($) 12773{ 12774 my $Symbol = $_[0]; 12775 $Symbol=~s/\A_ZN/_ZTIN/; 12776 $Symbol=~s/(C1E|C2E).*?\Z//; 12777 return $Symbol; 12778} 12779 12780sub getTestLang($) 12781{ 12782 my $Symbol = $_[0]; 12783 12784 if(getSymLang($Symbol) eq "C++") { 12785 return "C++"; 12786 } 12787 12788 foreach my $S (keys(%UsedInterfaces)) 12789 { 12790 if(getSymLang($S) eq "C++") { 12791 return "C++"; 12792 } 12793 } 12794 12795 return $COMMON_LANGUAGE; 12796} 12797 12798sub getSymLang($) 12799{ 12800 my $Symbol = $_[0]; 12801 my $Header = $CompleteSignature{$Symbol}{"Header"}; 12802 12803 if($Header=~/\.(hh|hp|hxx|hpp|h\+\+)\Z/i 12804 or $Header!~/\.[^\.]+\Z/) { 12805 return "C++"; 12806 } 12807 if(index($Symbol, "_Z")==0) 12808 { # mangled symbols 12809 if($Symbol!~/\A_Z(L|)\d/) 12810 { # mangled C functions and global data 12811 return "C++"; 12812 } 12813 } 12814 if(index($Symbol, "__gxx_")==0) { 12815 return "C++"; 12816 } 12817 12818 if(my $Lib = get_filename($Symbol_Library{$Symbol})) 12819 { 12820 if($Language{$Lib}) { 12821 return $Language{$Lib}; 12822 } 12823 } 12824 elsif(my $Lib = get_filename($DepSymbol_Library{$Symbol})) 12825 { 12826 if($Language{$Lib}) { 12827 return $Language{$Lib}; 12828 } 12829 } 12830 12831 return $COMMON_LANGUAGE; 12832} 12833 12834sub add_namespaces($) 12835{ 12836 my $CodeRef = $_[0]; 12837 my @UsedNameSpaces = (); 12838 foreach my $NameSpace (sort {get_depth($b,"::")<=>get_depth($a,"::")} keys(%NestedNameSpaces)) 12839 { 12840 next if($NameSpace eq "std"); 12841 my $NameSpace_InCode = $NameSpace."::"; 12842 if(${$CodeRef}=~s/(\W|\A)(\Q$NameSpace_InCode\E)(\w)/$1$3/g) { 12843 push(@UsedNameSpaces, $NameSpace); 12844 } 12845 my $NameSpace_InSubClass = getSubClassBaseName($NameSpace_InCode); 12846 if(${$CodeRef}=~s/(\W|\A)($NameSpace_InSubClass)(\w+_SubClass)/$1$3/g) { 12847 push(@UsedNameSpaces, $NameSpace); 12848 } 12849 } 12850 return @UsedNameSpaces; 12851} 12852 12853sub correct_spaces($) 12854{ 12855 my $Code = $_[0]; 12856 $Code=~s/\n\n\n\n/\n\n/g; 12857 $Code=~s/\n\n\n/\n\n/g; 12858 $Code=~s/\n \n /\n\n /g; 12859 $Code=~s/\n \n\n/\n/g; 12860 $Code=~s/\n\n\};/\n};/g; 12861 return $Code; 12862} 12863 12864sub orderHeaders($) 12865{ # ordering headers according to descriptor 12866 my @List = (); 12867 my %Replace = (); 12868 my $Num = 1; 12869 my %ElemNum = map {$_=>$Num++} @{$_[0]}; 12870 12871 foreach my $Elem (@{$_[0]}) 12872 { 12873 if(my $Preamble = $Include_Order{$Elem}) 12874 { 12875 if(not $ElemNum{$Preamble}) 12876 { 12877 push(@List, $Preamble); 12878 push(@List, $Elem); 12879 } 12880 elsif($ElemNum{$Preamble}>$ElemNum{$Elem}) 12881 { 12882 push(@List, $Preamble); 12883 $Replace{$Preamble} = $Elem; 12884 } 12885 else { 12886 push(@List, $Elem); 12887 } 12888 } 12889 elsif($Replace{$Elem}) { 12890 push(@List, $Replace{$Elem}); 12891 } 12892 else { 12893 push(@List, $Elem); 12894 } 12895 } 12896 return \@List; 12897} 12898 12899sub alignSpaces($) 12900{ 12901 my $Code = $_[0]; 12902 my $Code_Copy = $Code; 12903 my ($MinParagraph, $Paragraph); 12904 while($Code=~s/\A([ ]+)//) { 12905 $MinParagraph = length($1) if(not defined $MinParagraph or $MinParagraph>length($1)); 12906 } 12907 foreach (1 .. $MinParagraph) { 12908 $Paragraph .= " "; 12909 } 12910 $Code_Copy=~s/(\A|\n)$Paragraph/$1/g; 12911 return $Code_Copy; 12912} 12913 12914sub alignCode($$$) 12915{ 12916 my ($Code, $Code_Align, $Single) = @_; 12917 return "" if($Code eq "" or $Code_Align eq ""); 12918 my $Paragraph = get_paragraph($Code_Align, 0); 12919 $Code=~s/\n([^\n])/\n$Paragraph$1/g; 12920 if(not $Single) { 12921 $Code=~s/\A/$Paragraph/g; 12922 } 12923 return $Code; 12924} 12925 12926sub get_paragraph($$) 12927{ 12928 my ($Code, $MaxMin) = @_; 12929 my ($MinParagraph_Length, $MinParagraph); 12930 while($Code=~s/\A([ ]+)//) 12931 { 12932 if(not defined $MinParagraph_Length or 12933 (($MaxMin)?$MinParagraph_Length<length($1):$MinParagraph_Length>length($1))) { 12934 $MinParagraph_Length = length($1); 12935 } 12936 } 12937 foreach (1 .. $MinParagraph_Length) { 12938 $MinParagraph .= " "; 12939 } 12940 return $MinParagraph; 12941} 12942 12943sub writeFile($$) 12944{ 12945 my ($Path, $Content) = @_; 12946 return if(not $Path); 12947 if(my $Dir = get_dirname($Path)) { 12948 mkpath($Dir); 12949 } 12950 open (FILE, ">".$Path) || die ("can't open file \'$Path\': $!\n"); 12951 print FILE $Content; 12952 close(FILE); 12953} 12954 12955sub readFile($) 12956{ 12957 my $Path = $_[0]; 12958 return "" if(not $Path or not -f $Path); 12959 open (FILE, $Path); 12960 my $Content = join("", <FILE>); 12961 close(FILE); 12962 $Content=~s/\r//g; 12963 return $Content; 12964} 12965 12966sub get_RunScript($) 12967{ 12968 my $Interface = $_[0]; 12969 my @Paths = (); 12970 foreach my $Path (sort (keys(%UsedSharedObjects), keys(%LibsDepend), keys(%SpecLibs))) 12971 { 12972 if(my $Dir = get_dirname($Path)) 12973 { 12974 next if(grep {$Dir eq $_} @DefaultLibPaths); 12975 push_U(\@Paths, $Dir); 12976 } 12977 } 12978 if($OSgroup eq "windows") 12979 { 12980 if(@Paths) 12981 { 12982 my $EnvSet = "\@set PATH=".join(";", @Paths).";\%PATH\%"; 12983 return $EnvSet."\ntest.exe arg1 arg2 arg3 >output 2>&1\n"; 12984 } 12985 else { 12986 return "test.exe arg1 arg2 arg3 >output 2>&1\n"; 12987 } 12988 } 12989 elsif($OSgroup eq "macos") 12990 { 12991 if(@Paths) 12992 { 12993 my $EnvSet = "export DYLD_LIBRARY_PATH=\$DYLD_LIBRARY_PATH:\"".join(":", @Paths)."\""; 12994 return "#!/bin/sh\n$EnvSet && ./test arg1 arg2 arg3 >output 2>&1\n"; 12995 } 12996 else { 12997 return "#!/bin/sh\n./test arg1 arg2 arg3 >output 2>&1\n"; 12998 } 12999 } 13000 else 13001 { 13002 if(@Paths) 13003 { 13004 my $EnvSet = "export LD_LIBRARY_PATH=\$LD_LIBRARY_PATH:\"".join(":", @Paths)."\""; 13005 return "#!/bin/sh\n$EnvSet && ./test arg1 arg2 arg3 >output 2>&1\n"; 13006 } 13007 else { 13008 return "#!/bin/sh\n./test arg1 arg2 arg3 >output 2>&1\n"; 13009 } 13010 } 13011} 13012 13013sub short_soname($) 13014{ 13015 my $Name = $_[0]; 13016 $Name=~s/(?<=\.$LIB_EXT)\.[0-9.]+\Z//g; 13017 return $Name; 13018} 13019 13020sub checkHeader($) 13021{ 13022 if(defined $Cache{"checkHeader"}{$_[0]}) { 13023 return $Cache{"checkHeader"}{$_[0]} 13024 } 13025 foreach my $Path (@DefaultIncPaths) 13026 { 13027 if(-f $Path."/".$_[0]) { 13028 return ($Cache{"checkHeader"}{$_[0]} = join_P($Path, $_[0])); 13029 } 13030 } 13031 return ($Cache{"checkHeader"}{$_[0]} = ""); 13032} 13033 13034sub optimizeIncludes($$) 13035{ 13036 my %Paths = %{$_[0]}; 13037 my $Level = $_[1]; 13038 13039 if($Level=~/Low|Medium|High/i) 13040 { # optimization N1: included by others 13041 foreach my $Path1 (sort {$Paths{$b}<=>$Paths{$a}} keys(%Paths)) 13042 { 13043 if($Paths{$Path1}<0) 13044 { # preamble headers (%Include_Preamble) 13045 next; 13046 } 13047 13048 my $N = $Paths{$Path1}; 13049 foreach my $Path2 (sort {$Paths{$b}<=>$Paths{$a}} keys(%Paths)) 13050 { 13051 next if($Path1 eq $Path2); 13052 next if($Paths{$Path2}<=$N); # top-to-bottom 13053 if(grep {get_dirname($Path2) eq $_} @DefaultIncPaths) 13054 { # save 13055 next if(not defined $Include_RevOrder{get_filename($Path2)}); 13056 } 13057 13058 if(defined $RecursiveIncludes{$Path1}{$Path2}) 13059 { 13060 my $Name = get_filename($Path2); 13061 my $Dir = get_filename(get_dirname($Path2)); 13062 my $DirName = join_P($Dir, $Name); 13063 13064 if(defined $DirectIncludes{$Path1}{$Name} 13065 or defined $DirectIncludes{$Path1}{$DirName}) { 13066 delete($Paths{$Path2}); 13067 } 13068 } 13069 } 13070 } 13071 } 13072 13073 if($Level=~/Medium|High/i) 13074 { # optimization N2: non registered 13075 foreach my $Path (sort {$Paths{$b}<=>$Paths{$a}} keys(%Paths)) 13076 { 13077 if($Paths{$Path}<0) 13078 { # preamble headers (%Include_Preamble) 13079 next; 13080 } 13081 13082 if(not $RegisteredHeaders_R{$Path}) 13083 { 13084 my $Dir = get_dirname($Path); 13085 next if(grep {$Dir eq $_} @DefaultIncPaths); # save 13086 13087 my @Tops = sort keys(%{$RecursiveIncludes_R{$Path}}); 13088 @Tops = sort {keys(%{$DirectIncludes{$b}}) <=> keys(%{$DirectIncludes{$a}})} @Tops; 13089 foreach my $Top (@Tops) 13090 { 13091 if(defined $RegisteredHeaders_R{$Top}) 13092 { 13093 if(not defined $Paths{$Top}) { 13094 $Paths{$Top} = $Paths{$Path}; 13095 } 13096 delete($Paths{$Path}); 13097 last; 13098 } 13099 } 13100 } 13101 } 13102 } 13103 13104 if($Level=~/High/i) 13105 { # optimization N3: top headers 13106 foreach my $Path (sort {$Paths{$b}<=>$Paths{$a}} keys(%Paths)) 13107 { 13108 if($Paths{$Path}<0) 13109 { # preamble headers (%Include_Preamble) 13110 next; 13111 } 13112 13113 if($RegisteredHeaders_R{$Path}) 13114 { 13115 if(my @Tops = sort keys(%{$RegisteredIncludes_R{$Path}})) 13116 { 13117 my $Name = get_filename($Path); 13118 my $Short = $Name; 13119 $Short=~s/\.\w+\Z//; 13120 13121 @Tops = sort {keys(%{$DirectIncludes{$b}}) <=> keys(%{$DirectIncludes{$a}})} @Tops; 13122 @Tops = sort {$b=~/\Q$Short\E/i cmp $a=~/\Q$Short\E/i} @Tops; 13123 13124 foreach my $Top (@Tops) 13125 { 13126 if(get_filename($Top) ne $Name) 13127 { 13128 next if(keys(%{$DirectIncludes{$Top}})<=keys(%{$DirectIncludes{$Path}})); 13129 next if(keys(%{$DirectIncludes{$Path}})>$MAX_INC/3); 13130 } 13131 13132 next if(skipHeader($Top)); 13133 13134 # replace 13135 if(not defined $Paths{$Top}) { 13136 $Paths{$Top} = $Paths{$Path}; 13137 } 13138 delete($Paths{$Path}); 13139 last; 13140 } 13141 } 13142 } 13143 } 13144 } 13145 13146 %{$_[0]} = %Paths; 13147} 13148 13149sub identifyHeader($) 13150{ 13151 if(defined $Cache{"identifyHeader"}{$_[0]}) { 13152 return $Cache{"identifyHeader"}{$_[0]} 13153 } 13154 return ($Cache{"identifyHeader"}{$_[0]} = identifyHeader_I($_[0])); 13155} 13156 13157sub identifyHeader_I($) 13158{ 13159 my $Name = $_[0]; 13160 if(my $Path = $RegisteredHeaders{$Name}) { 13161 return $Path; 13162 } 13163 elsif(my $Path = $KnownHeaders{$Name}) { 13164 return $Path; 13165 } 13166 elsif(my $Path = checkHeader($Name)) { 13167 return $Path; 13168 } 13169 return $Name; 13170} 13171 13172sub prepareHeaders(@) 13173{ 13174 my @List = @_; 13175 my %Paths = (); 13176 my ($Num, $PNum) = (0, -$#List-2); 13177 13178 # determine header paths 13179 foreach my $Name (@_) 13180 { 13181 if(my $Path = identifyHeader($Name)) 13182 { 13183 if(my $Redirect = $Include_Redirect{$Path}) { 13184 $Path = $Redirect; 13185 } 13186 if(not defined $Paths{$Path}) 13187 { 13188 if(grep {$Name eq $_} @Include_Preamble) { 13189 $Paths{$Path} = $PNum++; 13190 } 13191 else { 13192 $Paths{$Path} = $Num++; 13193 } 13194 } 13195 } 13196 } 13197 13198 if(my $Level = lc($OptimizeIncludes)) 13199 { 13200 if($Level ne "none") { 13201 optimizeIncludes(\%Paths, $Level); 13202 } 13203 } 13204 else 13205 { # default 13206 optimizeIncludes(\%Paths, "High"); 13207 } 13208 13209 foreach my $Path (sort {$Paths{$a}<=>$Paths{$b}} keys(%Paths)) 13210 { 13211 if(my $Redirect = $Include_Redirect{$Path}) 13212 { 13213 if(not defined $Paths{$Redirect}) { 13214 $Paths{$Redirect} = $Paths{$Path}; 13215 } 13216 delete($Paths{$Path}); 13217 } 13218 } 13219 13220 my (@Headers, %IncPaths) = (); 13221 13222 # determine include paths 13223 foreach my $Path (sort {$Paths{$a}<=>$Paths{$b}} keys(%Paths)) 13224 { 13225 my $FName = get_filename($Path); 13226 my $Dir = get_dirname($Path); 13227 13228 my $Prefix = undef; 13229 13230 if(my @Prefixes = keys(%{$IncludePrefix{$FName}})) 13231 { 13232 @Prefixes = sort {length($a)<=>length($b)} sort @Prefixes; 13233 13234 foreach my $P (@Prefixes) 13235 { 13236 if($Dir=~s/[\/\\]+\Q$P\E\Z//g) 13237 { 13238 push(@Headers, join_P($P, $FName)); 13239 $Prefix = $P; 13240 last; 13241 } 13242 } 13243 } 13244 if(not $Prefix) 13245 { # default 13246 if($Prefix = getFilePrefix($Path)) 13247 { # NOTE: /usr/include/sys/... 13248 push(@Headers, join_P($Prefix, $FName)); 13249 $Dir=~s/[\/\\]+\Q$Prefix\E\Z//; 13250 } 13251 else { 13252 push(@Headers, $FName); 13253 } 13254 } 13255 13256 if($Dir) 13257 { 13258 if(not grep {$Dir eq $_} @DefaultIncPaths) { 13259 $IncPaths{$Dir} = $Num++; 13260 } 13261 } 13262 13263 # if(index($Dir, "/usr/include/c++/")!=0) { 13264 # $IncPaths{$Dir} = $Num; 13265 # } 13266 } 13267 13268 my @IncPaths = sort {$IncPaths{$b} <=> $IncPaths{$a}} keys(%IncPaths); 13269 return (\@Headers, \@IncPaths); 13270} 13271 13272sub get_Makefile($$) 13273{ 13274 my ($Interface, $IncPaths) = @_; 13275 13276 my (%LibPaths_All, %LibNames_All) = (); # Win 13277 13278 my (%LibPaths, %LibSuffixes) = (); 13279 my $LIBS = ""; 13280 foreach my $Path (sort (keys(%UsedSharedObjects), keys(%LibsDepend), keys(%SpecLibs))) 13281 { 13282 if($TestFormat eq "CL") 13283 { 13284 $Path=~s/\.dll\Z/.lib/; 13285 $LibPaths_All{"\"".get_dirname($Path)."\""} = 1; 13286 $LibNames_All{get_filename($Path)} = 1; 13287 } 13288 else 13289 { 13290 if(($Path=~/\.$LIB_EXT\Z/ or -f short_soname($Path)) 13291 and $Path=~/\A(.*)[\/\\]lib([^\/\\]+)\.$LIB_EXT[^\/\\]*\Z/) 13292 { 13293 $LibPaths{$1} = 1; 13294 $LibSuffixes{$2} = 1; 13295 } 13296 elsif($Path=~/\Alib([^\/\\]+)\.$LIB_EXT[^\/\\]*\Z/) { 13297 $LibSuffixes{$1} = 1; 13298 } 13299 else { 13300 $LIBS .= " ".$Path; 13301 } 13302 } 13303 } 13304 foreach my $Path (keys(%LibPaths)) 13305 { 13306 next if(not $Path); 13307 next if(grep {$Path eq $_} @DefaultLibPaths); 13308 $LIBS .= " -L".esc_option($Path, "GCC"); 13309 } 13310 foreach my $Suffix (keys(%LibSuffixes)) { 13311 $LIBS .= " -l".$Suffix; 13312 } 13313 13314 if($LibString) 13315 { # undefined symbols 13316 $LIBS .= " ".$LibString; 13317 } 13318 13319 if($CompilerOptions_Libs) { 13320 $LIBS .= $CompilerOptions_Libs; 13321 } 13322 13323 my $IncStr = ""; 13324 foreach my $Path (@{$IncPaths}) 13325 { 13326 my $IncOpt = inc_opt($Path, $TestFormat); 13327 if($IncludeString!~/\Q$IncOpt\E( |\Z)/) { 13328 $IncStr .= " ".$IncOpt; 13329 } 13330 } 13331 if($IncludeString) { 13332 $IncStr .= " ".$IncludeString; 13333 } 13334 13335 my $Source = "test.c"; 13336 my $Exe = "test"; 13337 my $Obj = "test.o"; 13338 my $Rm = "rm -f"; 13339 13340 if(getTestLang($Interface) eq "C++") 13341 { 13342 $Source = "test.cpp"; 13343 } 13344 13345 if($OSgroup eq "windows") 13346 { 13347 $Exe = "test.exe"; 13348 $Rm = "del"; 13349 } 13350 13351 if($TestFormat eq "CL") 13352 { 13353 $Obj = "test.obj"; 13354 } 13355 13356 if($TestFormat eq "CL") 13357 { # compiling using CL and NMake 13358 my $Makefile = "CC = cl"; 13359 if($IncStr) { 13360 $Makefile .= "\nINCLUDES = $IncStr"; 13361 } 13362 if(keys(%LibNames_All)) { 13363 $Makefile .= "\nLIBS = ".join(" ", keys(%LibNames_All)); 13364 } 13365 $Makefile .= "\n\nall: $Exe\n\n"; 13366 $Makefile .= "$Exe: $Source\n\t"; 13367 if(keys(%LibNames_All)) { 13368 $Makefile .= "set LIB=".join(";", keys(%LibPaths_All)).";\$(LIB)\n\t"; 13369 } 13370 $Makefile .= "\$(CC) "; 13371 if($IncStr) { 13372 $Makefile .= "\$(INCLUDES) "; 13373 } 13374 $Makefile .= $Source; 13375 if(keys(%LibNames_All)) { 13376 $Makefile .= " \$(LIBS)"; 13377 } 13378 $Makefile .= "\n\n"; 13379 $Makefile .= "clean:\n\t$Rm $Exe $Obj\n"; 13380 return $Makefile; 13381 } 13382 else 13383 { # compiling using GCC and Make 13384 if(getTestLang($Interface) eq "C++") 13385 { 13386 my $Makefile = "CXX = g++\n"; 13387 $Makefile .= "CXXFLAGS = -Wall".$CompilerOptions_Cflags; 13388 if($IncStr) { 13389 $Makefile .= "\nINCLUDES = $IncStr"; 13390 } 13391 if($LIBS) { 13392 $Makefile .= "\nLIBS = $LIBS"; 13393 } 13394 $Makefile .= "\n\nall: $Exe\n\n"; 13395 $Makefile .= "$Exe: $Source\n\t"; 13396 $Makefile .= "\$(CXX) \$(CXXFLAGS)"; 13397 if($IncStr) { 13398 $Makefile .= " \$(INCLUDES)"; 13399 } 13400 $Makefile .= " $Source -o $Exe"; 13401 if($LIBS) { 13402 $Makefile .= " \$(LIBS)"; 13403 } 13404 $Makefile .= "\n\n"; 13405 $Makefile .= "clean:\n\t$Rm $Exe $Obj\n"; 13406 return $Makefile; 13407 } 13408 else 13409 { 13410 my $Makefile = "CC = gcc\n"; 13411 $Makefile .= "CFLAGS = -Wall".$CompilerOptions_Cflags; 13412 if($IncStr) { 13413 $Makefile .= "\nINCLUDES = $IncStr"; 13414 } 13415 if($LIBS) { 13416 $Makefile .= "\nLIBS = $LIBS"; 13417 } 13418 $Makefile .= "\n\nall: $Exe\n\n"; 13419 $Makefile .= "$Exe: $Source\n\t"; 13420 $Makefile .= "\$(CC) \$(CFLAGS)"; 13421 if($IncStr) { 13422 $Makefile .= " \$(INCLUDES)"; 13423 } 13424 $Makefile .= " $Source -o $Exe"; 13425 if($LIBS) { 13426 $Makefile .= " \$(LIBS)"; 13427 } 13428 $Makefile .= "\n\n"; 13429 $Makefile .= "clean:\n\t$Rm $Exe $Obj\n"; 13430 return $Makefile; 13431 } 13432 } 13433} 13434 13435sub get_one_step_title($$$$$) 13436{ 13437 my ($Num, $All_Count, $Head, $Success, $Fail) = @_; 13438 my $Title = "$Head: $Num/$All_Count [".cut_off_number($Num*100/$All_Count, 3)."%],"; 13439 $Title .= " success/fail: $Success/$Fail"; 13440 return $Title." "; 13441} 13442 13443sub insertIDs($) 13444{ 13445 my $Text = $_[0]; 13446 13447 while($Text=~/CONTENT_ID/) 13448 { 13449 if(int($Content_Counter)%2) { 13450 $ContentID -= 1; 13451 } 13452 $Text=~s/CONTENT_ID/c_$ContentID/; 13453 $ContentID += 1; 13454 $Content_Counter += 1; 13455 } 13456 return $Text; 13457} 13458 13459sub cut_off_number($$) 13460{ 13461 my ($num, $digs_to_cut) = @_; 13462 if($num!~/\./) 13463 { 13464 $num .= "."; 13465 foreach (1 .. $digs_to_cut-1) { 13466 $num .= "0"; 13467 } 13468 } 13469 elsif($num=~/\.(.+)\Z/ and length($1)<$digs_to_cut-1) 13470 { 13471 foreach (1 .. $digs_to_cut - 1 - length($1)) { 13472 $num .= "0"; 13473 } 13474 } 13475 elsif($num=~/\d+\.(\d){$digs_to_cut,}/) { 13476 $num=sprintf("%.".($digs_to_cut-1)."f", $num); 13477 } 13478 return $num; 13479} 13480 13481sub selectSymbol($) 13482{ 13483 my $Symbol = $_[0]; 13484 13485 if(defined $CompleteSignature{$Symbol}) 13486 { 13487 if(my $Header = $CompleteSignature{$Symbol}{"Header"}) 13488 { 13489 if(my $Path = identifyHeader($Header)) 13490 { 13491 if(my $Skip = skipHeader($Path)) 13492 { 13493 if($Skip==1) 13494 { # skip_headers 13495 return 0; 13496 } 13497 } 13498 } 13499 if($RegisteredHeaders{$Header}) 13500 { 13501 if($Symbol_Library{$Symbol}) { 13502 return 1; 13503 } 13504 if($CompleteSignature{$Symbol}{"InLine"}) 13505 { 13506 if(not defined $NoInline) { 13507 return 1; 13508 } 13509 } 13510 } 13511 } 13512 } 13513 return 0; 13514} 13515 13516sub generateTests() 13517{ 13518 rmtree($TEST_SUITE_PATH) if(-e $TEST_SUITE_PATH); 13519 mkpath($TEST_SUITE_PATH); 13520 ($ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"}) = (0, 0); 13521 my %TargetInterfaces = (); 13522 if($TargetHeaderName) 13523 { # for the header file 13524 foreach my $Symbol (sort keys(%CompleteSignature)) 13525 { 13526 if(my $Header = $CompleteSignature{$Symbol}{"Header"}) 13527 { 13528 if(get_filename($Header) eq $TargetHeaderName) 13529 { 13530 if(selectSymbol($Symbol)) 13531 { 13532 if(symbolFilter($Symbol)) { 13533 $TargetInterfaces{$Symbol} = 1; 13534 } 13535 } 13536 } 13537 } 13538 } 13539 } 13540 elsif(keys(%InterfacesList)) 13541 { # for the list 13542 foreach my $Symbol (sort keys(%InterfacesList)) 13543 { 13544 if(symbolFilter($Symbol)) { 13545 $TargetInterfaces{$Symbol} = 1; 13546 } 13547 } 13548 } 13549 else 13550 { # all symbols (default) 13551 foreach my $Symbol (sort keys(%CompleteSignature)) 13552 { 13553 if(selectSymbol($Symbol)) 13554 { 13555 if(symbolFilter($Symbol)) { 13556 $TargetInterfaces{$Symbol} = 1; 13557 } 13558 } 13559 } 13560 if(not keys(%TargetInterfaces)) { 13561 exitStatus("Error", "cannot obtain enough information from header files to generate tests"); 13562 } 13563 } 13564 if(not keys(%TargetInterfaces)) { 13565 exitStatus("Error", "specified information is not enough to generate tests"); 13566 } 13567 unlink($TEST_SUITE_PATH."/scenario"); 13568 open(FAIL_LIST, ">$TEST_SUITE_PATH/gen_fail_list"); 13569 if(defined $Template2Code) 13570 { 13571 if(keys(%LibGroups)) 13572 { 13573 my %LibGroups_Filtered = (); 13574 my ($Test_Num, $All_Count) = (0, 0); 13575 foreach my $LibGroup (sort {lc($a) cmp lc($b)} keys(%LibGroups)) 13576 { 13577 foreach my $Interface (keys(%{$LibGroups{$LibGroup}})) 13578 { 13579 if($TargetInterfaces{$Interface}) 13580 { 13581 $LibGroups_Filtered{$LibGroup}{$Interface} = 1; 13582 $All_Count+=1; 13583 } 13584 } 13585 } 13586 foreach my $LibGroup (sort {lc($a) cmp lc($b)} keys(%LibGroups_Filtered)) 13587 { 13588 my @Ints = sort {lc($a) cmp lc($b)} keys(%{$LibGroups_Filtered{$LibGroup}}); 13589 t2c_group_generation($LibGroup, "", \@Ints, 0, \$Test_Num, $All_Count); 13590 } 13591 print "\r".get_one_step_title($All_Count, $All_Count, "generating tests", $ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"})."\n"; 13592 } 13593 else 13594 { 13595 my $TwoComponets = 0; 13596 my %Header_Class_Interface = (); 13597 my ($Test_Num, $All_Count) = (0, int(keys(%TargetInterfaces))); 13598 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%TargetInterfaces)) 13599 { 13600 my %Signature = %{$CompleteSignature{$Interface}}; 13601 $Header_Class_Interface{$Signature{"Header"}}{get_type_short_name(get_TypeName($Signature{"Class"}))}{$Interface}=1; 13602 if($Signature{"Class"}) { 13603 $TwoComponets=1; 13604 } 13605 } 13606 foreach my $Header (sort {lc($a) cmp lc($b)} keys(%Header_Class_Interface)) 13607 { 13608 foreach my $ClassName (sort {lc($a) cmp lc($b)} keys(%{$Header_Class_Interface{$Header}})) 13609 { 13610 my @Ints = sort {lc($a) cmp lc($b)} keys(%{$Header_Class_Interface{$Header}{$ClassName}}); 13611 t2c_group_generation($Header, $ClassName, \@Ints, $TwoComponets, \$Test_Num, $All_Count); 13612 } 13613 } 13614 print "\r".get_one_step_title($All_Count, $All_Count, "generating tests", $ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"})."\n"; 13615 } 13616 writeFile("$TEST_SUITE_PATH/$TargetLibraryName-t2c/$TargetLibraryName.cfg", "# Custom compiler options\nCOMPILER_FLAGS = -DCHECK_EXT_REQS `pkg-config --cflags $TargetLibraryName` -D_GNU_SOURCE\n\n# Custom linker options\nLINKER_FLAGS = `pkg-config --libs $TargetLibraryName`\n\n# Maximum time (in seconds) each test is allowed to run\nWAIT_TIME = $HANGED_EXECUTION_TIME\n\n# Copyright holder\nCOPYRIGHT_HOLDER = COMPANY\n"); 13617 } 13618 else 13619 { # standalone 13620 my $Test_Num = 0; 13621 if(keys(%LibGroups)) 13622 { 13623 foreach my $Interface (keys(%TargetInterfaces)) 13624 { 13625 if(not $Interface_LibGroup{$Interface}) { 13626 delete($TargetInterfaces{$Interface}); 13627 } 13628 } 13629 } 13630 my $All_Count = keys(%TargetInterfaces); 13631 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%TargetInterfaces)) 13632 { 13633 print "\r".get_one_step_title($Test_Num, $All_Count, "generating tests", $ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"}); 13634 # reset global state 13635 restore_state(()); 13636 @RecurInterface = (); 13637 @RecurTypeId = (); 13638 @RecurSpecType = (); 13639 %SubClass_Created = (); 13640 my %Result = generateTest($Interface); 13641 if(not $Result{"IsCorrect"}) 13642 { 13643 print FAIL_LIST $Interface."\n"; 13644 if($StrictGen) { 13645 exitStatus("Error", "can't generate test for $Interface"); 13646 } 13647 } 13648 $Test_Num += 1; 13649 } 13650 write_scenario(); 13651 print "\r".get_one_step_title($All_Count, $All_Count, "generating tests", $ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"})."\n"; 13652 restore_state(()); 13653 } 13654 close(FAIL_LIST); 13655 unlink($TEST_SUITE_PATH."/gen_fail_list") if(not readFile($TEST_SUITE_PATH."/gen_fail_list")); 13656} 13657 13658sub t2c_group_generation($$$$$$) 13659{ 13660 my ($C1, $C2, $Interfaces, $TwoComponets, $Test_NumRef, $All_Count) = @_; 13661 my ($SuitePath, $MediumPath, $TestName) = getLibGroupPath($C1, $C2, $TwoComponets); 13662 my $MaxLength = 0; 13663 my $LibGroupName = getLibGroupName($C1, $C2); 13664 my %TestComponents = (); 13665 # reset global state for section 13666 restore_state(()); 13667 foreach my $Interface (@{$Interfaces}) 13668 { 13669 print "\r".get_one_step_title(${$Test_NumRef}, $All_Count, "generating tests", $ResultCounter{"Gen"}{"Success"}, $ResultCounter{"Gen"}{"Fail"}); 13670 restore_local_state(()); 13671 %IntrinsicNum=( 13672 "Char"=>64, 13673 "Int"=>0, 13674 "Str"=>0, 13675 "Float"=>0); 13676 @RecurInterface = (); 13677 @RecurTypeId = (); 13678 @RecurSpecType = (); 13679 %SubClass_Created = (); 13680 my $Global_State = save_state(); 13681 my %Result = generateTest($Interface); 13682 if(not $Result{"IsCorrect"}) 13683 { 13684 restore_state($Global_State); 13685 print FAIL_LIST $Interface."\n"; 13686 } 13687 ${$Test_NumRef} += 1; 13688 $TestComponents{"Headers"} = addHeaders($TestComponents{"Headers"}, $Result{"Headers"}); 13689 $TestComponents{"Code"} .= $Result{"Code"}; 13690 my ($DefinesList, $ValuesList) = list_t2c_defines(); 13691 $TestComponents{"Blocks"} .= "##=========================================================================\n## ".get_Signature($Interface)."\n\n<BLOCK>\n\n<TARGETS>\n ".$CompleteSignature{$Interface}{"ShortName"}."\n</TARGETS>\n\n".(($DefinesList)?"<DEFINE>\n".$DefinesList."</DEFINE>\n\n":"")."<CODE>\n".$Result{"main"}."</CODE>\n\n".(($ValuesList)?"<VALUES>\n".$ValuesList."</VALUES>\n\n":"")."</BLOCK>\n\n\n"; 13692 $MaxLength = length($CompleteSignature{$Interface}{"ShortName"}) if($MaxLength<length($CompleteSignature{$Interface}{"ShortName"})); 13693 } 13694 # adding test data 13695 my $TestDataDir = $SuitePath."/testdata/".(($MediumPath)?"$MediumPath/":"")."$TestName/"; 13696 mkpath($TestDataDir); 13697 $TestComponents{"Blocks"} = add_VirtualTestData($TestComponents{"Blocks"}, $TestDataDir); 13698 $TestComponents{"Blocks"} = add_TestData($TestComponents{"Blocks"}, $TestDataDir); 13699 my $Content = "#library $TargetLibraryName\n#libsection $LibGroupName\n\n<GLOBAL>\n\n// Tested here:\n"; 13700 foreach my $Interface (@{$Interfaces}) 13701 { # development progress 13702 $Content .= "// ".$CompleteSignature{$Interface}{"ShortName"}; 13703 foreach (0 .. $MaxLength - length($CompleteSignature{$Interface}{"ShortName"}) + 2) { 13704 $Content .= " "; 13705 } 13706 $Content .= "DONE (shallow)\n"; 13707 } 13708 $Content .= "\n"; 13709 foreach my $Header (@{$TestComponents{"Headers"}}) 13710 { # includes 13711 $Content .= "#include <$Header>\n"; 13712 } 13713 $Content .= "\n".$TestComponents{"Code"}."\n" if($TestComponents{"Code"}); 13714 $Content .= "\n</GLOBAL>\n\n".$TestComponents{"Blocks"}; 13715 writeFile($SuitePath."/src/".(($MediumPath)?"$MediumPath/":"")."$TestName.t2c", $Content); 13716 writeFile($SuitePath."/reqs/".(($MediumPath)?"$MediumPath/":"")."$TestName.xml", get_requirements_catalog($Interfaces)); 13717} 13718 13719sub get_requirements_catalog($) 13720{ 13721 my @Interfaces = @{$_[0]}; 13722 my $Reqs = ""; 13723 foreach my $Interface (@Interfaces) 13724 { 13725 foreach my $ReqId (sort {int($a)<=>int($b)} keys(%{$RequirementsCatalog{$Interface}})) 13726 { 13727 my $Req = $RequirementsCatalog{$Interface}{$ReqId}; 13728 $Req=~s/&/&/g; 13729 $Req=~s/>/>/g; 13730 $Req=~s/</</g; 13731 $Reqs .= "<req id=\"".$CompleteSignature{$Interface}{"ShortName"}.".".normalize_num($ReqId)."\">\n $Req\n</req>\n"; 13732 } 13733 } 13734 if(not $Reqs) { 13735 $Reqs = "<req id=\"function.01\">\n If ... then ...\n</req>\n"; 13736 } 13737 return "<?xml version=\"1.0\"?>\n<requirements>\n".$Reqs."</requirements>\n"; 13738} 13739 13740sub list_t2c_defines() 13741{ 13742 my (%Defines, $DefinesList, $ValuesList) = (); 13743 my $MaxLength = 0; 13744 foreach my $Define (sort keys(%Template2Code_Defines)) 13745 { 13746 if($Define=~/\A(\d+):(.+)\Z/) 13747 { 13748 $Defines{$1}{"Name"} = $2; 13749 $Defines{$1}{"Value"} = $Template2Code_Defines{$Define}; 13750 $MaxLength = length($2) if($MaxLength<length($2)); 13751 } 13752 } 13753 foreach my $Pos (sort {int($a) <=> int($b)} keys(%Defines)) 13754 { 13755 $DefinesList .= "#define ".$Defines{$Pos}{"Name"}; 13756 foreach (0 .. $MaxLength - length($Defines{$Pos}{"Name"}) + 2) { 13757 $DefinesList .= " "; 13758 } 13759 $DefinesList .= "<%$Pos%>\n"; 13760 $ValuesList .= " ".$Defines{$Pos}{"Value"}."\n"; 13761 } 13762 return ($DefinesList, $ValuesList); 13763} 13764 13765sub buildTests() 13766{ 13767 if(-e $TEST_SUITE_PATH."/build_fail_list") { 13768 unlink($TEST_SUITE_PATH."/build_fail_list"); 13769 } 13770 ($ResultCounter{"Build"}{"Success"}, $ResultCounter{"Build"}{"Fail"}) = (0, 0); 13771 readScenario(); 13772 return if(not keys(%Interface_TestDir)); 13773 my $All_Count = keys(%Interface_TestDir); 13774 my $Test_Num = 0; 13775 open(FAIL_LIST, ">$TEST_SUITE_PATH/build_fail_list"); 13776 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%Interface_TestDir)) 13777 { # building tests 13778 print "\r".get_one_step_title($Test_Num, $All_Count, "building tests", $ResultCounter{"Build"}{"Success"}, $ResultCounter{"Build"}{"Fail"}); 13779 buildTest($Interface); 13780 if(not $BuildResult{$Interface}{"IsCorrect"}) 13781 { 13782 print FAIL_LIST $Interface_TestDir{$Interface}."\n"; 13783 if($StrictBuild) { 13784 exitStatus("Error", "can't build test for $Interface"); 13785 } 13786 } 13787 $Test_Num += 1; 13788 } 13789 close(FAIL_LIST); 13790 unlink($TEST_SUITE_PATH."/build_fail_list") if(not readFile($TEST_SUITE_PATH."/build_fail_list")); 13791 print "\r".get_one_step_title($All_Count, $All_Count, "building tests", $ResultCounter{"Build"}{"Success"}, $ResultCounter{"Build"}{"Fail"})."\n"; 13792} 13793 13794sub cleanTests() 13795{ 13796 readScenario(); 13797 return if(not keys(%Interface_TestDir)); 13798 my $All_Count = keys(%Interface_TestDir); 13799 my $Test_Num = 0; 13800 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%Interface_TestDir)) 13801 { # cleaning tests 13802 print "\r".get_one_step_title($Test_Num, $All_Count, "cleaning tests", $Test_Num, 0); 13803 cleanTest($Interface); 13804 $Test_Num += 1; 13805 } 13806 print "\r".get_one_step_title($All_Count, $All_Count, "cleaning tests", $All_Count, 0)."\n"; 13807} 13808 13809sub run_tests() 13810{ 13811 if(-f $TEST_SUITE_PATH."/run_fail_list") { 13812 unlink($TEST_SUITE_PATH."/run_fail_list"); 13813 } 13814 ($ResultCounter{"Run"}{"Success"}, $ResultCounter{"Run"}{"Fail"}) = (0, 0); 13815 readScenario(); 13816 if(not keys(%Interface_TestDir)) { 13817 exitStatus("Error", "tests were not generated yet"); 13818 } 13819 my %ForRunning = (); 13820 foreach my $Interface (keys(%Interface_TestDir)) 13821 { 13822 if(-f $Interface_TestDir{$Interface}."/test" 13823 or -f $Interface_TestDir{$Interface}."/test.exe") { 13824 $ForRunning{$Interface} = 1; 13825 } 13826 } 13827 my $All_Count = keys(%ForRunning); 13828 if($All_Count==0) { 13829 exitStatus("Error", "tests were not built yet"); 13830 } 13831 my $Test_Num = 0; 13832 open(FAIL_LIST, ">$TEST_SUITE_PATH/run_fail_list"); 13833 my $XvfbStarted = 0; 13834 $XvfbStarted = runXvfb() if($UseXvfb); 13835 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%ForRunning)) 13836 { # running tests 13837 print "\r".get_one_step_title($Test_Num, $All_Count, "running tests", $ResultCounter{"Run"}{"Success"}, $ResultCounter{"Run"}{"Fail"}); 13838 run_sanity_test($Interface); 13839 if(not $RunResult{$Interface}{"IsCorrect"}) 13840 { 13841 print FAIL_LIST $Interface_TestDir{$Interface}."\n"; 13842 if($StrictRun) { 13843 exitStatus("Error", "test run failed for $Interface"); 13844 } 13845 } 13846 $Test_Num += 1; 13847 } 13848 stopXvfb($XvfbStarted) if($UseXvfb); 13849 close(FAIL_LIST); 13850 unlink($TEST_SUITE_PATH."/run_fail_list") if(not readFile($TEST_SUITE_PATH."/run_fail_list")); 13851 print "\r".get_one_step_title($All_Count, $All_Count, "running tests", $ResultCounter{"Run"}{"Success"}, $ResultCounter{"Run"}{"Fail"})."\n"; 13852 return 0; 13853} 13854 13855sub initSignals() 13856{ 13857 return if(not defined $Config{"sig_name"} 13858 or not defined $Config{"sig_num"}); 13859 my $No = 0; 13860 my @Numbers = split(/\s/, $Config{"sig_num"} ); 13861 foreach my $Name (split(/\s/, $Config{"sig_name"})) 13862 { 13863 if(not $SigName{$Numbers[$No]} 13864 or $Name=~/\A(SEGV|ABRT)\Z/) 13865 { 13866 $SigNo{$Name} = $Numbers[$No]; 13867 $SigName{$Numbers[$No]} = $Name; 13868 } 13869 $No+=1; 13870 } 13871} 13872 13873sub genDescriptorTemplate() 13874{ 13875 writeFile("VERSION.xml", $Descriptor_Template."\n"); 13876 printMsg("INFO", "XML-descriptor template ./VERSION.xml has been generated"); 13877} 13878 13879sub genSpecTypeTemplate() 13880{ 13881 writeFile("SPECTYPES.xml", $SpecType_Template."\n"); 13882 printMsg("INFO", "specialized type template ./SPECTYPES.xml has been generated"); 13883} 13884 13885sub esc($) 13886{ 13887 my $Str = $_[0]; 13888 $Str=~s/([()\[\]{}$ &'"`;,<>\+])/\\$1/g; 13889 return $Str; 13890} 13891 13892sub remove_option($$) 13893{ 13894 my ($OptionsRef, $Option) = @_; 13895 return if(not $OptionsRef or not $Option); 13896 $Option = esc($Option); 13897 my @Result = (); 13898 foreach my $Arg (@{$OptionsRef}) 13899 { 13900 if($Arg!~/\A[-]+$Option\Z/) { 13901 push(@Result, $Arg); 13902 } 13903 } 13904 @{$OptionsRef} = @Result; 13905} 13906 13907sub get_RetValName($) 13908{ 13909 my $Interface = $_[0]; 13910 return "" if(not $Interface); 13911 if($Interface=~/\A(.+?)(_|)(init|initialize|initializer|install)\Z/) { 13912 return $1; 13913 } 13914 else { 13915 return getParamNameByTypeName($CompleteSignature{$Interface}{"Return"}); 13916 } 13917} 13918 13919sub add_LibraryPreambleAndFinalization() 13920{ 13921 if(not keys(%LibraryInitFunc) 13922 or keys(%LibraryInitFunc)>1) { 13923 return; 13924 } 13925 my $AddedPreamble = 0; 13926 my $Pos = 0; 13927 foreach my $Interface (sort {$Library_Prefixes{getPrefix($b)} <=> $Library_Prefixes{getPrefix($a)}} 13928 sort {$b=~/init/i <=> $a=~/init/i} sort {lc($a) cmp lc($b)} keys(%LibraryInitFunc)) 13929 { 13930 next if(not symbolFilter($Interface)); 13931 my $Prefix = getPrefix($Interface); 13932 next if($Library_Prefixes{$Prefix}<$LIBRARY_PREFIX_MAJORITY); 13933 next if($Interface=~/plugin/i); 13934 my $ReturnId = $CompleteSignature{$Interface}{"Return"}; 13935 my $ReturnFId = get_FoundationTypeId($ReturnId); 13936 my $ReturnFTypeType = get_TypeType($ReturnFId); 13937 my $RPLevel = get_PointerLevel($ReturnId); 13938 my $RetValName = get_RetValName($Interface); 13939 if(defined $CompleteSignature{$Interface}{"Param"}{0}) 13940 { # should not have a complex parameter type 13941 my $PTypeId = $CompleteSignature{$Interface}{"Param"}{0}{"type"}; 13942 next if(get_TypeType(get_FoundationTypeId($PTypeId))!~/\A(Enum|Intrinsic)\Z/ and get_PointerLevel($PTypeId)!=0); 13943 } 13944 if(get_TypeName($ReturnId) eq "void" 13945 or ($ReturnFTypeType=~/\A(Enum|Intrinsic)\Z/ and $RPLevel==0) 13946 or ($ReturnFTypeType eq "Struct" and $RPLevel>=1)) 13947 { # should return a simple type or structure pointer 13948 readSpecTypes(" 13949 <spec_type> 13950 <name> 13951 automatic preamble 13952 </name> 13953 <kind> 13954 common_env 13955 </kind> 13956 <global_code> 13957 #include <".$CompleteSignature{$Interface}{"Header"}."> 13958 </global_code> 13959 <init_code> 13960 \$[$Interface".($ReturnFTypeType eq "Struct" and $RetValName?":$RetValName":"")."]; 13961 </init_code> 13962 <libs> 13963 ".get_filename($Symbol_Library{$Interface})." 13964 </libs> 13965 <associating> 13966 <except> 13967 $Interface 13968 </except> 13969 </associating> 13970 </spec_type>"); 13971 $AddedPreamble = 1; 13972 $LibraryInitFunc{$Interface} = $Pos++; 13973 } 13974 } 13975 if(not $AddedPreamble 13976 or keys(%LibraryExitFunc)>1) { 13977 return; 13978 } 13979 foreach my $Interface (sort {lc($a) cmp lc($b)} keys(%LibraryExitFunc)) 13980 { 13981 next if(not symbolFilter($Interface)); 13982 my $Prefix = getPrefix($Interface); 13983 next if($Library_Prefixes{$Prefix}<$LIBRARY_PREFIX_MAJORITY); 13984 next if($Interface=~/plugin/i); 13985 my $ReturnId = $CompleteSignature{$Interface}{"Return"}; 13986 my $PTypeId = (defined $CompleteSignature{$Interface}{"Param"}{0})?$CompleteSignature{$Interface}{"Param"}{0}{"type"}:0; 13987 my $Interface_Pair = 0; 13988 foreach my $Interface_Init (keys(%LibraryInitFunc)) 13989 { # search for a pair interface 13990 my $Prefix_Init = getPrefix($Interface_Init); 13991 my $ReturnId_Init = $CompleteSignature{$Interface_Init}{"Return"}; 13992 my $PTypeId_Init = (defined $CompleteSignature{$Interface_Init}{"Param"}{0})?$CompleteSignature{$Interface_Init}{"Param"}{0}{"type"}:0; 13993 if($Prefix eq $Prefix_Init 13994 and ($PTypeId==0 or $PTypeId_Init==$ReturnId or $PTypeId==$ReturnId_Init or $PTypeId==$PTypeId_Init)) 13995 { # libraw_init ( unsigned int flags ):libraw_data_t* 13996 # libraw_close ( libraw_data_t* p1 ):void 13997 $Interface_Pair = $Interface_Init; 13998 last; 13999 } 14000 } 14001 next if(not $Interface_Pair); 14002 if(get_TypeName($ReturnId) eq "void" 14003 or (get_TypeType(get_FoundationTypeId($ReturnId))=~/\A(Enum|Intrinsic)\Z/ and get_PointerLevel($ReturnId)==0)) 14004 { 14005 readSpecTypes(" 14006 <spec_type> 14007 <name> 14008 automatic finalization 14009 </name> 14010 <kind> 14011 common_env 14012 </kind> 14013 <global_code> 14014 #include <".$CompleteSignature{$Interface}{"Header"}."> 14015 </global_code> 14016 <final_code> 14017 \$[$Interface]; 14018 </final_code> 14019 <libs> 14020 ".get_filename($Symbol_Library{$Interface})." 14021 </libs> 14022 <associating> 14023 <except> 14024 $Interface 14025 </except> 14026 </associating> 14027 </spec_type>"); 14028 } 14029 } 14030} 14031 14032sub initLogging() 14033{ 14034 $DEBUG_PATH = "debug/$TargetLibraryName/".$Descriptor{"Version"}; 14035 14036 if($Debug) 14037 { # reset 14038 if(not ($UseCache and -d $CACHE_PATH)) 14039 { 14040 rmtree($DEBUG_PATH); 14041 mkpath($DEBUG_PATH); 14042 } 14043 } 14044 14045} 14046 14047sub writeDebugLog() 14048{ 14049 my $DEBUG_LOG = ""; 14050 if(my @Interfaces = keys(%{$DebugInfo{"Init_InterfaceParams"}})) 14051 { 14052 $DEBUG_LOG .= "Failed to initialize parameters of these symbols:\n"; 14053 foreach my $Interface (@Interfaces) { 14054 $DEBUG_LOG .= " ".get_Signature($Interface)."\n"; 14055 } 14056 delete($DebugInfo{"Init_InterfaceParams"}); 14057 } 14058 if(my @Types = keys(%{$DebugInfo{"Init_Class"}})) 14059 { 14060 $DEBUG_LOG .= "Failed to create instances for these classes:\n"; 14061 foreach my $Type (@Types) { 14062 $DEBUG_LOG .= " $Type\n"; 14063 } 14064 delete($DebugInfo{"Init_Class"}); 14065 } 14066 if($DEBUG_LOG) { 14067 writeFile($DEBUG_PATH."/log.txt", $DEBUG_LOG."\n"); 14068 } 14069} 14070 14071sub printMsg($$) 14072{ 14073 my ($Type, $Msg) = @_; 14074 if($Type!~/\AINFO/) { 14075 $Msg = $Type.": ".$Msg; 14076 } 14077 if($Type!~/_C\Z/) { 14078 $Msg .= "\n"; 14079 } 14080 if($Type eq "ERROR") { 14081 print STDERR $Msg; 14082 } 14083 else { 14084 print $Msg; 14085 } 14086} 14087 14088sub exitStatus($$) 14089{ 14090 my ($Code, $Msg) = @_; 14091 printMsg("ERROR", $Msg); 14092 exit($ERROR_CODE{$Code}); 14093} 14094 14095sub listDir($) 14096{ 14097 my $Path = $_[0]; 14098 return () if(not $Path or not -d $Path); 14099 opendir(my $DH, $Path); 14100 return () if(not $DH); 14101 my @Contents = grep { $_ ne "." and $_ ne ".." } readdir($DH); 14102 return @Contents; 14103} 14104 14105sub read_ABI($) 14106{ 14107 my $Path = $_[0]; 14108 14109 # check ACC 14110 if(my $Version = `$ABICC -dumpversion`) 14111 { 14112 if(cmpVersions($Version, $ABICC_VERSION)<0) { 14113 exitStatus("Module_Error", "the version of ABI Compliance Checker should be $ABICC_VERSION or newer"); 14114 } 14115 } 14116 else { 14117 exitStatus("Module_Error", "cannot find \'$ABICC\'"); 14118 } 14119 14120 my $Extra_Dir = $TMP_DIR."/extra-info"; 14121 my $ABI_Dir = $TMP_DIR; 14122 if($Debug) 14123 { 14124 $Extra_Dir = $DEBUG_PATH."/extra-info"; 14125 $ABI_Dir = $DEBUG_PATH; 14126 } 14127 14128 if($UseCache and -f $CACHE_PATH."/ABI.dump") 14129 { # use cache 14130 printMsg("INFO", "Using cached ABI dump"); 14131 $Extra_Dir = $CACHE_PATH."/extra-info"; 14132 $ABI_Dir = $CACHE_PATH; 14133 } 14134 else 14135 { 14136 mkpath($Extra_Dir); 14137 14138 # clear cache 14139 rmtree($CACHE_PATH); 14140 14141 my $Cmd = $ABICC." -l $TargetLibraryName -dump \"$Path\" -dump-path \"".$ABI_Dir."/ABI.dump\""; 14142 $Cmd .= " -extra-info \"$Extra_Dir\""; # include paths and dependent libs 14143 $Cmd .= " -extra-dump"; # dump all symbols 14144 if($TargetVersion) { 14145 $Cmd .= " -vnum \"$TargetVersion\""; 14146 } 14147 if($RelativeDirectory) { 14148 $Cmd .= " -relpath \"$RelativeDirectory\""; 14149 } 14150 if($CheckHeadersOnly) { 14151 $Cmd .= " -headers-only"; 14152 } 14153 if($Debug) 14154 { 14155 $Cmd .= " -debug"; 14156 printMsg("INFO", "running $Cmd"); 14157 } 14158 system($Cmd); 14159 14160 if(not -f $ABI_Dir."/ABI.dump") { 14161 exit(1); 14162 } 14163 if($UseCache) 14164 { # cache ABI dump 14165 printMsg("INFO", "cache ABI dump"); 14166 mkpath($CACHE_PATH."/extra-info"); 14167 foreach (listDir($Extra_Dir)) { 14168 copy($Extra_Dir."/".$_, $CACHE_PATH."/extra-info"); 14169 } 14170 copy($ABI_Dir."/ABI.dump", $CACHE_PATH); 14171 } 14172 } 14173 14174 # read ABI dump 14175 my $ABI_Dump = readFile($ABI_Dir."/ABI.dump"); 14176 14177 # extra info 14178 if(my $Str = readFile($Extra_Dir."/include-string")) 14179 { 14180 if($TestFormat eq "GCC") { 14181 $IncludeString = $Str; 14182 } 14183 else 14184 { 14185 $Str=~s/\\//g; # unescape 14186 14187 foreach (split(/\s*\-I/, $Str)) 14188 { 14189 if($_) { 14190 $IncludeString .= " ".inc_opt($_, $TestFormat); 14191 } 14192 } 14193 14194 } 14195 } 14196 14197 $LibString = readFile($Extra_Dir."/libs-string"); 14198 14199 if(my $RInc = eval(readFile($Extra_Dir."/recursive-includes"))) 14200 { 14201 %RecursiveIncludes = %{$RInc}; 14202 foreach my $K1 (sort {length($a)<=>length($b)} keys(%RecursiveIncludes)) 14203 { 14204 registerHeader($K1, \%KnownHeaders); 14205 foreach my $K2 (sort {length($a)<=>length($b)} keys(%{$RecursiveIncludes{$K1}})) 14206 { 14207 registerHeader($K2, \%KnownHeaders); 14208 $RecursiveIncludes_R{$K2}{$K1} = 1; 14209 14210 if($RegisteredHeaders_R{$K1} 14211 and $RegisteredHeaders_R{$K2}) 14212 { 14213 $RegisteredIncludes{$K1}{$K2} = 1; 14214 $RegisteredIncludes_R{$K2}{$K1} = 1; 14215 } 14216 } 14217 } 14218 } 14219 14220 if(my @Paths = split(/\n/, readFile($Extra_Dir."/header-paths"))) 14221 { 14222 foreach my $P (sort {length($a)<=>length($b)} @Paths) { 14223 registerHeader($P, \%KnownHeaders); 14224 } 14225 } 14226 14227 if(my @Paths = split(/\n/, readFile($Extra_Dir."/lib-paths"))) 14228 { 14229 foreach my $P (@Paths) { 14230 $KnownLibs{get_filename($P)} = $P; 14231 } 14232 } 14233 14234 if(my @Paths = split(/\n/, readFile($Extra_Dir."/default-includes"))) 14235 { # default include paths 14236 @DefaultIncPaths = @Paths; 14237 } 14238 14239 if(my @Paths = split(/\n/, readFile($Extra_Dir."/default-libs"))) 14240 { # default lib paths 14241 @DefaultLibPaths = @Paths; 14242 } 14243 14244 if(my @Lines = split(/\n/, readFile($Extra_Dir."/include-redirect"))) 14245 { 14246 foreach (@Lines) 14247 { 14248 if(my ($P1, $P2) = split(";", $_)) 14249 { # separated by ";" 14250 $Include_Redirect{$P1} = $P2; 14251 } 14252 } 14253 } 14254 14255 if(my $DInc = eval(readFile($Extra_Dir."/direct-includes"))) { 14256 %DirectIncludes = %{$DInc}; 14257 } 14258 14259 if(not $Debug and not $UseCache) 14260 { 14261 rmtree($Extra_Dir); 14262 unlink($ABI_Dir."/ABI.dump"); 14263 } 14264 14265 if(not $ABI_Dump) { 14266 exitStatus("Error", "internal error - ABI dump cannot be created"); 14267 } 14268 14269 my $ABI = eval($ABI_Dump); 14270 14271 if(not $ABI) { 14272 exitStatus("Error", "internal error - eval() procedure seem to not working correctly, try to remove 'use strict' and try again"); 14273 } 14274 14275 %TypeInfo = %{$ABI->{"TypeInfo"}}; 14276 %SymbolInfo = %{$ABI->{"SymbolInfo"}}; 14277 %DepLibrary_Symbol = %{$ABI->{"DepSymbols"}}; 14278 %Library_Symbol = %{$ABI->{"Symbols"}}; 14279 %UndefinedSymbols = %{$ABI->{"UndefinedSymbols"}}; 14280 %Library_Needed = %{$ABI->{"Needed"}}; 14281 14282 %Constants = %{$ABI->{"Constants"}}; 14283 %NestedNameSpaces = %{$ABI->{"NameSpaces"}}; 14284 14285 $COMMON_LANGUAGE = $ABI->{"Language"}; 14286 14287 $ABI = undef; # clear memory 14288 14289 if(defined $UserLang) { 14290 $COMMON_LANGUAGE = uc($UserLang); 14291 } 14292 14293 foreach my $P (keys(%DirectIncludes)) 14294 { 14295 if(defined $RegisteredHeaders_R{$P}) 14296 { 14297 if($MAX_INC<keys(%{$DirectIncludes{$P}})) { 14298 $MAX_INC = keys(%{$DirectIncludes{$P}}); 14299 } 14300 } 14301 14302 foreach my $Inc (keys(%{$DirectIncludes{$P}})) 14303 { 14304 if(defined $Constants{$Inc}) 14305 { # FT_FREETYPE_H, etc. 14306 $Inc = $Constants{$Inc}{"Value"}; 14307 if($Inc=~s/\A([<"])//g 14308 and $Inc=~s/([>"])\Z//g) 14309 { 14310 $DirectIncludes{$P}{$Inc} = 1; 14311 my $Kind = $1 eq ">"?1:-1; 14312 if(my $IncP = $KnownHeaders{get_filename($Inc)}) 14313 { 14314 if(defined $RecursiveIncludes{$P} 14315 and not defined $RecursiveIncludes{$P}{$IncP}) 14316 { # add to known headers to recursive includes 14317 $RecursiveIncludes{$P}{$IncP} = $Kind; 14318 foreach (keys(%{$RecursiveIncludes_R{$P}})) { 14319 $RecursiveIncludes{$_}{$IncP} = $Kind; 14320 } 14321 } 14322 } 14323 } 14324 } 14325 14326 if(my $Dir = get_dirname($Inc)) 14327 { 14328 my $Name = get_filename($Inc); 14329 if($Name ne get_filename($P)) 14330 { # NOTE: stdlib.h includes bits/stdlib.h 14331 $IncludePrefix{$Name}{$Dir} = 1; 14332 } 14333 } 14334 } 14335 } 14336 14337 # recreate environment 14338 foreach my $Lib_Name (keys(%Library_Symbol)) 14339 { 14340 foreach my $Symbol (keys(%{$Library_Symbol{$Lib_Name}})) 14341 { 14342 if(my $P = identifyLibrary($Lib_Name)) 14343 { 14344 $Symbol_Library{$Symbol} = $P; 14345 14346 if(index($Symbol, "?")!=0) 14347 { # remove version 14348 $Symbol=~s/[\@\$]+.+?\Z//g; 14349 $Symbol_Library{$Symbol} = $P; 14350 } 14351 14352 if(not defined $Language{$Lib_Name}) 14353 { 14354 if(index($Symbol, "_ZN")==0 14355 or index($Symbol, "?")==0) { 14356 $Language{$Lib_Name} = "C++" 14357 } 14358 } 14359 } 14360 } 14361 } 14362 foreach my $Lib_Name (keys(%DepLibrary_Symbol)) 14363 { 14364 foreach my $Symbol (keys(%{$DepLibrary_Symbol{$Lib_Name}})) 14365 { 14366 if(my $P = identifyLibrary($Lib_Name)) 14367 { 14368 $DepSymbol_Library{$Symbol} = $P; 14369 14370 if(index($Symbol, "?")!=0) 14371 { # remove version 14372 $Symbol=~s/[\@\$]+.+?\Z//g; 14373 $DepSymbol_Library{$Symbol} = $P; 14374 } 14375 14376 if(not defined $Language{$Lib_Name}) 14377 { 14378 if(index($Symbol, "_ZN")==0 14379 or index($Symbol, "?")==0) { 14380 $Language{$Lib_Name} = "C++" 14381 } 14382 } 14383 } 14384 } 14385 } 14386 foreach my $NS (keys(%NestedNameSpaces)) 14387 { 14388 foreach (split("::", $NS)) { 14389 $NameSpaces{$NS} = 1; 14390 } 14391 } 14392 14393 my %Ctors = (); 14394 my @IDs = sort {int($a)<=>int($b)} keys(%SymbolInfo); 14395 14396 foreach my $InfoId (@IDs) 14397 { 14398 if(my $Mangled = $SymbolInfo{$InfoId}{"MnglName"}) 14399 { # unmangling 14400 $tr_name{$Mangled} = $SymbolInfo{$InfoId}{"Unmangled"}; 14401 } 14402 else 14403 { # ABI dumps have no mangled names for C-functions 14404 $SymbolInfo{$InfoId}{"MnglName"} = $SymbolInfo{$InfoId}{"ShortName"}; 14405 } 14406 if(my $ClassId = $SymbolInfo{$InfoId}{"Class"}) { 14407 $Library_Class{$ClassId} = 1; 14408 } 14409 if(defined $SymbolInfo{$InfoId}{"Param"}) 14410 { 14411 foreach my $Pos (keys(%{$SymbolInfo{$InfoId}{"Param"}})) 14412 { 14413 my $TypeId = $SymbolInfo{$InfoId}{"Param"}{$Pos}{"type"}; 14414 if($TypeInfo{$TypeId}{"Type"} eq "Restrict") { 14415 $SymbolInfo{$InfoId}{"Param"}{$Pos}{"type"} = $TypeInfo{$TypeId}{"BaseType"}; 14416 } 14417 } 14418 } 14419 if(defined $SymbolInfo{$InfoId}{"Constructor"}) { 14420 $Ctors{$SymbolInfo{$InfoId}{"Class"}}{$InfoId} = 1; 14421 } 14422 } 14423 14424 my $MAX = $IDs[$#IDs] + 1; 14425 14426 foreach my $TypeId (sort {int($a)<=>int($b)} keys(%TypeInfo)) 14427 { # order is important 14428 if(not defined $TypeInfo{$TypeId}{"Tid"}) { 14429 $TypeInfo{$TypeId}{"Tid"} = $TypeId; 14430 } 14431 if(defined $TypeInfo{$TypeId}{"BaseType"}) 14432 { 14433 if(defined $TypeInfo{$TypeId}{"BaseType"}{"Tid"}) 14434 { # format of ABI dump changed in ACC 1.99 14435 $TypeInfo{$TypeId}{"BaseType"} = $TypeInfo{$TypeId}{"BaseType"}{"Tid"}; 14436 } 14437 } 14438 my %TInfo = %{$TypeInfo{$TypeId}}; 14439 if(defined $TInfo{"Base"}) 14440 { 14441 foreach (keys(%{$TInfo{"Base"}})) { 14442 $Class_SubClasses{$_}{$TypeId} = 1; 14443 } 14444 } 14445 if($TInfo{"Type"} eq "Typedef" 14446 and defined $TInfo{"BaseType"}) 14447 { 14448 if(my $BTid = $TInfo{"BaseType"}) 14449 { 14450 my $BName = $TypeInfo{$BTid}{"Name"}; 14451 if(not $BName) 14452 { # broken type 14453 next; 14454 } 14455 if($TInfo{"Name"} eq $BName) 14456 { # typedef to "class Class" 14457 # should not be registered in TName_Tid 14458 next; 14459 } 14460 if(not $Typedef_BaseName{$TInfo{"Name"}}) { 14461 $Typedef_BaseName{$TInfo{"Name"}} = $BName; 14462 } 14463 if(selectType($TypeId)) { 14464 $Type_Typedef{$BTid}{$TypeId} = 1; 14465 } 14466 } 14467 } 14468 if(not $TName_Tid{$TInfo{"Name"}}) 14469 { # classes: class (id1), typedef (artificial, id2 > id1) 14470 $TName_Tid{$TInfo{"Name"}} = $TypeId; 14471 } 14472 if(my $Prefix = getPrefix($TInfo{"Name"})) { 14473 $Library_Prefixes{$Prefix} += 1; 14474 } 14475 14476 if($TInfo{"Type"} eq "Array") 14477 { # size in bytes to size in elements 14478 if($TInfo{"Name"}=~/\[(\d+)\]/) { 14479 $TypeInfo{$TypeId}{"Count"} = $1; 14480 } 14481 } 14482 14483 if($TInfo{"Type"} eq "Class" 14484 and not defined $Ctors{$TypeId}) 14485 { # add default c-tors 14486 %{$SymbolInfo{$MAX++}} = ( 14487 "Class"=>$TypeId, 14488 "Constructor"=>1, 14489 "Header"=>$TInfo{"Header"}, 14490 "InLine"=>1, 14491 "Line"=>$TInfo{"Line"}, 14492 "ShortName"=>$TInfo{"Name"}, 14493 "MnglName"=>"_aux_".$MAX."_C1E" 14494 ); 14495 } 14496 } 14497 14498 if($COMMON_LANGUAGE eq "C") 14499 { 14500 if(my $TypeId = get_TypeIdByName("struct __exception*")) 14501 { 14502 $TypeInfo{$TypeId}{"Name"} = "struct exception*"; 14503 $TypeInfo{$TypeInfo{$TypeId}{"BaseType"}}{"Name"} = "struct exception"; 14504 } 14505 } 14506} 14507 14508sub identifyLibrary($) 14509{ 14510 my $Name = $_[0]; 14511 if(my $Path = $RegisteredLibs{$Name}) { 14512 return $Path; 14513 } 14514 elsif(my $Path = $KnownLibs{$Name}) { 14515 return $Path; 14516 } 14517 return $Name; 14518} 14519 14520sub selectType($) 14521{ 14522 my $Tid = $_[0]; 14523 my $Name = $TypeInfo{$Tid}{"Name"}; 14524 if(index($Name, "::_")!=-1) 14525 { # std::basic_istream<wchar_t>::__streambuf_type 14526 return 0; 14527 } 14528 if(index($Name, "_")==0) 14529 { # __gthread_t 14530 return 0; 14531 } 14532 if(get_depth($Name, "::")>=2) 14533 { # std::vector::difference_type 14534 return 0; 14535 } 14536 if(get_depth($Name, "_")>=3) 14537 { # std::random_access_iterator_tag 14538 return 0; 14539 } 14540 if(index($Name, ">::")!=-1) 14541 { # std::collate<char>::collate 14542 return 0; 14543 } 14544 return 1; 14545} 14546 14547sub skipHeader($) 14548{ 14549 if(defined $Cache{"skipHeader"}{$_[0]}) { 14550 return $Cache{"skipHeader"}{$_[0]} 14551 } 14552 return ($Cache{"checkHeader"}{$_[0]} = skipHeader_I($_[0])); 14553} 14554 14555sub skipHeader_I($) 14556{ 14557 my $Path = $_[0]; 14558 return 1 if(not $Path); 14559 if(not keys(%SkipHeaders)) { 14560 return 0; 14561 } 14562 my $Name = get_filename($Path); 14563 if(my $Kind = $SkipHeaders{"Name"}{$Name}) { 14564 return $Kind; 14565 } 14566 foreach my $D (keys(%{$SkipHeaders{"Path"}})) 14567 { 14568 if(index($Path, $D)!=-1) 14569 { 14570 if($Path=~/\Q$D\E([\/\\]|\Z)/) { 14571 return $SkipHeaders{"Path"}{$D}; 14572 } 14573 } 14574 } 14575 foreach my $P (keys(%{$SkipHeaders{"Pattern"}})) 14576 { 14577 if(my $Kind = $SkipHeaders{"Pattern"}{$P}) 14578 { 14579 if($Name=~/$P/) { 14580 return $Kind; 14581 } 14582 if($P=~/[\/\\]/ and $Path=~/$P/) { 14583 return $Kind; 14584 } 14585 } 14586 } 14587 return 0; 14588} 14589 14590sub classifyPath($) 14591{ 14592 my $Path = $_[0]; 14593 if($Path=~/[\*\[]/) 14594 { # wildcard 14595 $Path=~s/\*/.*/g; 14596 $Path=~s/\\/\\\\/g; 14597 return ($Path, "Pattern"); 14598 } 14599 elsif($Path=~/[\/\\]/) 14600 { # directory or relative path 14601 return (path_format($Path, $OSgroup), "Path"); 14602 } 14603 else { 14604 return ($Path, "Name"); 14605 } 14606} 14607 14608sub registerFiles() 14609{ 14610 14611 foreach my $Path (split(/\s*\n\s*/, $Descriptor{"SkipHeaders"})) 14612 { 14613 my ($CPath, $Type) = classifyPath($Path); 14614 $SkipHeaders{$Type}{$CPath} = 1; 14615 } 14616 14617 foreach my $Path (split(/\s*\n\s*/, $Descriptor{"SkipIncluding"})) 14618 { 14619 my ($CPath, $Type) = classifyPath($Path); 14620 $SkipHeaders{$Type}{$CPath} = 2; 14621 } 14622 14623 foreach my $Path (split(/\s*\n\s*/, $Descriptor{"Headers"})) { 14624 registerHeaders($Path); 14625 } 14626 14627 foreach my $Path (split(/\s*\n\s*/, $Descriptor{"Libs"})) { 14628 registerLibs($Path); 14629 } 14630} 14631 14632sub scenario() 14633{ 14634 if(defined $Help) 14635 { 14636 HELP_MESSAGE(); 14637 exit(0); 14638 } 14639 if(defined $InfoMsg) 14640 { 14641 INFO_MESSAGE(); 14642 exit(0); 14643 } 14644 if(defined $ShowVersion) 14645 { 14646 printMsg("INFO", "API Sanity Checker $TOOL_VERSION\nCopyright (C) 2013 ROSA Lab\nLicense: LGPL or GPL <http://www.gnu.org/licenses/>\nThis program is free software: you can redistribute it and/or modify it.\n\nWritten by Andrey Ponomarenko."); 14647 exit(0); 14648 } 14649 if(defined $DumpVersion) 14650 { 14651 printMsg("INFO", $TOOL_VERSION); 14652 exit(0); 14653 } 14654 if(not defined $Template2Code) { 14655 $Standalone = 1; 14656 } 14657 if($GenerateDescriptorTemplate) 14658 { 14659 genDescriptorTemplate(); 14660 exit(0); 14661 } 14662 if($GenerateSpecTypeTemplate) 14663 { 14664 genSpecTypeTemplate(); 14665 exit(0); 14666 } 14667 if($OSgroup eq "windows") 14668 { 14669 if(not $ENV{"DevEnvDir"} 14670 or not $ENV{"LIB"}) { 14671 exitStatus("Error", "can't start without VS environment (vsvars32.bat)"); 14672 } 14673 } 14674 if(defined $TargetCompiler) 14675 { 14676 $TargetCompiler = uc($TargetCompiler); 14677 if($TargetCompiler!~/\A(GCC|CL)\Z/) { 14678 exitStatus("Error", "Target compiler is not either gcc or cl"); 14679 } 14680 } 14681 else 14682 { # default 14683 if($OSgroup eq "windows") { 14684 $TargetCompiler = "CL"; 14685 } 14686 } 14687 if(defined $TestTool) 14688 { 14689 loadModule("RegTests"); 14690 testTool($Debug, $LIB_EXT, $OpenReport, $TargetCompiler); 14691 exit(0); 14692 } 14693 if(not defined $TargetLibraryName) { 14694 exitStatus("Error", "library name is not selected (-l option)"); 14695 } 14696 else 14697 { # validate library name 14698 if($TargetLibraryName=~/[\*\/\\]/) { 14699 exitStatus("Error", "These symbols are not allowed in the library name: \"\\\", \"\/\" and \"*\""); 14700 } 14701 } 14702 if(not $TargetLibraryFullName) { 14703 $TargetLibraryFullName = $TargetLibraryName; 14704 } 14705 if($TestDataPath and not -d $TestDataPath) { 14706 exitStatus("Access_Error", "can't access directory \'$TestDataPath\'"); 14707 } 14708 if($SpecTypes_PackagePath and not -f $SpecTypes_PackagePath) { 14709 exitStatus("Access_Error", "ERROR: can't access file \'$SpecTypes_PackagePath\'"); 14710 } 14711 if($InterfacesListPath) 14712 { 14713 if(-f $InterfacesListPath) 14714 { 14715 foreach my $Interface (split(/\n/, readFile($InterfacesListPath))) { 14716 $InterfacesList{$Interface} = 1; 14717 } 14718 } 14719 else { 14720 exitStatus("Access_Error", "can't access file \'$InterfacesListPath\'"); 14721 } 14722 } 14723 14724 if(not $Descriptor{"Path"}) { 14725 exitStatus("Error", "library descriptor is not selected (option -d PATH)"); 14726 } 14727 elsif(not -f $Descriptor{"Path"}) { 14728 exitStatus("Access_Error", "can't access file \'".$Descriptor{"Path"}."\'"); 14729 } 14730 elsif($Descriptor{"Path"}!~/\.(xml|desc)\Z/i) { 14731 exitStatus("Error", "descriptor should be *.xml file"); 14732 } 14733 14734 if(not $GenerateTests and not $BuildTests 14735 and not $RunTests and not $CleanTests and not $CleanSources) { 14736 exitStatus("Error", "one of these options is not specified: -gen, -build, -run or -clean"); 14737 } 14738 $TOOL_SIGNATURE = "<hr/><div style='width:100%;font-family:Arial;font-size:11px;' align='right'><i>Generated on ".(localtime time)." for <b>$TargetLibraryFullName</b> by <a href='".$HomePage{"Dev"}."'>API Sanity Checker</a> $TOOL_VERSION <br/>An automatic generator of basic unit tests for a C/C++ library API </i></div>"; 14739 if($ParameterNamesFilePath) 14740 { 14741 if(-f $ParameterNamesFilePath) 14742 { 14743 foreach my $Line (split(/\n/, readFile($ParameterNamesFilePath))) 14744 { 14745 if($Line=~s/\A(\w+)\;//) 14746 { 14747 my $Interface = $1; 14748 if($Line=~/;(\d+);/) 14749 { 14750 while($Line=~s/(\d+);(\w+)//) { 14751 $AddIntParams{$Interface}{$1}=$2; 14752 } 14753 } 14754 else 14755 { 14756 my $Num = 0; 14757 foreach my $Name (split(/;/, $Line)) 14758 { 14759 $AddIntParams{$Interface}{$Num}=$Name; 14760 $Num+=1; 14761 } 14762 } 14763 } 14764 } 14765 } 14766 else { 14767 exitStatus("Access_Error", "can't access file \'$ParameterNamesFilePath\'"); 14768 } 14769 } 14770 if($TargetInterfaceName and defined $Template2Code) { 14771 exitStatus("Error", "selecting of symbol is not supported in the Template2Code format"); 14772 } 14773 if(($BuildTests or $RunTests or $CleanTests) and defined $Template2Code 14774 and not defined $GenerateTests) { 14775 exitStatus("Error", "see Template2Code technology documentation for building and running tests:\n http://template2code.sourceforge.net/t2c-doc/index.htm"); 14776 } 14777 if($Strict) { 14778 ($StrictGen, $StrictBuild, $StrictRun) = (1, 1, 1); 14779 } 14780 if($GenerateTests) 14781 { 14782 readDescriptor($Descriptor{"Path"}); 14783 registerFiles(); 14784 14785 $TestFormat = "GCC"; 14786 if($OSgroup eq "windows" 14787 and $TargetCompiler eq "CL") 14788 { # default for Windows 14789 $TestFormat = "CL"; 14790 } 14791 14792 $TEST_SUITE_PATH = ((defined $Template2Code)?"tests_t2c":"tests")."/$TargetLibraryName/".$Descriptor{"Version"}; 14793 my $LOG_DIR = "logs/".$TargetLibraryName."/".$Descriptor{"Version"}; 14794 rmtree($LOG_DIR); 14795 mkpath($LOG_DIR); 14796 $LOG_PATH = abs_path($LOG_DIR)."/log.txt"; 14797 $CACHE_PATH = "cache/".$TargetLibraryName."/".$Descriptor{"Version"}; 14798 14799 initLogging(); 14800 14801 read_ABI($Descriptor{"Path"}); 14802 14803 prepareInterfaces(); 14804 add_os_spectypes(); 14805 if($SpecTypes_PackagePath) { 14806 readSpecTypes(readFile($SpecTypes_PackagePath)); 14807 } 14808 14809 setRegularities(); 14810 markAbstractClasses(); 14811 14812 if(not keys(%Common_SpecEnv)) 14813 { # automatic preamble and finalization 14814 add_LibraryPreambleAndFinalization(); 14815 } 14816 if($TargetInterfaceName) 14817 { 14818 if(not $CompleteSignature{$TargetInterfaceName}) 14819 { 14820 my $EMsg = "specified symbol is not found\n"; 14821 if($Func_ShortName_MangledName{$TargetInterfaceName}) 14822 { 14823 if(keys(%{$Func_ShortName_MangledName{$TargetInterfaceName}})==1) { 14824 $EMsg .= "did you mean ".(keys(%{$Func_ShortName_MangledName{$TargetInterfaceName}}))[0]." ?"; 14825 } 14826 else { 14827 $EMsg .= "candidates are:\n ".join("\n ", keys(%{$Func_ShortName_MangledName{$TargetInterfaceName}})); 14828 } 14829 } 14830 exitStatus("Error", $EMsg); 14831 } 14832 if(not symbolFilter($TargetInterfaceName)) { 14833 exitStatus("Error", "can't generate test for $TargetInterfaceName"); 14834 } 14835 printMsg("INFO_C", "generating test for $TargetInterfaceName ... "); 14836 readScenario(); 14837 generateTest($TargetInterfaceName); 14838 write_scenario(); 14839 if($GenResult{$TargetInterfaceName}{"IsCorrect"}) { 14840 printMsg("INFO", "success"); 14841 } 14842 else { 14843 printMsg("INFO", "fail"); 14844 } 14845 create_Index(); 14846 } 14847 else 14848 { 14849 generateTests(); 14850 create_Index() if(not defined $Template2Code); 14851 } 14852 if($ResultCounter{"Gen"}{"Success"}>0) 14853 { 14854 if($TargetInterfaceName) 14855 { 14856 my $TestPath = getTestPath($TargetInterfaceName); 14857 printMsg("INFO", "see generated test in \'$TestPath/\'"); 14858 } 14859 else 14860 { 14861 printMsg("INFO", ""); 14862 if($Template2Code) 14863 { 14864 printMsg("INFO", "1. see generated test suite in the directory \'$TEST_SUITE_PATH/\'"); 14865 printMsg("INFO", "2. see Template2Code technology documentation for building and running tests:\nhttp://template2code.sourceforge.net/t2c-doc/index.html"); 14866 } 14867 else 14868 { 14869 printMsg("INFO", "1. see generated test suite in the directory \'$TEST_SUITE_PATH/\'"); 14870 printMsg("INFO", "2. for viewing tests use \'$TEST_SUITE_PATH/view_tests.html\'"); 14871 printMsg("INFO", "3. use -build option for building tests"); 14872 } 14873 printMsg("INFO", ""); 14874 } 14875 } 14876 if($Debug) 14877 { # write debug log 14878 writeDebugLog(); 14879 } 14880 remove_option(\@INPUT_OPTIONS, "gen"); 14881 remove_option(\@INPUT_OPTIONS, "generate"); 14882 } 14883 if($BuildTests and $GenerateTests and defined $Standalone) 14884 { # allocated memory for tests generation should be returned to OS 14885 system("perl", $0, @INPUT_OPTIONS); # build + run 14886 exit($?>>8); 14887 } 14888 elsif($BuildTests and defined $Standalone) 14889 { 14890 readDescriptor($Descriptor{"Path"}); 14891 $TEST_SUITE_PATH = "tests/$TargetLibraryName/".$Descriptor{"Version"}; 14892 if(not -e $TEST_SUITE_PATH) { 14893 exitStatus("Error", "tests were not generated yet"); 14894 } 14895 if($TargetInterfaceName) 14896 { 14897 printMsg("INFO_C", "building test for $TargetInterfaceName ... "); 14898 readScenario(); 14899 buildTest($TargetInterfaceName); 14900 if($BuildResult{$TargetInterfaceName}{"IsCorrect"}) 14901 { 14902 if($BuildResult{$TargetInterfaceName}{"Warnings"}) { 14903 printMsg("INFO", "success (Warnings)"); 14904 } 14905 else { 14906 printMsg("INFO", "success"); 14907 } 14908 } 14909 elsif(not $BuildResult{$TargetInterfaceName}{"TestNotExists"}) { 14910 printMsg("INFO", "fail"); 14911 } 14912 } 14913 else { 14914 buildTests(); 14915 } 14916 if($ResultCounter{"Build"}{"Success"}>0 14917 and not $TargetInterfaceName and not $RunTests) { 14918 printMsg("INFO", "use -run option to run tests"); 14919 } 14920 remove_option(\@INPUT_OPTIONS, "build"); 14921 remove_option(\@INPUT_OPTIONS, "make"); 14922 } 14923 if(($CleanTests or $CleanSources) and defined $Standalone) 14924 { 14925 readDescriptor($Descriptor{"Path"}); 14926 $TEST_SUITE_PATH = "tests/$TargetLibraryName/".$Descriptor{"Version"}; 14927 if(not -e $TEST_SUITE_PATH) { 14928 exitStatus("Error", "tests were not generated yet"); 14929 } 14930 if($TargetInterfaceName) 14931 { 14932 printMsg("INFO_C", "cleaning test for $TargetInterfaceName ... "); 14933 readScenario(); 14934 cleanTest($TargetInterfaceName); 14935 printMsg("INFO", "success"); 14936 } 14937 else { 14938 cleanTests(); 14939 } 14940 remove_option(\@INPUT_OPTIONS, "clean") if($CleanTests); 14941 remove_option(\@INPUT_OPTIONS, "view-only") if($CleanSources); 14942 14943 } 14944 if($RunTests and $GenerateTests and defined $Standalone) 14945 { # tests running requires creation of two processes, so allocated memory must be returned to the system 14946 system("perl", $0, @INPUT_OPTIONS); 14947 exit($ResultCounter{"Build"}{"Fail"}!=0 or $?>>8); 14948 } 14949 elsif($RunTests and defined $Standalone) 14950 { 14951 initSignals(); 14952 readDescriptor($Descriptor{"Path"}); 14953 $TEST_SUITE_PATH = "tests/$TargetLibraryName/".$Descriptor{"Version"}; 14954 $REPORT_PATH = "test_results/$TargetLibraryName/".$Descriptor{"Version"}; 14955 if(not -e $TEST_SUITE_PATH) { 14956 exitStatus("Error", "tests were not generated yet"); 14957 } 14958 if($OSgroup eq "windows") { 14959 createTestRunner(); 14960 } 14961 my $ErrCode = 0; 14962 if($TargetInterfaceName) 14963 { 14964 readScenario(); 14965 my $XvfbStarted = 0; 14966 if($UseXvfb and (-f $Interface_TestDir{$TargetInterfaceName}."/test" 14967 or -f $Interface_TestDir{$TargetInterfaceName}."/test.exe")) { 14968 $XvfbStarted = runXvfb(); 14969 } 14970 printMsg("INFO_C", "running test for $TargetInterfaceName ... "); 14971 $ErrCode = run_sanity_test($TargetInterfaceName); 14972 stopXvfb($XvfbStarted) if($UseXvfb); 14973 if($RunResult{$TargetInterfaceName}{"IsCorrect"}) 14974 { 14975 if($RunResult{$TargetInterfaceName}{"Warnings"}) { 14976 printMsg("INFO", "success (Warnings)"); 14977 } 14978 else { 14979 printMsg("INFO", "success"); 14980 } 14981 } 14982 elsif(not $RunResult{$TargetInterfaceName}{"TestNotExists"}) { 14983 printMsg("INFO", "fail (".get_problem_title($RunResult{$TargetInterfaceName}{"Type"}, $RunResult{$TargetInterfaceName}{"Value"}).")"); 14984 } 14985 } 14986 else { 14987 $ErrCode = run_tests(); 14988 } 14989 mkpath($REPORT_PATH); 14990 if((not $TargetInterfaceName or not $RunResult{$TargetInterfaceName}{"TestNotExists"}) 14991 and keys(%Interface_TestDir) and not $ErrCode) 14992 { 14993 unlink($REPORT_PATH."/test_results.html");# removing old report 14994 printMsg("INFO", "creating report ..."); 14995 createReport(); 14996 printMsg("INFO", "see test results in the file:\n $REPORT_PATH/test_results.html"); 14997 } 14998 exit($ResultCounter{"Run"}{"Fail"}!=0); 14999 } 15000 exit($ResultCounter{"Build"}{"Fail"}!=0); 15001} 15002 15003scenario(); 15004