#!/usr/bin/perl ## pythonizer -- Translator of the subset of Perl 5 to Python 3.8+ ## Copyright Nikolai Bezroukov, 2019-2022. Significant updates by Joe Cool (http://github.com/snoopyjc). ## Licensed under Perl Artistic license ## ## Automatic translation of most perl scripts to python 3.8+. ## Best works for Perl 4 subset of Perl 5 which typically is used in sysadmin scripts. ## Perl scripts that extensivly use references or OO require more extensive manual effort ## ## --- INVOCATION: ## ## pythonizer [options] [file_to_process] ## ##--- OPTIONS: ## -V -- print the version and exit ## -v -- verbosity 0 -minimal (only serious messages) 3 max verbosity (warning, errors and serious); default -v 1 ## -h -- this help ## -t -- size of tab in the generated Python code (emulated with spaces). Default is 4 ## -k -- run the Python Black code formatter (if it's available) on the generated python code (default) ## -K -- Turn off -k ## -l -- the output line length - how many characters per line to generate by the Black code formatter (default 98) ## -m -- Make global variables into "my" filescope variables, else they use a separate global namespace ## -M -- Turn off -m ## NOTE: If neither -m nor -M are passed, the pythonizer uses heuristics to make a best guess here. ## -u -- Replace usage strings of the form "Usage: filename.pl ..." with "Usage: filename.py ..." and also replace "myScript.pl" with "myScript.py" (default) ## -U -- Turn off -u ## -y -- Replace ".pl" references to perl scripts as the first path-like word of a string or in a backtick reference to refer to ".py" instead, changing calls to perl scripts to instead call the pythonized version. (default) ## -Y -- Turn off -y ## -s -- Attempt to run standard library functions thru pythonizer for use/require - not recommended! ## -S -- Turn off -s ## -p -- "import perllib" library instead of including functions inline to emulate perl built-in functions (default) ## -P -- Turn off -p ## -A -- Imply "use autodie qw(:all);" ## -T -- Perform a traceback in the generated code on errors ## -n -- Trace Run: Generate code to trace subprocess.run results - used in qx, `backtick`, open('|'), and system() ## -o dir -- Output directory for .py and .data files, created if need be (defaults to the same location as the input file) ## -N -- Imply "no autovivification qw(fetch delete exists store strict);" ## -w -- the width of the screen on which you plan to view the protocol of translation. The default is 188. ## -R -- remap comma separated list of variables: variables specified as var or *var will map all variables named 'var', ## $var will just map scalar to var_v, @var will just map array to var_a, %var will just map hash to var_h, ## :global will remap all global vars (default), :all will remap all variables, :none will remap no variables. ## -a -- Add __author__, __email__, and __version__ strings to the generated code ## -e input_encoding,output_encoding -- specify the encoding to use for the perl input file and the python output file ## If this option is not specified, then Pythonzer attempts to discern the input encoding by looking for "use utf8;" in ## the input file or a special coding comment like # -*- coding: latin1 -*-. If neither are found, Pythonizer effectively uses ## Encoding::FixLatin::fix_latin to read the input if there are any non-ascii characters present, which does a pretty good job ## of reading any encoding. ## If -e is specified, then the next argument is used to determine the input file encoding and the output file encoding. ## If -e is specified and ",output_encoding" is not included, then the output encoding defaults to the same ## as the input encoding. If input_encoding is not included (and you only include ",output_encoding", then ## Pythonizer attempts to detect the input encoding as if -e was not specified, but with the specified output encoding. ## If the input_encoding is specified and is followed by only a comma, then the output_encoding defaults to utf8. ## -f -- Fully qualify method calls. If not specified, and -M is specified or implied, then this is turned on ## -F -- Turn off -f. If not specified, and -m is specified or implied, then -f is turned off ## -d level of debugging default is 0 -- production mode ## 0 -- Production mode ## 1 -- Testing mode. Program is autosaved in Archive (primitive versioning mechanism) ## 2 -- Stop at the beginning of statement analysys (the statement can be selected via breakpoint option -b ) ## 3 -- More debugging output. ## 4 -- Stop at lexical scanner with $DB::single = 1; ## 5 -- output stages of Python line generation ## 6 -- also trace all calls to getline() ## -B N -- for internal debugging - set breakpoint when processing input line N in the first pass ## -b N -- for internal debugging - set breakpoint when processing input line N in the second pass ## ## You may set these options and all other options in the perl source file using a special comment ## of the form "# pragma pythonizer -flags". You can also spell the options out optionally prefixed ## by "no", like "# pragma pythonizer no implicit global my, traceback". ##--- PARAMETERS: ## ## 1st -- full pathname of file (only one argument accepted) ## ##--- OUTPUT: ## filename.py will be generated in the same folder as the input file (unless -o is specified) #--- Development History # # Ver Date Who Modification # ===== ========== ======== ============================================================== # 0.010 2019/10/09 BEZROUN Initial implementation # 0.020 2019/10/10 BEZROUN Revised structure of global arrays, Now we have four parallel arrays: TokenStr, ValClass ValPerl, ValPy # 0.030 2019/10/11 BEZROUN Recursion is used to expressions, but in certain cases when I need a look-ahead, bracket counting is used instead # 0.040 2019/10/12 BEZROUN Better listing for debugging implemented # 0.050 2019/11/06 BEZROUN Forgot almost everything after a month; revised code just to refreash memory. Tokenizer slightly improved # 0.051 2019/11/07 BEZROUN Assignment within logical expression is not allowed in Python 2.7. It is now translated correctly # 0.060 2019/11/08 BEZROUN post assignment conditions like "next if( substr($line,0,1) eq '') " are processed correctly # 0.070 2019/11/11 BEZROUN x=(v>0) ? y :z is now translated into ugly Python ternary operator which exists since Python 2.5 # 0.071 2019/11/11 BEZROUN program now correctly translated 80% codelines of pre_pythonizer.pl # 0.080 2019/12/27 BEZROUN Array ValCom is introduced for the preparation of version 0.2 of pre-processor pre_pythonizer.pl # 0.090 2020/02/03 BEZROUN #\ means continuation of the statement. # 0.091 2020/02/03 BEZROUN Moved sub preprocess_line to Pythonizer # 0.100 2020/03/16 BEZROUN Reworked scanner # 0.200 2020/08/05 BEZROUN Abandoned hope to make it perfect. # 0.210 2020/08/07 BEZROUN Moved gen_output to Perlscan, removed ValCom from the exported list. # 0.220 2020/08/07 BEZROUN Diamond operator is processed as a special type of identifier. # 0.230 2020/08/09 BEZROUN gen_chunk moves to Perlscan module. Pythoncode array made local # 0.230 2020/08/09 BEZROUN more functions and statements implemented # 0.240 2020/08/10 BEZROUN postfix conditional like return if(rc>0) re-implemented differently via scanner buffer # 0.250 2020/08/10 BEZROUN split function is reimplemented and optimized in case there is plain vanilla string and not-regex. # 0.251 2020/08/12 BEZROUN Perl_default_var is renames into default_var # 0.260 2020/08/14 BEZROUN System variables in double quoted literals are now complied correctly. Perlscan.pm improved. # 0.261 2020/08/14 BEZROUN for loop translation corrected # 0.270 2020/08/15 BEZROUN getopts is now implemented in Softpano.pm to allow the repetition of option letter to set the value of options ( -ddd) # 0.300 2020/08/17 BEZROUN Python 3.8 now is default for generaion. Option -p introduced. -p 2 changes target version of Python to 2.7 # 0.310 2020/08/18 BEZROUN f-strings are implemented for Python 3 mode instead of decompiling string into chunks # 0.320 2020/08/20 BEZROUN open statement and (condition) && ... statement translation corrected # 0.400 2020/08/22 BEZROUN __DATA__ and POD statements are now processed. File filename.data is created for data file. # 0.410 2020/08/24 BEZROUN pre_pythonizer now refactors Perl script pushing subroutines to the top and creating main sub. # 0.420 2020/08/25 BEZROUN print recognized in constructs like if($debug){ print 'something';}. # 0.430 2020/08/25 BEZROUN Variables from other namespaces recognized. # 0.440 2020/08/26 BEZROUN FailedTrans flag is replaced with TrStatus flag. Failure now is determined by the negative value of the TrStatus flag. # 0.450 2020/08/26 BEZROUN Option - r (refactor) added # 0.500 2020/08/31 BEZROUN Regular expression processing competly reworked based on changed in Perlscan # 0.510 2020/08/31 BEZROUN Special subroutine for putting regex in quote created in Perlscan.pm # 0.520 2020/08/31 BEZROUN Statement $line=~/abc/ this is not assignment statement; In no metacharaters it should be treated as string search. # 0.530 2020/08/31 BEZROUN Handling of __DATA and __END__ improved. Now they are not discarded but instead the separate file with extention.data is created. # 0.540 2020/09/01 BEZROUN Translation of function substr improved by recognizing several special cases. # 0.550 2020/09/01 BEZROUN Matching of groups corrected. # 0.560 2020/09/02 BEZROUN Translation of for and while improved. # 0.570 2020/09/03 BEZROUN Translation of ++ and -- implemented # 0.580 2020/09/03 BEZROUN Translation of function sprintf implemented # 0.600 2020/09/08 BEZROUN List on internal functions created. Translation of backquotes and open improved. # 0.700 2020/09/17 BEZROUN Basic global varibles detection added. Global statement generated for each local subroutine # 0.800 2020/10/02 BEZROUN More correct translation of array assignments. Globals initialiazed after main sub. Installer added # 0.810 2020/10/05 BEZROUN Pre-pythonizer by default does not create main subroutine # 0.820 2020/10/06 BEZROUN Function parsing rewritten to accomodate some "bracketless" cases which now became a norm in Perl # 0.830 2020/10/08 BEZROUN Implementation of postfix conditional is completly rewritten and now uses token buffering # 0.840 2020/10/09 BEZROUN state varibles now are prefixed with the name of sub to avoid conflict with globals # 0.850 2020/10/12 BEZROUN print translation improved; many fixes in lex analyser # 0.860 2020/10/14 BEZROUN Python 2.7 mode eliminated to simplify the code. Option -p removed. "since" test passed # 0.870 2020/10/21 BEZROUN Treatment of brackets systematised. The code of subroutine expression revised. # 0.871 2021/05/10 BEZROUN Minor corrections in the header. # 0.900 2021/11/06 SNOOPYJC Updates to handle many more cases. # 0.901 2021/11/08 SNOOPYJC Fix issue 22 and issue with pyf folder # 0.902 2021/11/09 SNOOPYJC Fix issues 13,23,24,25,26 and mismatched parens # 0.903 2021/11/10 SNOOPYJC Physically remove ( ) on control statements rather than just skipping the first and removing the second # 0.904 2021/11/10 SNOOPYJC Fix issues in for/foreach, including adding range support and proper loop termination if ">=" or "<=" is used. Generate proper code for split on space. # 0.905 2021/11/11 SNOOPYJC Fix issues 28, 29, 31 # 0.906 2021/11/14 SNOOPYJC Fix issue 14, more fixes for issue 9, 13 and 28, issue 35, 36, 37, 38, and most of issue 39 (except interpolation in HereIs) # 0.907 2021/11/15 SNOOPYJC Fix issues 43, 44, more issue 37 (my $x=@a) # 0.908 2021/11/15 SNOOPYJC Fix issue 48 # 0.909 2021/11/16 SNOOPYJC Handle more cases of issue 48, issue 49, additional fix for issue 44, issue 54, issue 52 (in assignment only), issue 50, issue 53, issue 45, issue 55, issue 56, issue 57, issue 58, issue 46, issue 59, issue 61, issue 62, issue 61, issue 62, issue 41, issue 45 # 0.910 2021/11/22 SNOOPYJC Fix issue 63, issue with post-pass refactoring of multi-line strings, issue 64, addl fixes for issue 36 and issue 39, another issue 13 fix (array assignment of function call) # 0.911 2021/11/23 SNOOPYJC Another issue 49 fix ($ARGV), another issue 43 fix (${var} not in ...), issue 68, issue 65, issue 69, more issue 32 fixes, some pep8 enhancements to spacing, implement 'abs(...)', issue 74, issue 66, issue 75, issue 76, issue 42, issue 52, another issue 45 fix, isue 42, issue 73, issue 71 # 0.912 2021/11/29 SNOOPYJC Fix coding error in perl_open (encoding) # 0.913 2021/11/30 SNOOPYJC issue 79, addl fix for issue 53, addl fix for foreach, addl fix for ++/--, add constants for open and flock # 0.914 2021/12/01 SNOOPYJC Fix missing _time, add _flock, fix references to $!, issue 81 # 0.915 2021/12/02 SNOOPYJC Additional issue 81 fixes, add -A for autodie and -T for traceback, fix issue with globals on sub's with () # 0.916 2021/12/03 SNOOPYJC issue 60: implement grep and map # 0.917 2021/12/04 SNOOPYJC Addl fix for issue 60 - map with user functions, fix ref, generate proper code for $#ARGV, generate no code for labels and warn on label refs, fix .. range if preceded by a digit, use _open for all open calls, implement binmode, fix extra paren on split, add type computation and init variables appropriately, fix state vars, change undef to use type appropriate assignment, issue 82 # 0.918 2021/12/06 SNOOPYJC addl issue 39 fix, compute types of user subs, add sqrt, fix _flock typo, more type analysis, issue 85, fix undef, fix | open, issue 86, fix get_globals # 0.919 2021/12/08 SNOOPYJC Set nest to 0 after pass 1, allow ' in varnames (old perl syntax for ::), fix infinite recursion in expr_type, fix := in assignment in expression by fixing next_same_level_token(s) for parens, issue 88, extra issue 50 fix for $$xxx, addl fix for issue 45 with function call as last statement # 0.920 2021/12/09 SNOOPYJC issue 89, issue 90, addl fix for $t-timegm issue 88, add timegm(), issue 91 # 0.921 2021/12/10 SNOOPYJC Fix if not(open(FH,...)), add rename, fork, implement range (..) operator in slice, issue 84, fix open/opendir in control stmt # 0.922 2021/12/10 SNOOPYJC issue 93, fix foreach (%hash), @arr = keys %hash, @arr = values %hash, @arr = %hash, ignore var defs alone, handle modelsss constant open, handle sed/awk style range, implement each # 0.923 2021/12/12 SNOOPYJC Add wait() using _wait(), fileparse() using _fileparse(), fix open/opendir with filename expression, issue 94 # 0.924 2021/12/13 SNOOPYJC issue 95, implement do{...}while/until(...);, PERL5PATH is now automatic, addl fix for issue 93, issue 96, remove double ++/-- fix, remove warning on 1;, issue 99 # 0.925 2021/12/14 SNOOPYJC Addl fixes for issue 21 (split), issue 45 (was putting orig lines in wrong place), issue 58 on elsif, fix opendir not found error, issue 98, issue 100, remove extra 'r' after regex, issue 101 # 0.926 2021/12/15 SNOOPYJC Addl fix for issue 93, uniquely map tokens to get precedence, issue 102, update to ending fix in double_quoted string # 0.927 2021/12/16 SNOOPYJC Revamp the time functions, use *arr for passing arrays, use map(str,...) for join of int array # 0.928 2021/12/19 SNOOPYJC Rename vars that clash with built-in functions like len, etc., fix _each, issue 103, issue 104, implement automatic type conversion, issue 105, issue 106 # 0.929 2021/12/20 SNOOPYJC issue 107, fix _open if result is checked, implement $| and FD->autoflush(), fix problem with vartypes for globals vars, use _i as temp loop index instead of _ # 0.930 2021/12/21 SNOOPYJC Check var references in interpolated strings for auto-init # 0.931 2021/12/22 SNOOPYJC Interpolate in HERE strings, issue 92 # 0.932 2021/12/23 SNOOPYJC Fix foreach loop with array range, fix range index to include last, addl fix for issue 92, issue 109, remove blank lines at start of output, change not X is not None => X is None # 0.933 2021/12/23 SNOOPYJC Additional fix for issue 106, issue 110, addl fix for issue 45, handle $/, $. with issue 66 # 0.934 2021/12/25 SNOOPYJC One more fix for issue 106, issue 108 (implement local), addl fix for issue 43 with @ and %, use a simpler _readline if the program does not use $. or $/, suppress generation of EVAL_ERROR if $@ is not used # 0.935 2021/12/26 SNOOPYJC Chg type of optional second arg to mkdir to int, chg type of ENV and os.environ so _str() is called, remove [] on args and only copy to a list if used in shift or pop, only die on return outside a function in main. # 0.936 2021/12/29 SNOOPYJC Fix issue 84 with 2 subscripts, fix caller to return None if in main, allow E in float exponent, shift(@arr) caused extra ), fix @_ in assignment where it's still a tuple, proper code generation for sub call statement with array arg, implement rand # 0.937 2021/12/30 SNOOPYJC issue 111, issue 112, issue 113, default to -v 2, print code on stdout only if -v 3, print warnings at -v 2 # 0.938 2022/01/10 SNOOPYJC Fix STMT for LIST and do{...} if/unless EXPR; fix _list_of_n() with short tuple as arg, implement dirname(), filepath(), replace basename(), splat out map() if used as arg, implement use and require, handle $. on LHS assignment, implement more special vars, handle goatse, set v5.034, implement use constant, handle names with multiple sets of ::, implement carp, $| needs to autoflush STDERR too, add seek, tell, reimplement stat and lstat, use full topological sort on sub placement, implement remaining -X operators, fix function return insertion if line has a comment, fix issue with order of comments being reversed, fix variable variables, fix assignment to ARGV[i], handle vNN version strings, handle ~ operator, handle default with no arg, exit takes an optional int - not a str, handle GLOB assignment and subrefs. Add -s flag. Fix tr with [...][...]. # 0.939 2022/01/18 SNOOPYJC Implement package X and cross-file global vars, implement -m option. Do a better job at handling various assignment operators in expressions, handle $arr_ref->[...] and $hash_ref->{...} in double quoted strings, fixes for use/require + look at the perl if we don't have the python, implement goto &sub, remove -u option to python as we have autoflush implemented, spit out the args to pythonizer in the py file, rewrite read to handle expressions and package names, handle s/.../.../ and tr/.../.../ without =~ and with complex arguments # 0.940 2022/01/18 SNOOPYJC Fix issue where _num(...) is missing on for loop upper bound, make filehandles global unless declared otherwise # 0.941 2022/01/24 SNOOPYJC Addl fix for issue 42: eval in expression, handle goatse in expression, addl fix for issue 57, reimplement read using helper function to mimic perl results and handle offset in expression, type convert sprintf/printf args to match format using a helper function, support use utf8 and handle special chars in strings and regexs, return was not being recognized as a keyword, generate a warning if the loop counter is modified in the loop # 0.942 2022/01/26 SNOOPYJC Add autovivification of arrays and hashes and -V option to turn it off and support no autovifification in the source code too, fixup incorrect code from defined arr[i][j], make sure hash and array values are always typed properly so they get initialized, fix conversions from hash to array so they don't give an error on empty hashes, change package name to main and change user sub main to main_, generate proper code to merge hashes, when tokenizing strings in the first pass, make sure we generate balanced brackets else the scanner won't stop on the ending ;, generate proper code for sub main, addl fix for issue 41 where the name is main, issue 115 multi-assignment of %hash vars # 0.943 2022/01/28 SNOOPYJC Create makelib.py and get_globals.pl to build perllib, fix binmode, make -p the default, give warning on require stmt if using -m # 0.944 2022/01/30 SNOOPYJC Addl fixes for issue 108: handle local with array elem or hash key, handle array elem and hash keys in paren list LHS expressions, fix issue 78 - s/regex/expr/e flag, handle g flag on regex, warn on wantarray use, handle 'no warnings' and assignments to $^W. # 0.945 2022/02/04 SNOOPYJC Fix __LINE__, implement __FILE__, __PACKAGE__, fix missing _init_package('main') if the file has other packages but still uses main, handle dotted package name in _init_package, fixup wrong ++/-- code in trailing if, use proper {} brackets for hashref in expr, add File::Temp functions POSIX::tmpnam, and IO::File->new, fix UTF-8 in binmode and binmode in an expression, handle i=>x in func/sub calls, change opendir etc to _opendir and fix readdir(), do not try to write in perllib folders even if writable, use python package name - not the perl name, handle open as last line of sub producing the return value, addl fix for issue 13 - scalar context with comma operator, revamp stat now that all OO references are methods and not properties # 0.946 2022/02/06 SNOOPYJC Implement redo and continue, fix push with scalar expression in parens, remove more oddities in the generated code like perllib.Array([]) and ((...)), add a couple dozen additional tests, fix issue 24, add UNITCHECK, CHECK, and INIT blocks, give warning if $? is set in an END block (not supported), issue 26, issue 30, issue 54, issue 76, handle for(;;), implement every type of for loop using while e.g. if the loop counter is modified or the increment can't be handled by range(...) # 0.947 2022/02/08 SNOOPYJC Use a heuristic to determine -m/-M option by adding Pass0.pm, implement # pragma pythonizer to set options, issue 72 - wait for subprocess to complete on close, fix fcntl, ioctl, and flock with clash on the module name # 0.948 2022/02/09 SNOOPYJC Implement splice, fix push with a list of multiple values, fix issue with assigning less values to Array slice, fix passing qw(...) to sub, fix passing array as non-first argument to sub, fix some issues in stmt modifiers, fix mkdir not returning the proper return code, remove blank line generated if the perl line has trailing whitespace # 0.949 2022/02/10 SNOOPYJC Handle ${\(expr)} and @{[expr]} in strings, fix while in stmt modifier with global pattern, fix AUTODIE, uniform handling of TRACEBACK using cluck, fix system, fix empty signal function, implement hex and oct # 0.950 2022/02/12 SNOOPYJC Fix pythonizer hang on unless eval, fix error on func($_) foreach @arr, allow sigils to have whitespace after them including newlines, use -M if all lines in main are global inits, generate proper code for ($v1,$v2...) = ();, add the package name to a non-local sub call if it's referenced with an &, implement FileHandle and new_from_fd() also for IO::File, fix if/else with comment before the {, issue 117 - pass thru the arguments on &mySub;, remove sub dereferences, implement pack and unpack # 0.951 2022/02/13 SNOOPYJC Remove extra () on if not (...), issue 116 - bash and/or with stmt modifier, issue 114 - substr with replacement, implement elipsis ..., redo test run script to operate like pytest # 0.952 2022/02/14 SNOOPYJC Grab proper var class in while(my @arr...), place close paren in proper place when adding _assign_global if there is a non-paren function or sub call involved, use proper var class on a subref, addl fix for issue 114 (substr with replacement) when used as statement # 0.953 2022/02/17 SNOOPYJC Fix warning on @DeferredValPy, prepare perllib for release on pypi, addl fix for issue 44 with quotes, handle open with defined mode we can't translate, update _open_dynamic to handle >- which opens STDOUT, when moving a def up after the topological sort, also move up any state variable initializations, issue 118 - qx or backticks in list context, handle assignment of regex in list context with groups, update user_guide.html # 0.954 2022/02/18 SNOOPYJC Implement -n trace_run, never set scalar_reference_type to a or h # 0.955 2022/02/20 SNOOPYJC issue 120 - m flag on regex is not a new regex, fix split: A zero-width match at the beginning of EXPR never produces an empty field, issue 119 - last index of expr, issue 120 - handle foreach with reverse range, remove tight loop in fix_type_issues() if there is a missing right paren, key=>{ is not a new block, fix issue 114 substr match with expr containing a comma, fix issue where 3 or more subscripts in a variable reference in a string produces wrong code, fix issues and write test case for assigning var(s) with undef, fix issues and write test cases for lh substr, fix delete on hash with expression as key, fix issue with map function generating syntax error, fix issue with unbalanced parens generated using regex with g flag in while loop with the default variable, put defined function expr in parens, propagate global variable references down to lines that only have regex's or here-is documents to handle the case that they have global variable references in them, handle regex with char class that looks like a subscript # 0.956 2022/02/21 SNOOPYJC issue 121 - all ranges need to be expanded for maketrans, issue 122 fix tr with d flag, issue 123 - tr arguments should not be interpolated, issue 124 - Regex with DEFAULT_VAR and capturing groups needs to always set the DEFAULT_MATCH, issue 125 - implement the c flag on tr, addl fix for issue 45 return insertion found during bootstrapping, don't remove ((...)) in strings, addl fix for issue 89 keyword in {hash ref def} # 0.957 2022/02/22 SNOOPYJC Don't recognize keyword after 'no', translate the idiom to see if a var is numeric, handle hashref interpolation in strings, don't initialize variables from other packages, insert splats in lists of arrays for map/grep, addl fix for issue 124 in expression with 'not', fix grep with pattern with capturing groups # 0.958 2022/02/23 SNOOPYJC Addl fix for issue 25 - defined, don't use get() with autovivification unless at end of expr, rewrite import to deal with importing variables, convert hash to list for iteration # 0.959 2022/02/24 SNOOPYJC issue 126 - hash init generates bad code if there are exprs on the RHS, issue 127 - flatten qw references inside arrayrefs, don't use .get(...) if autovivification on for loop, issue 128 - state variable initialized to a function argument, expression or local var generates bad code, issue 129 - State variables are not interpolated into strings, merge_types: if var is init to undef, don't set it's type to like I, assignments to $@ and other special vars need to be declared global if -P flag is used - also add EVAL_ERROR to globals so we can refer to it before using eval, have ArrayHash() + or += work on empty value, don't pull ++/-- operations out of expressions - use library function instead - was causing wrong answer in updated :all computation in test.pm # 0.960 2022/02/28 SNOOPYJC Add use of pythonizer_importer.pl for use/require to continue bootstrap, handle re.E flag when we insert the substitute_element perllib call, insert return if the last line of a sub is a call of another sub, patch bootstrapping issue where perl was giving a SEGV while translating this file, fix issue bootstrapping where nested anonymous hashref initializer was generating a list/set init instead, fix issues computing types of expressions involving sort and hash keys, generate proper code for shift @ARGV, don't generate __main__() when used as hash key, always call the library for subprocess so we can check for windows, don't recognize $) as special var in regex, replace fileinput.input() call with library function so it can be called once per line (bootstrap issue), don't assume we can know the types of vars from other packages, fix adding a package name to scalar(@arr) (bootstrap issue), _translate_global call was adding an extra 'str' to the maketrans call, suppress error if black pretty-printer is not found # 0.961 2022/03/02 SNOOPYJC Implement functions for bootstrap: dclone, use open, Data::Dumper, file_name_is_absolute, catfile, extract_bracketed, addl fix for issue 37 - grep used in scalar context, handle \cX and \o{...} escapes, fix issue with tr and special chars, fix issue in d and s flags on tr, mark 'bless' as a function (not implemented yet), don't generate any code on a sub prototype, give error on unsupported \G (start at pos) in regex, Replace usage strings of the form 'Usage: filename.pl ...' with 'Usage: filename.py ...' and -U option to turn off, handle scalar context assignment in control statement, stop overwriting the source file and making .bak files unless the deprecated -r option is used, properly translate ^ (xor) operator, implement use Config; fix print $str . \n, fix push of hashref to array, issue 130 - we can never use subscript for substr because at end it gives IndexError, fix RuntimeError: dictionary keys changed during iteration on for loop, set VarType properly on for my $var (...) loops, don't mark variables as initialized if they are only conditionally initialized, remove autocommit on debug, fix the check where we use .get(...) on the last subscript only, handle hash initialized as array and sparse array assignment on LHS, convert RHS of x operator to integer, allow return stmt to be inserted if last expression of sub is array, escape 'perllib' if used as a varname, translate posix brackets in regex's properly, escape special chars in RHS of re.sub expressions, splat a @$arrref in a sub call, fix substr with a negative start pos # 0.962 2022/03/09 SNOOPYJC Hot fix for _fileinput_next - errors on Python older than v3.10 # 0.963 2022/03/09 SNOOPYJC issue bootstrap - escape '{' and '}' unless a legit repeat specifier in regex, escape keywords on last index references like $#list, don't remap /$func[:(]/ to @func_a in a regex (that's not a subscript!), fix 'defined' on regex special vars like $1, change the shebang line to something that works more universally, push hashref onto an array generated wrong code, @$arr[0] generated bad code, fix complex references to chop and chomp, don't use .get() as the first arg to a _set_element call, issue ddts: handle '}' with spaces at end # 0.964 2022/03/10 SNOOPYJC Don't mark variables as initialized if there is a conditional at the end of the statement, don't generate bad return statment if last expression of sub is an unshift, handle @1234 as a variable but give a warning, handle assignment to args and add a warning, remove re.G on a regex in a non-normal place, fix return {}, add -l flag and default to 98 (was 88), strip escape chars where not ignored by python e.g. \[, handle method call with {} in place of argument list, initialize vars that are conditionally set in an eval block, handle TYPE on my/our declarations (and ignore it), in print mysub() - mysub is NOT a file handle, $^X was calling sys.executable() instead of referencing sys.executable properly, fix eval: If no error occurs, eval sets $@ to the empty string (we were setting it to None), calling a local sub in an expression was incorrectly setting all subsequent terms to be in list context, regex (qr) variable not being handled properly when passed as arg and used in match, generate proper code for my/local/our hash or array initialization when extra parens are used around variable name. Library: Fix _init_package for package with dotted name, don't raise exceptions in -C, -A, -M, fix Array __setitem__ with slice # 0.965 2022/03/14 SNOOPYJC Added -R option to remap variables and automatically set it when we translate (or re-translate) use/require modules with cross-module conflicting names, to avoid issues with STDIN and subprocesses on windows - change pythonizer internally to open SYSIN to read the source code instead, was mapping SYSIN to stdin instead of STDIN, is a file handle - not a glob, regex in parens followed by a subscript needs to be treated as in list context, int used as hash key wasn't being converted to a str, multi-reference to hash or array with list or array index wasn't being mapped to proper index or key type, issue bootstrap: Generate proper code for delete $NeedsInitializing{$subname}{$varname}, fix some more type conversion issues, remove excess escape chars on RHS of s///, don't assume we know the types of global variables if we call an outside sub, for bootstrapping - manually parse the output of pythonizer_importer.pl, print ($var); was generating bad code, backslash escape sequences in single quoted strings were being interpolated in the output, print @_ was printing (...,...), implement OUTPUT_FIELD_SEPARATOR and OUTPUT_RECORD_SEPARATOR and always use _perl_print. BOOTSTRAPPING NOW PASSES ALL TESTS! # 0.966 2022/03/20 SNOOPYJC Don't message about translating a std lib file if we already have it translated, give warning on ref of $scalar, don't die on empty input file, issue s7 - complex expression with || messes up the nesting level, issue s9 - return list needs to return Array([list]), issue s10 - variables declared my/local/state with no init are initialized twice, add File::Spec file_name_is_absolute, catfile, rel2abs, abs2rel, issue s8 - int values passed to regex, s, or tr weren't being convered to strings, issue s11 - * bare_word being treated as typeglob, issue s12 - return from BEGIN block generating wrong code, issue s13 - $var = eval '...' wasn't handled and line with only 0 wasn't being tokenized and nested eval wasn't returning a result, addl fix to remove extra * on issue 37, issue s3 - add functions ceil, floor, trunc, round, exp, log, sin, cos - change exp(99999) to math.inf and also 9**9**9, handle open with single argument, issue s14 - $#Package::var doesn't work, issue bootstrap - substitution in a function arg generates bad code, bare word followed by a scalar or constant is not a string - it's a sub ref, handle multiple ''' on a line in eat_strings - symptom - import line wasn't being cleaned up in test_complex.py, issue bootstrap - generate the right exception name for plain next or last used in a labeled loop, issue s3 - fix syntax error from functions in complex ? : expression, remove extra parens from sprintf and defined functions, add 're' to the list of names that need to be escaped, add '.pattern' to a compiled regex variable used in another regex, if user imports a package that includes a predefined function - call that instead of ours, generate proper code for ${expr}[0], ignore the o flag on a regex, import exp, cos, and sin from a package if they are overloaded even if they are not in @EXPORT, add and use _flt() for conversions to float - like for math functions, properly splat the arguments even if the sub call is fully qualified, list of strings with an int at the end was being incorrectly typed as 'a of S', implement 'wantarray', issue s15 - handle 'a'.1234 as concat, issue s16 - named capture groups are not properly translated into python, implement select function, defined(&POSIX::_exit) was calling the function, implement kill via perllib.kill, assigning to a hashref or arrayref scalar from a {...} or [...] wasn't making the value a Hash or Array, generate proper code for substr with incr/decr included # 0.967 2022/03/31 SNOOPYJC Implement -oOutputDir, issue s24 - @X = (split /regex/, $x) generates incorrect code, issue s25 - Reserved word 'in' used as file handle in diamond operator needs to be escaped # 0.968 2022/04/02 SNOOPYJC issue s27 - 'tr' from backslash generates bad code, issue s26 - Multiple anonymous subroutines on the same line all get the same name and all but the last sub don't get a return statement automatically inserted, issue s29 - 'return' or implied return at end of anon sub in a BEGIN block generates incorrect code, issue s31: Assignment to typeglob with a variable name doesn't generate any code, issue s33: stat function doesn't work on a FILEHANDLE or DIRHANDLE and stat_cando doesn't work, issue s36 - Bareword in boolean context should not be translated as a string, issue s35: ... or do {...}; without a while/until generates an infinite loop, issue s37: Assignment to variables with /BEGIN|UNITCHECK|CHECK|INIT/ in their names generates incorrect code, issue s34: Bad code generated for my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] or next ROOT_DIR;, fix issue scanning line in PASS 1 that ends with an interpolated string with the ; on the next line, add the Cwd package, issue s38: Assigning to a hashref marked as an array with a qw containing the list of keys generates bad code # 0.969 2022/04/05 SNOOPYJC issue s39 - Having multiple statements in map {...} or grep {...} generates bad code, issue s40 - readdir in list context needs to return all of the entries, add readline function, issue s41 - Multi-variable split assignment with a bash style and/or generates syntax error code, issue s43: Multi-index of a function that returns an empty array doesn't work, issue s44 - Bash style and/or with 'next LABEL;' generates incorrect loop break, issue s45 - Turn warning off by default, issue s46 - Non-parenthesized function call with | operator isn't parsed properly, issue s47 - Map of a qw generates bad code syntax, issue s48 - When an array or hash is passed to a function that expects a number, the length needs to be passed instead # 0.970 2022/04/10 SNOOPYJC issue s4: use Config with -m doesn't work, issue s50 - next LABEL inside a do {...} generates incorrect code, causing the do to become an infinite loop, issue s30 - 'return' inside of a loop in a BEGIN block generates incorrect code, issue s49 - next OUTER loop from an inner loop that uses a 'continue' generates syntax error code # 0.971 2022/04/12 SNOOPYJC issue s19: add option to add __author__ etc, issue s51: add more functions to File::Spec, issue s53: pushing something to @_ generates an AttributeError at runtime, issue s54: implement UNIVERSAL::isa, implement File::Path, issue s57: if ref X is used in an expression that compares with HASH, SCALAR, etc then call our refs function and not ref even if a backslash isn't used, issue s55: Converting an array into an array ref using [@arr] shouldn't generate an outer array, issue s56: chdir and rmdir don't return the proper result, issue s58: Referencing a built-in sub with & generates bad code, issue s59: Don't insert _list_of_n if the RHS contains the same # of elements as the LHS, issue s52: 3-arg split generates incorrect code # 0.972 2022/04/15 SNOOPYJC issue s61: Fix bootstrapping issue with =pod code, convert and/or operands to int, don't assume everything on a 'my' statement is initialized esp if it's on the RHS of an =, assignment to array element at length of array generating wrong code after s55 fix, issue s60: if statement following a do, issue s62: DB::single should break not if debugger is not active # 0.973 2022/04/16 SNOOPYJC issue s63: Allow # pragma pythonizer to be interpreted even if -m or -M is passed, issue s64: Implement new # pragma no convert regex for bootstrap, addl fix for issue s28 - escape \x{...} to python \U after we handle \U for upper case, issue s65 - x operator always converts it's left operand to a string # 0.974 2022/04/21 SNOOPYJC issue 133: pythonizer doesn't run under Strawberry perl on windows, fix issues uncovered by test coverage, issue s66: give proper error message on non-specified or non-existing input file, issue s67: implement Getopt::Std # 0.975 2022/04/28 SNOOPYJC issue s69: Hex constant in source code generates internal warning message and gets changed to 0 # 0.976 2022/04/28 SNOOPYJC issue s68: implement strftime, issue s71: Getopt:Std getopt generates wrong code if -M is active, issue s73: Multi-line q/.../ with line that starts with # is NOT a comment line, issue s72: new CGI generates a string instead of a method call, issue s74: Interesting perl module $VERSION calculation line generates wrong code # 0.977 2022/04/29 SNOOPYJC issue s82: Pythonizing a file that uses require can generate strange error messages # 0.978 2022/05/12 SNOOPYJC Fix issue with extra stuff printed in -h, issue s81: Regex \Z( being translated as $( special variable, issue s83: Nested sub at top level generating nonlocal statement instead of global, issue s84: Nested sub that changes its arglist (via shift, etc) doesnt properly copy the arglist to a list, issue s76: Assignment to a typeglob ref of an anonymous function doesnt work, issue s86: If a perl script mentions its own filename, it should be pythonized to the python filename, issue s87: If a perl script executes another perl script via a file path, optionally replace that with the pythonized version, issue s77: push containing a || doesnt work, issue s85: document that single dash long options do not work, issue s88: Anonymous hashes containing a single array generate incorrect code, issue s89: eval containing only close() generates 2 close() calls, issue s75: for(each) loop with multiple list items doesnt work, fix issues in new test_splat.pl, issue s90: Reference to unset %ENV variable gives KeyError in python version # 0.979 2022/07/02 SNOOPYJC issue s91: open with a dynamic single argument that does not contain a mode returns None on error instead of a closed file (fix in perllib _open_dynamic) # 0.980 2022/07/28 SNOOPYJC Additional fix for issue 133 - make_path not found if log dir is not present # 0.981 2022/08/02 SNOOPYJC issue s92: while(defined(magic function)) generates incorrect code, issue s93: Setting array last index as the only reference doesn't generate code to initialize the array # 0.982 2022/09/02 SNOOPYJC issue s95: local hash generates Array, issue s97: handle slurp mode in do statement, issue s96: TypeError in complex ? : expression # 0.983 2022/09/04 SNOOPYJC Additional fix for issue s87 with variable interpolation # 0.984 2022/09/08 SNOOPYJC issue s98: missing type conversion for hash values # 0.985 2022/09/08 SNOOPYJC issue s99: If you have more formats than items, you get an error in python but not perl - fix in _format_ # 0.986 2022/09/09 SNOOPYJC issue s100: for(each) variable is local to the loop and the value should revert back after the loop, don't lose comment at end of for loop line # 0.987 2022/09/14 SNOOPYJC issue s101: missing global for file handle across subs # 0.988 2022/09/15 SNOOPYJC issue s102: NoneType has no attribute keys when fetching hash from empty data structure, also implicit return statement is not applying the package name on -M option # 0.989 2022/09/15 SNOOPYJC additional fix for issue s100: use 'local' unless variable is explicitly declared using 'my' # 0.990 2022/09/22 SNOOPYJC issue s103: referencing the default variable without setting it causes an error # 0.991 2022/09/23 SNOOPYJC issue s104: Don't assume the default variable is a string # 0.992 2022/09/24 SNOOPYJC issue s105: newline at end of filename gets stripped by perl, issue s106: undefined variable on local foreach loop counters # 0.993 2022/09/26 SNOOPYJC issue s107: error referencing missing hash of hashes in a string # 0.994 2022/09/29 SNOOPYJC issue s94: unlink or die generates incorrect code, issue s108: for(each) variable is local to the loop and the value should revert back after the loop even if foreach statement is on multiple lines, issue s109: Subref dereference generates syntax error code, issue s110: Scope of 'my' should not be extended below for/while loop # 1.001 2022/10/01 SNOOPYJC issue s76: function templates don't work properly, issue s111: for loop that counts down to 1 is not translated correctly, issue s112: string containing only '.pl' should not be changed to '.py', issue 133 bootstrap: add tmpdir function, issue s113: invalid code generated for some OO function calls, issue s114: improper interpretation of interpolated string leads to bad code in next sub, issue s115: regex substitution of literal escape chars interprets them instead # 1.002 2022/10/11 SNOOPYJC issue s78: sort with complex {...} doesn't work properly, issue s118: Split of the result of a command execution never runs the command, issue s116: Regex substitution raises exception on undef arg, issue s117: Referencing an undefined variable in an interpolated string should give an empty string, not 'None', issue s119: Sparse extraction from array doesn't give proper results # 1.003 2022/10/17 SNOOPYJC issue s120: Interpolate array reference in double-quoted string with subscript the same way perl does, issue s121: localtime, gmtime, and timelocal shouldn't raise exceptions # 1.004 2022/10/19 SNOOPYJC issue s122: IO encoding shouldn't default to UTF-8, issue s123: Integer hash keys are not being converted to string type in interpolated string references # 1.005 2022/10/21 SNOOPYJC Additional fix for issue s123 if using -P option, issue s124: Boolean values should print or convert to strings as 1 or '', not True/False, issue s125: \xH doesn't generate proper python code, issue s126: naming variables starting with _ can conflict with pythonizer function names, don't include 'return' in the LHS of <=> or cmp operator # 1.006 2022/10/23 SNOOPYJC More fixes for issue s79, addl fix for issue s126 when using pythonizer with an old perl # 1.007 2022/10/24 SNOOPYJC issue s79: Use of uninitialized value $prev_line in rindex at ../pythonizer/pythonizer line, more fixes for issue s102 # 1.008 2022/10/26 SNOOPYJC issue s80: substr outside of string at ../pythonizer line, issue s127: To make the output of repeated pythonizer runs the same, sort globals, imports, and initializations, issue s130: Flatten the RHS of a list assignment, issue s131: Match capture variables are not set on a substitute # 1.009 2022/10/31 SNOOPYJC issue s128: Implement FindBin and readlink, fix import for modules that begin with a POD, issue s129: Implement switch/case and given/when, issue s20: Begin to write some error tests # 1.010 2022/11/03 SNOOPYJC issue s133: use lib with FindBin needs to handle at pythonizer time, issue s132: add -V option and change existing -V option to -N # 1.011 2022/11/03 SNOOPYJC issue s135: grep expression with substitute and/or angle brackets glob does not work, issue s136: for loop with ++ctr at the end generates bad code, issue s137: default variable regex in && expression doesn't work and foreach scalar generates bad code and last in do generates bad code, issue s138: Split on '\|' doesn't work properly # 1.012 2022/11/07 SNOOPYJC issue s140: $* doesn't work, issue s141: Naming a sub 'main' fails to pythonize properly, issue s142: Autovivification doesn't work on @ARGV, also fix range assignment for @ARGV, issue s143: Complex hash assignment with regex substitute generates incorrect code, issue s144: my statement with a comma-separated list of initializations generates bad code, issue s145: complex nested hash/array initialization fails translation, issue s146: for loop that starts by incrementing the loop counter is not handled, issue s147: multiple do{...} until(...) with nested trailing 'if' does not translate properly, issue s148: chomp/chop on an array element or hash value fails to translate, issue s149: multi-line q string with blank lines doesn't translate properly, issue s150: GetOptions or die generates bad code, other fixes to GetOptions to handle -option and check for invalid options, issue s139: Multiple '}' on the same line not being recognized as block close # 1.013 2022/11/14 SNOOPYJC issue s151: = ~ with extra space generates syntax error code, issue s152: missing ';' on require should execute next line if it starts with an '&' operator, issue s153: grep ! /pattern/ generates bad code, issue s155: nested BEGIN block generates bad code, issue s156: => in if statement generates bad code, issue s157: Multi-array assignment generates bad code, issue s158: ++ in comma expression in or clause generates bad code, issue s159: grep regex generates bad code, issue s160: Assignment to @hash{@keys} generates bad code, issue s154: implement tie, issue s162: file size operation can generate incorrect code, issue s163: Simple sort generating bad code, issue s164: Passing a -pragma on a use statement is not translated correctly, issue s165: Bogus pattern match operation generates TypeError in python, issue s168: Calls to undefined subroutines without parens should not be generated as strings, issue s166: open(COPY, '>&HANDLE') does not generate proper code, issue s167: 1 while chomp; generates incorrect code, issue s169: Bogus reference to scalar warnings on array and hash references, also add # pragma pythonizer verbose, issue s170: break outside of a given block should raise an exception, not generate a syntax error, issue s171: Deleting multiple hash entries using an array undef generates bad code, generate warning messages for missing use/require modules, issue s172: Use of both variable and variable_a causes initialized error in pythonizer, add more error tests and fix error on % in GetOptions and fix version check on use/require # 1.014 2022/11/24 SNOOPYJC issue s173: File::Path functions need an empty array passed for the error => $err parameter # 1.015 2022/11/26 SNOOPYJC issue s174: The .. (range) operator should be supported in initializations, issue s175: tie should be allowed to take a bareword package name, issue s180: Implement can method for packages and blessed classes, issue s176: References to variables with variable names including a package name are not properly translated, issue s177: The import function should be called in the translation of use statements, issue s178: Reference to CORE::print is not translated properly, issue s179: Conditional eval/getops/substitute with e flag generates bad code, issue s20: added remaining error tests, issue s182: do statement with for(each) statement modifier generates bad code, issue s183: Calling binmode on a sub argument generates bad code, add openhandle function # 1.016 2022/11/30 SNOOPYJC issue s184: Implement subs with scalar out parameters, issue s183: Allow _perl_print to write to binary files to support binmode, fix autoflush with binmode, some pattern references were incorrectly being marked as to requiring the default varible ($_ or _d in Python) when they didn't actually reference it # 1.017 2022/12/04 SNOOPYJC issue s186: Eliminate bogus warnings when calling external subs in package main, issue s187: use MODULE (); should not call the import method, issue s188: Handle \*main::STDIN and \*STDIN as alternates to STDIN # 1.018 2022/12/05 SNOOPYJC issue s185: Implement subs with scalar reference out parameters, issue s191: Passing a hash to a sub should send the keys and values, issue s192: Reference to a prior match capture group in a non-capturing match generates bad code, issue s190: Local sub should not override the CORE function unless use subs is specified, addl fix for issue s184 with array or hash args, issue s194: map with a ? : conditional array generates bad code, issue s195: Naming a variable $caller generates incorrect code, issue s196: Pattern match in ? : operation generates bad code, issue s197: Complex ? : with defined and split generates bad code, issue s198: Array or hash in local declaration list in a sub should consume the rest of the RHS, issue s200: Naming variables the same as python imported packages causes problems, issue s201: Method call with expanded hash generates bad code, issue s202: [arrayfunc()] incorrectly generates an array with an array in it, issue s203: $self->PACKAGE::subname(...) generates incorrect code, issue s204: Complex double ? : operation generates bad code # 1.019 2022/12/10 SNOOPYJC issue s205: complex method call with -barewords generates bad code, issue s206: string range in definition generates bad code, test GPT regex - assume any variable in a regex can contain groups, addl fix for issue s131 with unbalanced ( in RHS, issue s207: Bless with || generates incorrect code, addl fix for issue s124 with a regex, addl fix for issue s144 on local, issue scalar ref: handle ref function properly on scalars, issue s208: Method call with multiple shift operators isn't being translated properly, issue s209: Multiple packages in the same file with names that have the same prefix causes errors on global variable initialization, issue s210: Calling a sub stored in a hash generates incorrect code # 1.020 2022/12/20 SNOOPYJC issue s211: create link from PACKAGE.py to PACKAGE/__init__.py if PACKAGE is a directory, addl fix for issue s177 with -nph=>':standard', issue s212: shift->{key} generates bad code, additional fix for issue s155 to generate proper results from nested subs, handle nested packages, and also handle code after the nested sub definition, issue s18: implement use package, issue s213: Constant hashref dereference generates bad code, implement fallback on use overload, implement PerlIO::get_layers(fh), issue s214: Function templates don't work in blessed classes or packages with an ISA parent, issue s216: tie class methods need to be set on a subclass of the class instance, not on the class, issue s215: if(keys %$leftover) incorrectly raises an exception if $leftover is undef, addl fix for issue s154 on sub import, issue s218: Return with ||= generates bad code (and object comparison is broken), issue s220: In a sub, unshift(@_, ...) gives a TypeError: 'tuple' object does not support item assignment, issue s217: Array assignment in foreach loop generates bad code # 1.021 2022/12/28 SNOOPYJC issue s223: Converting a $class to a string and also ref $class gives incorrect result, issue s221: Hash keys with -X are incorrectly being translated as file test operations, issue s222: $#$order gives an incorrect value if $order is a my variable in a sub, issue s224: for loop on an undefined scalar with ? : should loop once, issue s227: Brackets not being escaped in interpolated string that almost looks like a hash index, issue s225: require statement in a sub for a translated standard package doesn't work properly, issue s228: hash initialization with ? : condition generates bad code, issue s226: wantarray: Returns the undefined value if the context is looking for no value (void context) - implement this, issue s219: eval {...} if ... generates bad code, issue s230: Simple pattern match that generates .find() gives bad code, also .find can't be directly used if the pattern contains an anchor, and escape characters like '\.' need to be removed from find patterns, issue s232: Hash slice assignment to list of vars generates bad code, issue s229: goto &$subname if defined &$subname generates bad code, issue s231: implement do EXPR, issue s233 - Defining my own sub croak causes infinite recursion if it calls Carp::croak, issue s234: substr($s, -2, 1) gives incorrect result, implement utf8:: functions, implement blessed, fix use parent with '-norequire' as string, addl fix for issue s203 to create proper MethodClass methods for subclasses, issue s236: Method calls via a scalar containing a string give an AttributeError, add builtins (blessed, ceil, floor), fix Pythonizer.pm warning on my ($staticDir, $destDir) = (@_);, issue s235: Syntax error in generated code $selected{$_}++ for $self->param($name); # 1.022 2023/01/06 SNOOPYJC issue s238: use overload '<=>' and 'cmp' are not respected, test overload methods: Add overload::StrVal, overload::Overloaded, overload::Method, test list util: Add List::Util, issue s237: implement logical xor operator, issue s239: passing an anonymous sub as a sub arg generates bad code if the anonymous sub ends with an assignment statement, issue s240: Implement some \p and \P in regex, issue s241: (partial fix): Wantarray and other sub options need to be inherited, nested sub levels not properly maintained, issue s249: multiple globs in one line are not handled, globs need splats, and @{[scalar @$right]} needs to change the scalar value into an array, issue s250: keys %{ ...} being translated as a mod operator, issue s243: eval with nested sub generates bad python code with syntax error, issue s246: Mod (%) operator mistaken as a hash name, issue s244: Use of struct generates code with syntax error, issue s251: Implement smartmatch (~~) operator # 1.023 2023/01/18 SNOOPYJC test reverse: fix issue reversing a number, issue s241: Wantarray and other sub options need to be inherited, nested sub levels not properly maintained, issue s247: implement exec, fix exists on array element, issue s253: given/when doesn't work for objects that overload the smartmatch (~~) operator, issue s254: Empty list in scalar context should be changed to undef, issue s255: join with ? : to determine the join char generates bad code, issue s252: If a for(each) loop modifies the loop counter, that modification needs to update the array being iterated, issue s256: complex ? : expression with wantarray and grep generates bad code, issue s257: .= operator with || generates incorrect code, issue s258: use Package qw/function.../ needs to import the function into the local package's namespace, issue s259: caller() doesn't return the proper package name # 1.024 2023/01/30 SNOOPYJC issue s260: fix _caller and _callers, addl fixes for issue s244, issue s261: Assignment to arrayref and hashref changes the location of the object so the original object is not updated, implement Text::ParseWords and Class::Struct, issue s263: sub that has an if(/else) and ends with a for loop returns early, issue s264: incorrect int conversion of hashref in array subscript, issue s265: use XXX in a sub, where XXX defines an import sub generates code with a bad indent, issue s266: Bless with => instead of , generates bad code, issue s267: Regex pattern [\s\-_] should not be turned into a range, issue s268: shift->method(...) generates bad code # 1.025 2023/02/05 SNOOPYJC issue s70: Malformed UTF-8 character (fatal) at ../pythonizer/Pythonizer.pm, plus add -e flag and change how ord/chr work for non-utf8 encodings, issue s269: Naming a package 'bytes' should generate an escaped name, implement Encode, Encode::Encoding, Encode::MIME::Name, CGI, CGI::Cookie, CGI::Util, CGI::File::Temp, issue s272: Conditional $DB::single assignment generates unconditional call to pdb # 1.026 2023/02/10 SNOOPYJC implement use English and use integer, issue s273: Multi-assignment to an arrayref and a list of scalars generates bad code, issue s274: $+ without a subscript should give the $LAST_PAREN_MATCH. Implement Time::localtime and Time::tm. Retranslate Math::Complex and fix Pythonizer issues found. Implement Time::HiRes, issue s275: Global variable in package sometimes incorrectly replaced with loop-local variable, issue s276: Getting a reference to a function generates incorrect code # 1.027 2023/02/16 SNOOPYJC issue s281: UNIVERSAL::isa(\*FH,'GLOB') should return 1, issue s286: Regex with m flag gives different results in perl vs python, issue s285: Use of uninitialized value $ValClass[1] in string eq at ../pythonizer, issue s282: Implement $^S, addl fix for issue s252 - update the var type on functions with out parameters, issue s278: Any multi-line statement as the last statement of a sub causes bad code to be generated, issue s283: Bad code generated for CORE::die(@_), issue s291: Pushing to @ARGV doesn't work properly, issue s288: warn doesn't work like perl, issue s277: If a signal handler is more than 1 line, bad code is generated, issue s293: goto &mySub inside an anonymous sub gives a Pythonizer error message, issue s295: (backtick)script.py(backtick) on windows will launch an editor if that's the associated program, issue s292: die doesn't work like perl, issue s289: Setting *CORE::GLOBAL::func doesn't do anything, issue s298: Setting an environment variable to an integer causes an exception, issue s279: grep thru multiple arrays generates bad code, issue s280: Explicitly calling Exporter::import doesn't work, issue s300: Subs that start with an '_' and the name is the same as a perllib function causes bad code to be generated, issue s299: foreach as statement modifier with a , expression generates bad code, issue s297: $? ($CHILD_ERROR) is not set properly, issue s296: Create environment variables to set perllib.TRACEBACK, perllib.AUTODIE, perllib.TRACE_RUN, perllib.WARNING, issue s294: -y option (replace run) should also work in qw/lists.pl of.pl perl.pl scripts.pl/, issue s292: die doesn't work like perl, issue s290: assert statement with side-effect generates assert that's always True, issue s284: Add an option to make all calls via the full qualified sub name, issue s262: map that updates a variable in the function generates incorrect code # 1.028 2023/02/24 SNOOPYJC issue s287: implement isa operator, issue s301: Implement tie scalar, Implement use Env, issue s302: Goatse idiom to count the # of matches generates bad code, issue s303: Need to use os.environ.get(...) on fetch from $ENV{...}, not os.environ[...], issue s304: If a file implements multiple packages with different tie operations, the wrong FETCH/STORE will be called, issue s306: If a function has a replacement in scalar context, it shouldn't be replaced if it's being indexed, issue s305: Calling keys (or values) on a hash should reset the 'each' iterator # 1.029 2023/03/03 SNOOPYJC issue s312: Use of uninitialized value $Pythonizer::ValClass[2] in string eq at ../../Pythonizer.pm line 4935, issue s313: LINE XXXX [Perlscan-S5363]: Unterminated string starting at line YYYY, issue s310: LINE XXXX [main-W6814]: Update to $_ alias of foreach items will not modify list items, issue s309: LINE XXX [Pythonizer-W2556]: Cannot get function type for _reset_each (_reset_each in python), issue s307: implement another form of range (..) operator, issue s308: Use of uninitialized value within @Pythonizer::ValClass in string eq at ../../Pythonizer.pm and also remove flatten in lists and replace with splats and calls to new _sl lambda function, issue s311: Use of uninitialized value within @ValClass in string eq at pythonizer, issue s314: Call via $subref->() in interpolated string generates incorrect code, issue s315: push with grep generates bad code, issue s316: Hash being initialized from some hash keys/values and also another hashref generates bad code, issue s317: Complex method call generates bad code, issue s318: eval {...} if... generates bad code, issue s319: tie with package name containing :: generates bad code, issue s320: Defining a sub with a fully qualified package name generates bad code, issue s321: Hash slice on LHS with @$aref generates bad code, issue s323: UnboundLocalError: local variable '_m' referenced before assignment, issue s324: Calling a method via a variable generates bad code, issue s326: Hashref interpolated into string generates bad code, issue s327: List with hashes generates bad code, issue s330: Implement use overload int, issue s331: Change errors for use overload ++ / -- to warnings, issue s332: Implement use warnings FATAL => qw(numeric);, issue s329: $var = eval {...} or $^W && warn $@; generates bad code, issue s334: Bad code is generated for complex ++ operation, some partial fixes for issue s328 # 1.030 2023/03/27 SNOOPYJC issue_s335: $( and $) give errors in the generated code on unix, issue s337: Fix issues in Time::HiRes on unix, issue s336: Assigning a string to a signal handler generates incorrect code unless the string is IGNORE or DEFAULT, issue s338: Use of uninitialized value $class in string eq at ../../Pythonizer.pm line 2171 caused by @+ not being recognized, issue s339 - Use of uninitialized value in string eq at ../../Perlscan.pm line 9614 causes by @{... \n} not being recognized and @ISA = ... also not being recognized, issue s340: Substitute in elsif generates bad code, issue s341: Bogus [Perlscan-S5450]: Unterminated string starting at line XX, issue s345: Diamond operator with python keyword as file handle generates bad code, issue s344: Simple regex substitute generates bad code, issue s342: %+ hash is not available, issue s343: The number of generated chunk exceeed 2048, issue s346: Array to Hash map idiom generates bad code, issue s347: Converting a class object to a string should change '.' to '::', issue s348: Copies of @_ need to be autovivified, issue s349: Initializing a %hash with a qw(...) causes it to be an array, issue s350: Handle dynamic require statement in eval, issue s351: sort that looks like a sub call generates incorrect code, issue s352: Pattern match with variable sub-pattern doesn't create the match variable, issue s353: Methods with multiple out parameters are not properly handled, issue s354: defined on an arrayref gives error on get operation, issue s355: undef being interpolated in string as None instead of '' if coming from arrayref or hashref, issue s356: Conditionally assigned arrayref is being incorrectly initialized to an empty array instead of undef, issue s357: A conditional IO::File open fails as it calls open_ instead, issue s358: Bad code generated for ' 'x$pad operation, issue s359: referencing an array element that doesn't exist shouldn't create it, issue s360: Subpackage with the same name as any parent package causes the module to overwrite the parent namespace, issue s361: Symbolic reference not generating proper code, issue s362: C-style for loop with ++j may generate bad code, issue s363: Pattern style range operator no longer works if a simple string pattern is used #!start =============================================================================================================================== use v5.10.1; use warnings; use strict 'subs'; use feature 'state'; use Carp 'verbose'; # SNOOPYJC use File::Basename; # SNOOPYJC use File::Spec::Functions qw(file_name_is_absolute catfile rel2abs tmpdir); # SNOOPYJC, issue 133 use Data::Dumper; # SNOOPYJC use Storable qw(dclone); # issue s3 $SIG{ __DIE__ } = sub { Carp::confess( @_ ) }; # SNOOPYJC $SIG{ INT } = sub { Carp::confess( @_ ) }; # SNOOPYJC # $SIG{ __WARN__ } = sub { Carp::confess( @_ ) }; # SNOOPYJC $| = 1; # SNOOPYJC - unbuffer STDOUT BEGIN { # SNOOPYJC use Config; unshift @INC, dirname(__FILE__); if(exists $ENV{PERL5PATH}) { my $sep = $Config{path_sep}; $ENV{PERL5PATH} .= $sep . dirname(__FILE__); } else { $ENV{PERL5PATH} = dirname(__FILE__); } } use Pyconfig; # issue 32 # # Modules used ( from the current directory to make debugging more convenient; will change later) # use Softpano qw(autocommit abend banner logme summary out); use Perlscan ('gen_statement', 'tokenize', 'gen_chunk', 'append', 'replace', 'insert', 'destroy', 'autoincrement_fix', '@ValClass', '@ValPerl', '@ValPy', '@ValCom', 'escape_keywords', # issue 41 'unescape_keywords', # issue s18 'save_code', 'restore_code', # issue 74 'ok_to_break_line', # issue s228 '%SpecialVarsUsed', # SNOOPYJC '%SpecialVarR2L', # SNOOPYJC '@EndBlocks', # SNOOPYJC '@BeginBlocks', # issue s155 '@CheckBlocks', # issue s155 '@InitBlocks', # issue s155 '@UnitCheckBlocks', # issue s155 'special_code_block_name', # issue s155 'get_sub_vars_with_class', # issue 78 'add_package_to_mapped_name', # issue import vars '%FileHandles', # SNOOPYJC '%FuncType', # SNOOPYJC '%PyFuncType', # SNOOPYJC '%UseRequireOptionsPassed', # issue names '%UseRequireOptionsDesired', # issue names 'mapped_name', # issue names '%UseSwitch', # issue s129 'handle_block_scope_pragma', # use integer, use English '@ValType', '$TokenStr'); use Pythonizer qw(correct_nest getline prolog output_line %LocalSub %PotentialSub %GlobalVar %VarType %InitVar init_val matching_br reverse_matching_br next_matching_token last_matching_token next_matching_tokens next_same_level_token next_same_level_tokens next_lower_or_equal_precedent_token fix_scalar_context %SubAttributes %Packages @Packages arg_type_from_pos in_sub_call end_of_function new_anonymous_sub save_nest restore_nest for_loop_uses_default_var get_sub_attribute get_sub_attribute_at set_sub_attribute clone_sub_attributes debug_start_end); # SNOOPYJC $VERSION='1.030'; $SCRIPT_NAME='pythonizer'; # # options # $breakpoint=9999; # line from which to debug code. See Pythonizer user guide $debug=0; # 0 -- production mode # 1 -- testing mode # 2 -- first pass debugging # 3 -- provides tracing during the second pass (useful for users for trableshooing infinite loops) # 4 -- stop at Perlscan.pm # 5 -- stop at particular error message. # 6 -- also trace all calls to getline() $traceback=0; # SNOOPYJC -T option $autodie=0; # SNOOPYJC -A option $implicit_global_my=0; # SNOOPYJC -m option $pythonize_standard_library=0; # SNOOPYJC -s option $import_perllib=1; # SNOOPYJC -p option, -P turns it off $autovivification=1; # SNOOPYJC -N turns this option off $replace_usage=1; # SNOOPYJC -u/-U option $replace_run=1; # issue s87 -y/-Y option $fully_qualify_calls=undef; # issue s284: is set to 0 or 1 in &Pythonizer::prolog, based on $implicit_global_my $trace_run=0; # SNOOPYJC -n option $black=1; # SNOOPYJC -k option $black_line_length=98; # SNOOPYJC -l option $remap_all=0; # SNOOPYJC -R:all option $remap_global=1; # SNOOPYJC -R:global option %remap_requests=(); # SNOOPYJC -R $var1,@var2,%var3,*var4,... - set $output_dir=undef; # issue s23 $gen_author=0; # issue s19 $HOME=$ENV{'HOME'}; # the directory used for autobackup (only if debug>0) if( $^O eq 'cygwin' ){ # $^O is built-in Perl Variable that contains OS name $HOME="/cygdrive/f/_Scripts"; # CygWin development mode -- the directory used for backups } # # Local dictionaries # # SNOOPYJC %PyOpen=('<'=>'r', '>'=>'w', '>>'=>'a', '+<'=>'+'); %PyOpen=('<'=>'r', '>'=>'w', '>>'=>'a', '+<'=>'r+', '+>'=>'w+', '+>>'=>'a+', '->'=>'->', '<-'=>'<-', '-|'=>'-|', '|-'=>'|-', '|'=>'|-', ''=>'r'); # SNOOPYJC @UseLib=(); # SNOOPYJC: Paths added using "use lib" %Pyf=(); # SNOOPYJC: Keeps track of which extra functions we need to include at the end $Pyf_dir = dirname(__FILE__)."/pyf"; # SNOOPYJC: Where we keep the extra python functions $saved_eval_tokens = undef; # issue 42 @saved_eval_buffer = (); # issue 42 @saved_eval_BufferValClass = (); # issue s179 $saved_eval_token_buffer_active = 0; # issue s179 $saved_eval_lno = undef; # issue 42 %nested_subs = (); # issue 78: map from nested sub name to arglist %aliased_foreach_subs = (); # issue s252 %aliased_foreach_return = (); # issue s252 $deferred_nesting_top = undef; # issue s252 $nested_sub_at_level = -1; # issue 78 @nested_sub_at_levels = (); # issue s241: All current levels that have an active nested sub $saved_sub_tokens = undef; @saved_sub_tokens_stack = (); # issue s311 @saved_sub_tokens_level = (); # issue s311 # issue 133 $LOG_DIR='/tmp/'.ucfirst($SCRIPT_NAME); $LOG_DIR=catfile(tmpdir(), ucfirst($SCRIPT_NAME)); # issue 133 # issue 64 banner($LOG_DIR,$SCRIPT_NAME,"Fuzzy translator of Python to Perl. Version $VERSION",30); # Opens SYSLOG and print STDERRs banner; parameter 4 is log retention period # issue 55 prolog(); # sets all options, including breakpoint prolog(dirname(__FILE__), $LOG_DIR,$SCRIPT_NAME,"Translator of Python to Perl. Version $VERSION",30); # issue 55, issue 64 # sets all options, including breakpoint $EVAL_ERROR = $Perlscan::SPECIAL_VAR{'@'}; # SNOOPYJC: EVAL_ERROR or perllib.EVAL_ERROR $EXCEPTIONS_BEING_CAUGHT = $Perlscan::SPECIAL_VAR2{'S'}; # issue s282: EXCEPTIONS_BEING_CAUGHT or perllib.EXCEPTIONS_BEING_CAUGHT $processing_closing_bracket = 0; # issue s325: See &Perlscan::in_starting_BEGIN for use of this push @UseLib, dirname($Pythonizer::fname); # SNOOPYJC: Always good to look here! correct_nest(0, 0); # SNOOPYJC # if( $debug > 0 ){ #autocommit("$HOME/Archive",$ENV{'PERL5LIB'},qw(Softpano.pm Perlscan.pm Pythonizer.pm)); #} %Constants=(); # issue 13: Keeps track of constants declared in "use constant" and also file handles #@Constants{keys %CONSTANT_MAP} = values %CONSTANT_MAP; # SNOOPYJC @Constants{values %CONSTANT_MAP} = values %CONSTANT_MAP; # SNOOPYJC $modules_path_added = 0; # SNOOPYJC $uses_file_stat = 0; # SNOOPYJC $uses_english = 0; # use English $uses_integer = 0; # use integer $set_initial_package = 0; # SNOOPYJC if(!%Packages) { # SNOOPYJC $Packages{$DEFAULT_PACKAGE} = 1 unless($implicit_global_my); } $saved_eval_tokens = undef; # issue 42 @saved_eval_buffer = (); # issue 42 @saved_eval_BufferValClass = (); # issue s179 $saved_eval_token_buffer_active = 0; # issue s179 $saved_eval_lno = undef; # issue 42 $saved_sub_tokens = undef; $nested_sub_at_level = -1; # issue 78 @nested_sub_at_levels = (); # issue s241: All current levels that have an active nested sub $saved_sub_tokens = undef; @saved_sub_tokens_stack = (); # issue s311 @saved_sub_tokens_level = (); # issue s311 $split_multiple_assignment = undef; # issue 115 $gen_open_data = 0; # SNOOPYJC %foreach_modified_counter_assignment_map = (); # issue s252: lno=>python code $skip_bash_style_or_and_fix = 0; # issue s329 # issue s49 $continue_needed_try_block = 0; # issue continue # # Skip initial block of comments # $TrStatus=0; # issue stdin chomp($line=<>); # we need to discard the first line with /usr/bin/perl as interpreter $line=; # issue stdin: we need to discard the first line with /usr/bin/perl as interpreter chomp($line) if(defined $line); # issue empty file # SNOOPYJC: We don't need '-u' anymore: output_line('','#!/usr/bin/python3 -u'); # put a proper line # issue bootstrap output_line('','#!/usr/bin/python3'); # SNOOPYJC: We implemented autoflush, so we don't need '-u': put a proper line output_line('',"$SHEBANG"); # issue bootstrap if($Pythonizer::f_encoding) { # issue s70 output_line('', "# -*- coding: $Pythonizer::f_encoding -*-"); # issue s70 } # issue s70 my $user = $ENV{LOGNAME} || $ENV{USERNAME} || $ENV{USER}; # SNOOPYJC $user = 'SNOOPYJC' if $gen_author; # SNOOPYJC $rb_user = " run by $user" if($user); # SNOOPYJC my $us = basename($0); # SNOOPYJC my $comment = "# Generated by \"$us @Pythonizer::orig_ARGV\" v$VERSION$rb_user on ".localtime(); # SNOOPYJC output_line('', $comment); # SNOOPYJC if(@Pass0::implied_options) { output_line('', "# Implied $us options: " . join(' ', @Pass0::implied_options)); } if($gen_author) { # issue s19 my $dir = dirname(__FILE__); open(AUTH, "<", "$dir/$AUTHORS_FILE"); while() { if(/^\* (.*) <(.*@.*)>/) { $author = $1; $email = $2; } } output_line('', '__author__ = """' . $author . '"""'); output_line('', "__email__ = '$email'"); output_line('', "__version__ = '$VERSION'"); } if (defined $line && $line =~ /^\s*#!/){ $line=getline(); # skip previous interpreter definition and get the first meaningful line + initial block of comments, if present }else{ getline($line) if(defined $line); # put the first line in the readline buffer $line=getline(); # rescan it to have full proper processing } # issue flock foreach $l ('import sys,os,re','import fileinput,subprocess,inspect'){ $Die = "class Die(Exception): pass"; if($traceback) { # Note: The code in &Pythonizer::cleanup_imports needs to know how many lines we have in this definition (see $dif_def_lno) $Die = "class Die(Exception): def __init__(self, *args,suppress_traceback=None): super().__init__(*args) if TRACEBACK and not suppress_traceback: _cluck()"; $Pyf{_cluck} = 1; $Pyf{_longmess} = 1; } $Die = "from $PERLLIB import Die" if($import_perllib); # NOTE: This import line gets rewritten in Pythonizer.pm (pick & choose that is)! my @headers = ("import sys,os,re,fcntl,math,fileinput,subprocess,collections.abc,argparse,glob,warnings,inspect,functools,itertools,signal,traceback,io,tempfile,atexit,calendar,types,random,stat,dataclasses,builtins,codecs,struct,$PERLLIB,copy,getopt,abc", 'import time as tm_py', # SNOOPYJC "_bn = lambda s: '' if s is None else s", # issue s117 "_pb = lambda b: 1 if b else ''", # issue s124 "_sl = lambda r: [r] if isinstance(r, str) or hasattr(r, '__PACKAGE__') or not hasattr(r, '__iter__') else r", # issue s308 "_str = lambda s: '' if s is None else str(s)", # SNOOPYJC ); foreach my $g (keys %GLOBALS) { # SNOOPYJC if($import_perllib) { if($g eq 'TRACEBACK' && $traceback) { push @headers, "$PERLLIB.$g = 1"; } elsif($g eq 'TRACE_RUN' && $trace_run) { push @headers, "$PERLLIB.$g = 1"; } elsif($g eq 'AUTODIE' && $autodie) { push @headers, "$PERLLIB.$g = 1"; } elsif($g =~ /^_[a-z]/) { # e.g. _locals_stack push @headers, "$g = $GLOBALS{$g}"; } } else { if($g eq 'TRACEBACK' && $traceback) { push @headers, "$g = 1"; } elsif($g eq 'TRACE_RUN' && $trace_run) { push @headers, "$g = 1"; } elsif($g eq 'AUTODIE' && $autodie) { push @headers, "$g = 1"; } else { push @headers, "$g = $GLOBALS{$g}"; } } } my @more_headers = ("$Die", "class $EVAL_RETURN_EXCEPTION(Exception):\n pass"); # SNOOPYJC if($Perlscan::uses_function_return_exception) { push @more_headers, "class $FUNCTION_RETURN_EXCEPTION(Exception):\n pass"; # SNOOPYJC } for my $label (sort keys %Perlscan::all_labels) { # issue 94, issue s127 my $ex_name = label_exception_name($label); push @more_headers, "class $ex_name(Exception):\n pass"; } push @headers, @more_headers; # SNOOPYJC # # SNOOPYJC: Define any variables that just appear out of nowhere in perl, like $option{key} = 1 creates %options # #if(exists $InitVar{main}) { # push @headers, $InitVar{main}; #} # issue 24 my $last_header = "$PERL_ARG_ARRAY = sys.argv[1:]"; # SNOOPYJC - must be last!! my $last_header = "pass # LAST_HEADER"; # issue 24 - must be last!! push @headers, $last_header; # SNOOPYJC: Post-processor in Pythonizer.pm relies on this one being last foreach $l (@headers) { # SNOOPYJC output_line('',$l); # to block reproducing the first source line } # issue s18 my $package_sort = sub { # issue s209: Put 'main' first # issue s18 my $aye = $a eq 'main' ? '0' : $a; # issue s18 my $bee = $b eq 'main' ? '0' : $b; # issue s18 if(exists $SpecialVarsUsed{'bless'}) { # issue s18: Put base classes before subclasses # issue s18 if($SpecialVarsUsed{'bless'}{$a}) { # issue s18 my $key = $a . '.ISA'; # issue s18 if(exists $SpecialVarsUsed{$key}) { # issue s18 $isa = $SpecialVarsUsed{$key}{__main__}; # issue s18 $isa =~ s/\.split\(\)$//; # issue s18 $isa = unquote_string($isa); # issue s18 for my $parent (split ' ', $isa) { # issue s18 return 1 if($parent eq $b); # issue s18 } # issue s18 } # issue s18 } # issue s18 if($SpecialVarsUsed{'bless'}{$b}) { # issue s18 my $key = $b . '.ISA'; # issue s18 if(exists $SpecialVarsUsed{$key}) { # issue s18 $isa = $SpecialVarsUsed{$key}{__main__}; # issue s18 $isa =~ s/\.split\(\)$//; # issue s18 $isa = unquote_string($isa); # issue s18 for my $parent (split ' ', $isa) { # issue s18 return -1 if($parent eq $a); # issue s18 } # issue s18 } # issue s18 } # issue s18 } # issue s18 # issue s18 return $aye cmp $bee; # issue s18 }; # issue s18: Properly sort the packages esp if there are dependencies to other packages my %dependencies = ('main'=>[]); my @unsorted = reverse sort keys %Packages; for my $package (@unsorted) { my @pieces = split /\./, $package; push @{$dependencies{'main'}}, $package unless $package eq 'main'; # Put main first if(scalar(@pieces) != 1) { for(my $l = 0; $l < $#pieces; $l++) { my $p = join('.', @pieces[0..$l]); if(exists $Packages{$p}) { push @{$dependencies{$p}}, $package; } } } # issue s18: Put base classes before subclasses my $key = $package . '.ISA'; if(exists $SpecialVarsUsed{$key}) { $isa = $SpecialVarsUsed{$key}{__main__}; $isa =~ s/\.split\(\)$//; $isa = unquote_string($isa); for my $p (split ' ', $isa) { push @{$dependencies{$p}}, $package; } } } if($::debug >= 3) { $Data::Dumper::Indent=0; $Data::Dumper::Terse = 1; say STDERR "package dependencies: "; say STDERR Dumper(\%dependencies); } my $children = sub { @{$dependencies{$_[0]} || []} }; @sorted_packages = &Pythonizer::toposort($children, \@unsorted); #for my $package (sort $package_sort keys %Packages) { # SNOOPYJC, issue s209: add 'sort' to get CGI before CGI.MultipartBuffer my %deferred_init_packages = (); # RequirePackage => [lines] my %deferred_init_packages_map = (); # package => RequirePackage %deferred_init_package_lines = (); # line => 1 my $defer = ''; # issue s18 my $defer_lno = 0; # issue s18 for my $package (@sorted_packages) { # SNOOPYJC, issue s209: add 'sort' to get CGI before CGI.MultipartBuffer next if($package =~ /^main\./ && exists $Packages{substr($package, 5)}); # issue s209: skip 'main.XXX' if we have 'XXX' $Pyf{_init_package} = 1; my $is_class = ''; #if((exists $SpecialVarsUsed{'bless'} && exists $SpecialVarsUsed{'bless'}{$package}) || parent_is_class($package)) { # issue s18 if(exists $SpecialVarsUsed{'bless'} && exists $SpecialVarsUsed{'bless'}{$package}) { $is_class = ', is_class=True'; } my $key = $package . '.ISA'; # issue s18 if(exists $SpecialVarsUsed{$key}) { # issue s18 $is_class .= ", isa=$SpecialVarsUsed{$key}{__main__}"; # issue s18 my $parents = $SpecialVarsUsed{$key}{__main__}; $parents =~ s/\.split\(\)$//; $parents = unquote_string($parents); foreach my $parent (split ' ', $parents) { if(exists $Pythonizer::RequirePackage{$parent} && !exists $BUILTIN_LIBRARY_SET{$parent}) { if($Pythonizer::RequirePackage{$parent} > $defer_lno) { $defer = $parent; $defer_lno = $Pythonizer::RequirePackage{$parent}; } } } if($package ne $DEFAULT_PACKAGE && exists $Pythonizer::PackageDef{$package}) { $deferred_init_packages_map{$package} = $package; # Used to defer initialiazations } } if($is_class && $autovivification) { # issue test coverage $PYF_CALLS{'_init_package'} = 'ArrayHash,Hash,_ArrayHash,_ArrayHashClass,_partialclass'; # issue test coverage } # issue s280 my $ip; my ($ip, $dip); # issue s280: Chicken and egg problem: generate 2 _init_package calls - one simple and one complex $escaped_package = escape_keywords($package, 1); # issue s18 if($import_perllib) { # issue s280 $ip = "$PERLLIB.init_package('$escaped_package'$is_class)"; $ip = "$PERLLIB.init_package('$escaped_package')"; # issue s280 $dip = "$PERLLIB.init_package('$escaped_package'$is_class)"; # issue s280 } else { # issue s280 $ip = "_init_package('$escaped_package'$is_class)"; $ip = "_init_package('$escaped_package')"; # issue s280 $dip = "_init_package('$escaped_package'$is_class)"; # issue s280 } if($defer) { # issue s280 push @{$deferred_init_packages{$defer}}, $ip; # issue s280 $deferred_init_package_lines{$ip} = 1; # So we don't move it push @{$deferred_init_packages{$defer}}, $dip; # issue s280 $deferred_init_package_lines{$dip} = 1; # issue s280: So we don't move it $deferred_init_packages_map{$package} = $defer; output_line('', $ip); # issue s280 } else { # issue s280 output_line('', $ip); output_line('', $dip); # issue s280 } } if(exists $InitVar{__main__}) { # SNOOPYJC, issue 41 if(keys %deferred_init_packages_map) { # issue s18: Def any dependencies on use/_init_package my @kept_lines = (); my @lines = split(/\n/, $InitVar{__main__}); foreach (@lines) { #say STDERR "InitVar = $_"; if(/^([A-Za-z0-9_.]+)\.[A-Za-z0-9_]+ /) { #say STDERR "matched $1"; my $package = unescape_keywords($1); #say STDERR "unescaped $package"; if(exists $deferred_init_packages_map{$package}) { my $usep = $deferred_init_packages_map{$package}; push @{$deferred_init_packages{$usep}}, $_; } else { push @kept_lines, $_; } } else { push @kept_lines, $_; } } $InitVar{__main__} = join("\n", @kept_lines); } output_line('', $InitVar{__main__}); # issue 41 } if($::debug >= 3) { $Data::Dumper::Indent=0; $Data::Dumper::Terse = 1; say STDERR "deferred_init_packages"; say STDERR Dumper(\%deferred_init_packages); } foreach my $end (@EndBlocks) { # SNOOPYJC output_line('', "atexit.register($end)"); # SNOOPYJC } # SNOOPYJC if($autovivification && exists $SpecialVarsUsed{'@ARGV'}) { # issue s142 $Pyf{Array} = 1; # issue s142 if($import_perllib) { # issue s142 output_line('', "sys.argv = $PERLLIB.Array(sys.argv)"); # issue s142 } else { # issue s142 output_line('', "sys.argv = Array(sys.argv)"); # issue s142 } # issue s142 } # issue s142 if($autovivification && exists $SpecialVarsUsed{'@INC'}) { # issue s359: Ensure .get(...) works on $INC[...] $Pyf{Array} = 1; # issue s359 if($import_perllib) { # issue s359 output_line('', "sys.path = $PERLLIB.Array(sys.path)"); # issue s359 } else { # issue s359 output_line('', "sys.path = Array(sys.path)"); # issue s359 } # issue s359 } # issue s359 if(exists $SpecialVarsUsed{'$|'}) { # SNOOPYJC: This is also set by the scanner if we ever call autoflush $Pyf{_autoflush} = 1; if($import_perllib) { output_line('', "$Perlscan::keyword_tr{STDOUT}.autoflush = types.MethodType($PERLLIB.autoflush, $Perlscan::keyword_tr{STDOUT})"); output_line('', "$Perlscan::keyword_tr{STDERR}.autoflush = types.MethodType($PERLLIB.autoflush, $Perlscan::keyword_tr{STDERR})"); } else { output_line('', "$Perlscan::keyword_tr{STDOUT}.autoflush = types.MethodType(_autoflush, $Perlscan::keyword_tr{STDOUT})"); output_line('', "$Perlscan::keyword_tr{STDERR}.autoflush = types.MethodType(_autoflush, $Perlscan::keyword_tr{STDERR})"); } } foreach my $begin (@BeginBlocks) { # issue s155 if(defined $Pythonizer::StartingBeginLno && $begin =~ /(\d+)/ && $1 == $Pythonizer::StartingBeginLno) { # issue s325 ; # issue s325: We generate the call right after the '}' is processed } else { # issue s325 output_line('', "$begin()"); # issue s155 } } # issue s155 foreach my $unitcheck (reverse @UnitCheckBlocks) { # issue s155 output_line('', "$unitcheck()"); # issue s155 } # issue s155 foreach my $check (reverse @CheckBlocks) { # issue s155 output_line('', "$check()"); # issue s155 } # issue s155 foreach my $init (@InitBlocks) { # issue s155 output_line('', "$init()"); # issue s155 } # issue s155 #while($l=){ # chomp $l; # output_line($l,'',''); # to block reproducing the first source line; added Sept 3, 2020 just for the future #} #close DATA; # #Main loop # @Perlscan::BufferValClass=@Perlscan::BufferValCom=@Perlscan::BufferValPerl=@Perlscan::BufferValPy=(); # cleaning after the first pass @Perlscan::BufferValType=(); my ($start,$token_buffer_active); # issue 41 $CurSub='main'; $CurSub='__main__'; # issue 41 $CurPackage = $DEFAULT_PACKAGE; # SNOOPYJC $FullyQualifiedCurSub = undef; # issue s320: Handle a fully qualified subname $token_buffer_active=0; $we_are_in_sub_body=0; @save_nests = (); # issue s155 $context_manager_nest = -2; # issue 66 @eval_stack = (); # issue 42 %eval_suffix = (); # issue s13: Map from lno to current suffix for that line $deferred_statement=0; # issue 58 $deferred_statement_nesting=0; # issue 58 @DeferredValClass=@DeferredValCom=@DeferredValPerl=@DeferredValPy=@DeferredValType=(); # issue 58 my %line_needs_added_return = (); # issue implicit conditional return foreach my $cs ( keys %Perlscan::sub_lines_contain_potential_last_expression ) { # issue implicit conditional return my $lnos = $Perlscan::sub_lines_contain_potential_last_expression{$cs}; foreach my $lno ( split/,/, $lnos ) { # issue s79 $line_needs_added_return{$lno} = 1; $line_needs_added_return{$lno}++; # issue s79: Keep track if there are multiple instances on one line } } if($debug >= 5) { # issue implicit conditional return print STDERR "line_needs_added_return = "; say STDERR Dumper(\%line_needs_added_return); } &Perlscan::initialize(); # issue 94 while( defined($line) || scalar(@Perlscan::BufferValClass)>0 || $saved_eval_tokens || $split_multiple_assignment){ # issue 42, issue 115 $TrStatus=0; # issue 68 if( scalar(@ValClass)==0 || ! defined($ValClass[0]) ){ # issue 68 $line=getline(); # skip lines with no tokens like ';' # issue 68 next; # issue 68 } # issue 13: Attempt to replace bare words in hash definitions and references # issue 13 $line =~ s/\{([A-Za-z_][A-Za-z0-9_]*)\}/\{\'$1\'\}/g; # issue 13 # We do this a better way now: $line =~ s/(?= 5) { say "Main loop, line=$line, BufferValClass=@Perlscan::BufferValClass, deferred_statement=$deferred_statement, saved_eval_tokens=" . (defined $saved_eval_tokens ? "@{$saved_eval_tokens->{perl}}" : "undef") . (defined $split_multiple_assignment ? ", split_multiple_assignment" :"") . ", token_buffer_active=$token_buffer_active, saved_eval_BufferValClass=@saved_eval_BufferValClass"; } # # You need to claw back tokens from buffer for postfix conditionals. This is a pretty brittle and complex code -- Oct 8,2020 NNB # if(!defined $line && $saved_eval_tokens) { # issue 42, issue s3 unpackage_tokens($saved_eval_tokens); $saved_eval_tokens = undef; for my $t (@saved_eval_buffer) { getline($t); } @saved_eval_buffer = (); @Perlscan::BufferValClass = @saved_eval_BufferValClass; # issue s179 $token_buffer_active = $saved_eval_token_buffer_active; # issue s179 $. = $saved_eval_lno; say STDERR "Restoring lno=$., BufferValClass=@Perlscan::BufferValClass, token_buffer_active=$token_buffer_active" if($debug); } elsif(defined $split_multiple_assignment) { # issue 115 unpackage_tokens($split_multiple_assignment); $split_multiple_assignment = undef; # issue s311 } elsif(defined $saved_sub_tokens && $nested_sub_at_level < 0) { # SNOOPYJC } elsif(defined $saved_sub_tokens && $nested_sub_at_level <= $saved_sub_tokens_level[-1]) { # SNOOPYJC, issue s311 unpackage_tokens($saved_sub_tokens); # issue s311 $saved_sub_tokens = undef; $saved_sub_tokens = pop @saved_sub_tokens_stack; # issue s311 pop @saved_sub_tokens_level; # issue s311 if($ValClass[0] eq 'c' && $ValPerl[0] eq 'aliased_foreach') { # issue s252 getline($line) unless @Perlscan::BufferValClass; # issue s252 } else { # issue s252 say STDERR "Restoring saved_sub_tokens - continuing to tokenize $line" if($debug); tokenize($line, 1); # Continue where we left off } } elsif ( scalar(@Perlscan::BufferValClass)==0 && $deferred_statement < 2) { # issue 58 if( $debug>1 ){ say STDERR "\n\n === Line $. Perl source:".(defined($line)?$line:$ValPerl[0])."===\n"; if( $.>=$breakpoint ){ logme('S', "Breakpoint was triggered at line $. in pythonizer.pl"); # $breakpoint=999999; $DB::single = 1; } } # if(!defined $line && $saved_eval_tokens) { # issue 42 # unpackage_tokens($saved_eval_tokens); # $saved_eval_tokens = undef; # for my $t (@saved_eval_buffer) { # getline($t); # } # @saved_eval_buffer = (); # $. = $saved_eval_lno; # } elsif(defined $split_multiple_assignment) { # issue 115 # unpackage_tokens($split_multiple_assignment); # $split_multiple_assignment = undef; # } elsif(defined $saved_sub_tokens && $nested_sub_at_level < 0) { # SNOOPYJC # unpackage_tokens($saved_sub_tokens); # $saved_sub_tokens = undef; # tokenize($line, 1); # Continue where we left off # } else { tokenize($line); # I just like to see tokenize call first in debugger :-) # } if($debug >= 5) { say STDERR "deferred_statement_nesting=$deferred_statement_nesting, nesting_level=$Perlscan::nesting_level, TokenStr=$TokenStr, nesting_last->{type}=$Perlscan::nesting_last->{type}" if($deferred_statement == 1); } if($deferred_statement == 1 && $Perlscan::nesting_level < $deferred_statement_nesting) { # issue 58 if($Perlscan::nesting_last->{type} eq 'else') { $deferred_statement=0; # We're all set } elsif(($TokenStr ne '}' && substr($TokenStr,0,1) ne 'C') || $Perlscan::nesting_level < $deferred_statement_nesting-1) { # issue 103 gen_statement('else:'); # Insert an 'else:' clause so we have a place to generate the assignment correct_nest(1,1); my @tmp=@ValClass; @ValClass=@DeferredValClass; @DeferredValClass=@tmp; @tmp=@ValCom; @ValCom=@DeferredValCom; @DeferredValCom=@tmp; @tmp=@ValPerl; @ValPerl=@DeferredValPerl; @DeferredValPerl=@tmp; @tmp=@ValPy; @ValPy=@DeferredValPy; @DeferredValPy=@tmp; @tmp=@ValType; @ValType=@DeferredValType; @DeferredValType=@tmp; $TokenStr=join('',@ValClass); $deferred_statement=3; } } }else{ if($deferred_statement >= 2) { # issue 58 @ValClass=@DeferredValClass; $TokenStr=join('',@ValClass); @ValCom=@DeferredValCom; @ValPerl=@DeferredValPerl; @ValPy=@DeferredValPy; @ValType=@DeferredValType; #@DeferredValClass=@DeferredValCom=@DeferredValPerl=@DeferredValPy=@DeferredValType=(); # issue 58 if($deferred_statement == 3) { correct_nest(-1,-1); # We inserted an "else:" above $deferred_statement = 0; } else { $deferred_statement = 1; } } elsif($token_buffer_active==0){ @ValClass=@ValPerl=('{'); $TokenStr=join('',@ValClass); # SNOOPYJC @ValPy=('if'); # issue 94 if(scalar(@Perlscan::nesting_stack) >= 1 && $Perlscan::nesting_stack[-1]->{type} eq 'given') { # issue s129 @ValPy=('when'); # issue s129 } # issue s129 &Perlscan::enter_block(); # issue 94 $token_buffer_active=1; }elsif($token_buffer_active==1 || $token_buffer_active==5){ # issue s79 @ValClass=@Perlscan::BufferValClass; $TokenStr=join('',@ValClass); @ValCom=@Perlscan::BufferValCom; @ValPerl=@Perlscan::BufferValPerl; @ValPy=@Perlscan::BufferValPy; @ValType=@Perlscan::BufferValType; say STDERR "Processing BufferValClass for token_buffer_active=$token_buffer_active =|$TokenStr|= ValPerl=@ValPerl, ValPy=@ValPy" if($debug>=5); # issue s79 $token_buffer_active=2; $token_buffer_active++; # issue s79 }elsif($token_buffer_active==4) { # issue s79: Inside the 'if', process the 'return' we snuck in say STDERR "Tokenizing $line for token_buffer_active=4" if($debug>=5); tokenize($line); @Perlscan::BufferValClass=@ValClass; @Perlscan::BufferValCom=@ValCom; @Perlscan::BufferValPerl=@ValPerl; @Perlscan::BufferValPy=@ValPy; @Perlscan::BufferValType=@ValType; @ValClass=@ValCom=@ValPerl=@ValPy=(); @ValType=(); $token_buffer_active = 5; }else{ @ValClass=@ValPerl=('}'); $TokenStr=join('',@ValClass); # SNOOPYJC &Perlscan::exit_block(); # issue 94 @Perlscan::BufferValClass=@Perlscan::BufferValCom=@Perlscan::BufferValPerl=@Perlscan::BufferValPy=(); @Perlscan::BufferValType=(); $token_buffer_active=0; } } if( scalar(@ValClass)==0 || ! defined($ValClass[0]) ){ # issue 68 gen_statement('pass'); # issue 68 $line=getline(); # skip lines with no tokens like ';' # issue 68 next; # issue 68 } # issue 68 # # Dealing with problem of state varaible mapping into Python via renaming # rename_state_var(0,$#ValPy); if( index($TokenStr,'s^')>-1){ # Selected cases of postfix and prefix operator can be translated; other not autoincrement_fix() # exported function located in Perlscan } if($TokenStr =~ /^f\("\)="$/ && $ValPerl[0] eq '%SIG') { # SNOOPYJC: Fix a signal assignment with a sub replace(1,'(','(','('); # issue s154 replace(2, 'i', $ValPerl[2], unquote_string($ValPy[2])); replace(3,',',',',','); replace(4,$ValClass[5],$ValPerl[5],$ValPy[5]); replace(5,')',')',')'); } fix_scalar_context(); # issue 37 #fix_string_catenation(); # issue 36 fix_multi_subscripts(); # issue 84 fix_singular_foreach(); # issue s137 # issue s176 remove_dereferences(); # issue 50 remove_scalar_dereferences(); # issue s185: Must do this type before fix_expression_issues replace_incr_decr_stmt(); # SNOOPYJC fix_expression_issues(); # SNOOPYJC, issue 74, issue 52 remove_dereferences(); # issue 50, issue s176 fix_type_issues(0, $#ValClass, undef); # SNOOPYJC fix_undef(); # SNOOPYJC $split_multiple_assignment = split_up_multiple_assignment(); # issue 115 if($split_multiple_assignment) { # issue 115 fix_expression_issues(); # issue 115: We skip handling assignment in expression on multi-assignment } fix_global_and_eval_regex(); # SNOOPYJC fix_boolean_expressions(0, $#ValClass, lc($ValClass[0]) eq 'c'); # issue s124 insert_splat_lists(0, $#ValClass, 0); # issue s308 if(fix_out_parameters()) { # issue s184 fix_expression_issues(); # issue s184: Correct any bad assignments we created } insert_method_calls(); # issue s236: Do this after fix_out_parameters interpolate_hashrefs(); # issue s316 #fix_multistmt_bracket_functions(); # issue s39 # # Statements # $RecursionLevel=0; if(!$set_initial_package && ($ValClass[0] ne 'c' || $ValPerl[0] ne 'package')) { # SNOOPYJC gen_statement("builtins.__PACKAGE__ = '$CurPackage'"); $set_initial_package = 1; } elsif(exists $FileHandles{DATA} && $FileHandles{DATA} == $. && !$gen_open_data) { my $data = 'DATA'; $data = "$CurPackage.DATA" unless($implicit_global_my); $Pyf{_open} = 1; gen_chunk($data,'=','_open',"(re.sub(r'\\.py\$',r'.data',sys.argv[0])", ',', "'r'", ',', 'checked=False', ')'); gen_statement(); $gen_open_data = 1; } # issue 13: Treat my @arr and my %hash as if there was no "my" so the proper code is generated if( $ValClass[0] eq 't' && $ValClass[1] =~ /[ah]/ && (($ValPerl[0] eq 'my' && scalar(@ValClass) > 2) || # issue 13 ($ValPerl[0] eq 'local' && $CurSub eq '__main__' && scalar(@ValClass) > 2) || # SNOOPYJC: Local same as my at outer scope ($ValPerl[0] eq 'our' && next_same_level_token('=', 2, $#ValClass) > 0))) { # SNOOPYJC destroy(0, 1); # issue 13: remove the "my"/"our"/"local" } elsif( $ValClass[0] eq 't' && $ValClass[1] eq '(' && $ValClass[2] =~ /[ah]/ && $ValClass[3] eq ')' && (($ValPerl[0] eq 'my' && scalar(@ValClass) > 4) || # issue ddts ($ValPerl[0] eq 'local' && $CurSub eq '__main__' && scalar(@ValClass) > 4) || # SNOOPYJC: Local same as my at outer scope ($ValPerl[0] eq 'our' && next_same_level_token('=', 4, $#ValClass) > 0))) { # SNOOPYJC destroy(3, 1); # remove the ')' destroy(0, 2); # remove the "my"/"our"/"local" and the '(' } elsif($ValClass[0] eq 't' && $ValPerl[0] eq 'local' && $ValClass[1] eq 'f') { # Handle local signal destroy(0, 1); # issue 13: remove the "my"/"our" } if( $ValClass[0] eq '^' ) { # issue 29 # ++ expr; statement: change to expr++; my $vpl = $ValPerl[0]; my $vpy = $ValPy[0]; destroy(0, 1); # issue 29 append('^', $vpl, $vpy); # issue 29 } # issue 29 if ($ValClass[0] eq 'W' ) { # issue 66: Context manager $context_manager_nest = $Pythonizer::CurNest; # issue 66 if($debug >= 3) { say STDERR "Setting context_manager_nest = $context_manager_nest"; } gen_statement($ValPy[0]); # issue 66 correct_nest(1); # issue 66 correct_nest(); # issue 66 destroy(0, 1); # issue 66 } if( $ValClass[0] eq '}' ){ # we treat curvy bracket as a separate dummy statement $processing_closing_bracket = 1; # issue s325: See &Perlscan::in_starting_BEGIN for use of this if($debug >= 5 && $deferred_statement == 1) { say STDERR "deferred_statement_nesting=$deferred_statement_nesting, nesting_level=$Perlscan::nesting_level"; say STDERR "nesting_last->{type}=$Perlscan::nesting_last->{type}"; } if(!$Pythonizer::GeneratedCode) { # issue 96 gen_statement('pass'); # issue 96: python doesn't allow empty blocks } # issue 96 gen_statement(); if(&Perlscan::is_continue_block(1)) { # correct_nest(-1,-1) if($continue_needed_try_block); # issue s49 correct_nest(-1,-1) if(&Perlscan::continue_needed_try_block(1)); # issue s49 } if(&Perlscan::needs_redo_loop(1)) { # SNOOPYJC gen_statement('break'); correct_nest(-1,-1); } if(&Perlscan::needs_try_block(1)) { # issue 94 my $ex_name = &Perlscan::try_block_exception_name(); if(defined $ex_name) { # issue 108 correct_nest(-1,-1); if($ex_name eq $FUNCTION_RETURN_EXCEPTION) { # SNOOPYJC gen_statement("except $ex_name as _r:"); correct_nest(1,1); gen_statement("return _r.args[0]"); } else { my $continue = 0; if(&Perlscan::has_continue(1)) { # SNOOPYJC $continue = 1; correct_nest(1,1); gen_statement("raise $ex_name('continue')"); correct_nest(-1,-1); # issue s46 $continue_needed_try_block = 1; &Perlscan::set_continue_needed_try_block(1, 1); # issue s49 } gen_statement("except $ex_name as _l:"); correct_nest(1,1); #gen_statement("if 'break' in str(_l):"); gen_statement("if _l.args[0] == 'break':"); correct_nest(1,1); gen_statement('break'); correct_nest(-1,-1); gen_statement('continue') if(!$continue); gen_implicit_continue(); } } &Perlscan::gen_try_block_finally(); correct_nest(-1); } elsif(!&Perlscan::is_continue_block(1)) { # issue s46 $continue_needed_try_block = 0; &Perlscan::set_continue_needed_try_block(1, 0); # issue s49 gen_implicit_continue(); } if(exists $Perlscan::nesting_last->{function_template}) { # issue s76 correct_nest(-1,-1); # issue s76 gen_chunk('return', $Perlscan::nesting_last->{cur_sub} . "template"); # issue s76 gen_statement(); # issue s76 #} elsif($Perlscan::nesting_last->{type} eq 'given') { # issue s129 #gen_statement('break'); # issue s129 } elsif($Perlscan::nesting_last->{type} eq 'when' && !exists $UseSwitch{fallthrough} && !exists $Perlscan::nesting_last->{fallthrough}) { # issue s129 gen_statement('break'); # issue s129 } elsif($Perlscan::nesting_last->{type} eq 'sub' && exists $aliased_foreach_subs{$Perlscan::nesting_last->{cur_sub}}) { # issue s252 gen_chunk('return', $aliased_foreach_return{$Perlscan::nesting_last->{cur_sub}}); # issue s252 gen_statement(); # issue s252 } correct_nest(-1); # next line will be de-indented if( $we_are_in_sub_body && $Pythonizer::NextNest ==0 ){ correct_nest(0,0); if(!$implicit_global_my && $CurSub ne '__main__') { # SNOOPYJC, issue 41 my $escaped = escape_keywords($CurSub); my $p_escaped = escape_keywords($CurPackage, 1); if(defined $FullyQualifiedCurSub) { # issue s320 my $pd = rindex($FullyQualifiedCurSub, '.'); # issue s320 $p_escaped = escape_keywords(substr($FullyQualifiedCurSub, 0, $pd), 1); # issue s320 $FullyQualifiedCurSub = undef; # issue s320 } #if(exists $SpecialVarsUsed{'bless'} && exists $SpecialVarsUsed{'bless'}{$CurPackage}) { # issue s241 if(exists $CLASS_METHOD_SET{$CurSub} || (exists $SubAttributes{$CurSub}{blesses} && # issue s241 !exists $SubAttributes{$CurSub}{overloads})) { # issue s3 if(exists $CLASS_METHOD_SET{$CurSub} || (defined get_sub_attribute($CurSub, 'blesses') && !defined get_sub_attribute($CurSub, 'overloads'))) { # issue s3, issue s241 # issue s203 addl fix: Since we move all _init_package calls up front, when any subclasses are defined we # may not have yet defined the parent's MethodClass functions yet, so we need to # properly subclass them here if need be. Fix also in _init_package my %children = (); for my $isa (keys %SpecialVarsUsed) { next unless $isa =~ /^(.+)\.ISA$/; next unless exists $SpecialVarsUsed{$isa}{__main__}; my $subp = $1; my $parents = $SpecialVarsUsed{$isa}{__main__}; $parents =~ s/^'(.*)'.split\(\)$/$1/; @parents = split ' ', $parents; for (@parents) { push @{$children{$_}}, $subp; } } my @gen_list = (); my %to_gen = (); my $create_list; $create_list = sub { my ($gen_list_ref, $to_gen_ref, $children_ref, $pkg) = @_; if(exists $children_ref->{$pkg}) { for (@{$children_ref->{$pkg}}) { unshift @$gen_list_ref, $_ unless exists $to_gen_ref->{$_}; $to_gen_ref->{$_} = 1; &$create_list($gen_list_ref, $to_gen_ref, $children_ref, $_); } } }; &$create_list(\@gen_list, \%to_gen, \%children, $CurPackage); for (@gen_list) { my $epkg = escape_keywords($_); if(exists $Packages{$_} && $Packages{$_} == 1) { # Package defined here gen_statement("$epkg.$escaped = types.MethodType($escaped, $epkg)"); } else { gen_statement("$epkg.$escaped = types.MethodType($escaped, $epkg) if not hasattr($epkg, '$escaped') else getattr($epkg, '$escaped')"); } } # end of issue s203 addl fix # MethodType is used to set @classmethod's only. It's a class method if it has # one of the names in %CLASS_METHOD_SET (new, make), or if it calls 'bless' and it's not # listed in overloads: gen_statement("$p_escaped.$escaped = types.MethodType($escaped, $p_escaped)"); # issue s3 } elsif($CurSub ne 'import' && ((exists $LocalSub{TIEHASH} && $LocalSub{TIEHASH} == 1) || # (exists $LocalSub{TIESCALAR} && $LocalSub{TIESCALAR} == 1) || # issue s301: Not needed for TIESCALAR (exists $LocalSub{TIEARRAY} && $LocalSub{TIEARRAY} == 1))) { # issue s154 # issue s216 gen_statement("$p_escaped.$escaped = lambda *_args: $escaped(_args[0].__dict__, *_args[1:])"); # issue s154 # issue s304 $Pyf{_tie_call} = 1; # issue s216 $Pyf{_add_tie_call} = 1; # issue s304 # # NOTE: Whatever you put here, you have to match in 2 places in Pythonizer.pm so the line gets moved along with # the def above it: # if($import_perllib) { # issue s216 # issue s304 gen_statement("$p_escaped.$escaped = lambda *_args, **_kwargs: $PERLLIB.tie_call($escaped, _args, _kwargs)"); gen_statement("$p_escaped.$escaped = $PERLLIB.add_tie_call($escaped, $p_escaped)"); # issue s304 } else { # issue s304 gen_statement("$p_escaped.$escaped = lambda *_args, **_kwargs: _tie_call($escaped, _args, _kwargs)"); gen_statement("$p_escaped.$escaped = _add_tie_call($escaped, $p_escaped)"); # issue s304 } } else { gen_statement("$p_escaped.$escaped = $escaped"); } } elsif($implicit_global_my && exists $SpecialVarsUsed{caller}) { # issue s260 my $escaped = escape_keywords($CurSub); # issue s260 my $p_escaped = escape_keywords($CurPackage, 1); # issue s260 gen_statement("$p_escaped.$escaped = $escaped"); # issue s260 } initialize_globals_for_state_vars(); %new_state_var_name=(); # hash for own and state variables %new_state_var_init=(); if(defined $Pythonizer::StartingBeginLno && $CurSub =~ /^__BEGIN__(\d+)$/ && $1 == $Pythonizer::StartingBeginLno) { # issue s325 output_line('', "$CurSub()"); # issue s325: Call it right away (the # I_M_P_O_R_T comment will be added) } $CurSub='__main__'; # issue 41 if($save_nests[-1]->[0] != 0) { # issue s155 gen_statement('pass'); # issue s155 } # issue s155 restore_nest(pop @save_nests); # issue s155 $we_are_in_sub_body--; # issue s155 } if($#ValClass > 1 && $ValClass[1] eq 'c' && $ValPerl[1] eq 'while') { # issue s35: end of 'do' in the delayed case #control(1); # issue s35 my $lno = $Perlscan::nesting_last->{lno}; # issue s35 gen_statement("$DO_CONTROL$lno = False"); # issue s35 } # issue s35 #if($nested_sub_at_level >= 0) { #say STDERR "Got } on line $., nested_sub_at_level=$nested_sub_at_level, nesting_level=$Perlscan::nesting_level"; #} $processing_closing_bracket = 0; # issue s325: See &Perlscan::in_starting_BEGIN for use of this }elsif( $ValClass[0] eq '{' ){ if(&Perlscan::is_continue_block(0)) { # issue s49 correct_nest(1,1) if($continue_needed_try_block); correct_nest(1,1) if(&Perlscan::continue_needed_try_block(1)); # issue s49 } elsif(!$Perlscan::PREV_HAD_COLON) { # SNOOPYJC # The user opened a brace with nothing before it, so we have to generate some code for # the nesting to be correct gen_statement('for _ in range(1):'); # SNOOPYJC: Use a loop so you can last/next it #finish(); } $Perlscan::PREV_HAD_COLON = 0; # issue 94: It's only good once! if(&Perlscan::needs_try_block(0)) { # issue 94 gen_statement(); correct_nest(1,1); gen_statement('try:'); } if(&Perlscan::needs_redo_loop(0)) { # SNOOPYJC gen_statement(); correct_nest(1,1); gen_statement('while True:'); } $Pythonizer::GeneratedCode = 0; # issue 96 correct_nest(1); # next line will be indented if(&Perlscan::needs_try_block(0)) { # issue 108 &Perlscan::push_locals($CurSub); } if($deferred_statement == 1 && $deferred_statement_nesting == $Perlscan::nesting_level) { $deferred_statement = 2; # issue 58 } if($deferred_nesting_top) { # issue s252: We deferred marking this aliased_foreach because it's a stmt modifier $top = $Perlscan::nesting_stack[-1]; $top->{is_sub} = 1; $top->{in_sub} = 1; $top->{cur_sub} = $deferred_nesting_top; $top->{type} = 'sub'; $top->{was_foreach} = 1; $top->{in_loop} = 0; $top->{is_loop} = 0; $deferred_nesting_top = undef; if($nested_sub_at_level != 0) { # issue s252: ... for LIST didn't process '{' yet, issue s299 $nested_sub_at_level++; # issue s299 pop @nested_sub_at_levels; push @nested_sub_at_levels, $nested_sub_at_level; # issue s299 } # issue s299 } }elsif( $ValClass[0] eq '(' ){ $close_br_pos=matching_br(0); # issue paren if( $close_br_pos && $ValClass[$close_br_pos+1] eq '=' ){ if( $close_br_pos >= 0 && $close_br_pos < $#ValClass && $ValClass[$close_br_pos+1] eq '='){ # issue paren $TrStatus=assignment(0); # issue s151 } elsif($close_br_pos >= 0 && $close_br_pos < $#ValClass && $ValClass[$close_br_pos+1] eq '~' && $ValPerl[$close_br_pos+1] ne '~') { # Regex } elsif($close_br_pos >= 0 && $close_br_pos < $#ValClass && $ValClass[$close_br_pos+1] eq 'p') { # Regex, issue s151 $TrStatus=expression(0, $#ValClass, 0); } elsif (index(substr($TokenStr, 0, $close_br_pos), '=') >= 0) { # issue paren: assignment, like in ($i = 1) if(...); if($close_br_pos == $#ValClass && next_same_level_token(',', 1, $close_br_pos-1) == -1) { $TrStatus=assignment(1, $close_br_pos-1); # issue paren } else { $TrStatus=expression(0, $close_br_pos, 1); $TrStatus=expression($close_br_pos+1, $#ValClass, 0) if($close_br_pos+1 <= $#ValClass); } } elsif($ValPerl[0] eq '(' && $close_br_pos == 1 && &Perlscan::cur_sub() ne '__main__') { # issue s254 $TrStatus=expression(0, $close_br_pos, 1); # issue s254 gen_chunk('if', 'wantarray', 'else', 'None'); # issue s254 $TrStatus=expression($close_br_pos+1, $#ValClass, 0) if($close_br_pos+1 <= $#ValClass); # issue s254 }else{ $TrStatus=expression(0, $close_br_pos, 1); # SNOOPYJC $TrStatus=expression($close_br_pos+1, $#ValClass, 0) if($close_br_pos+1 <= $#ValClass); } }elsif( $ValPy[0] eq 'NoTrans!' ){ if($Pythonizer::CurNest) { # SNOOPYJC output_line('pass',' #SKIPPED: '.$line); # issue 96 } else { output_line('','#SKIPPED: '.$line); } $line=getline(); next; }elsif($ValPerl[0] eq 'sub' && $#ValClass >= 1 && exists $nested_subs{$ValPerl[1]}) { # issue 78 # issue s131 gen_chunk('def',$ValPy[1],"($nested_subs{$ValPerl[1]}):"); # def name (special list of arguments) my $orig_args = $nested_subs{$ValPerl[1]}; # issue s131 my $args = $orig_args; if($orig_args eq $DEFAULT_MATCH) { # issue s131 $args .= '_'; # issue s131: add an extra '_' } gen_chunk('def',$ValPy[1],"($args):"); # def name (special list of arguments), issue s131 gen_statement(); if($Pythonizer::NextNest ==0) { # issue s155 $we_are_in_sub_body++; # issue s155 push @save_nests, save_nest(); # issue s155 } if($orig_args eq $DEFAULT_MATCH) { # issue s131 correct_nest(1,1); # issue s131 output_line("global $DEFAULT_MATCH"); # issue s131 output_line("$DEFAULT_MATCH = ${DEFAULT_MATCH}_"); # issue s131 correct_nest(-1,-1); # issue s131 } # issue s131 $LocalSub{$ValPy[1]} = 1; $nested_sub_at_level = $Perlscan::nesting_level; # issue s299 $nested_sub_at_level++ if defined $deferred_nesting_top && $nested_sub_at_level != 0; # issue s252: ... for LIST didn't process '{' yet push @nested_sub_at_levels, $nested_sub_at_level; # issue s241 # issue s299 if(defined $deferred_nesting_top && $nested_sub_at_level != 0) { # issue s252: ... for LIST didn't process '{' yet, issue s299 # issue s299 $nested_sub_at_level++; # issue s299 # issue s299 push @nested_sub_at_levels, $nested_sub_at_level; # issue s299 # issue s299 } # issue s299 $top = $Perlscan::nesting_stack[-1]; # issue s76 if(exists $top->{function_template}) { # issue s76 correct_nest(1,1); gen_chunk('def',$ValPy[1].'template',"(\*$PERL_ARG_ARRAY):"); # def nametemplate (regular list of arguments) gen_statement(); $LocalSub{$ValPy[1].'template'} = 1; $nested_sub_at_level = $Perlscan::nesting_level+1; # issue s241 push @nested_sub_at_levels, $nested_sub_at_level; # issue s241 } say STDERR "Generating $ValPy[1], nested_sub_at_level=$nested_sub_at_level, nested_sub_at_levels=@nested_sub_at_levels" if($debug>=3); # issue s241 if(exists $SubAttributes{$ValPy[1]}{modifies_arglist}) { # issue s84 if(defined get_sub_attribute($ValPy[1], 'modifies_arglist')) { # issue s84, issue s241 # This sub uses a shift or pop of the arguments, so we have to copy it # from a tuple to a list. correct_nest(1,1); if($autovivification) { # issue s348 output_line("$PERL_ARG_ARRAY = " . ($import_perllib ? "$PERLLIB.Array" : 'Array') . "($PERL_ARG_ARRAY)"); # issue s348 } else { # issue s348 output_line("$PERL_ARG_ARRAY = list($PERL_ARG_ARRAY)"); } gen_init_outps($ValPy[1]); # issue s184 correct_nest(-1,-1); } else { # issue s185: Reference out parameters may exist w/o modifies_arglist set correct_nest(1,1); # issue s185 gen_init_outps($ValPy[1]); # issue s185 correct_nest(-1,-1); # issue s185 } correct_nest(1,1); for my $class (qw(global nonlocal)) { my @vars = get_sub_vars_with_class($ValPy[1], $class); if(@vars) { output_line("$class " . join(', ', @vars)); } } correct_nest(-1,-1); }elsif( $ValPerl[0] eq 'sub' && $#ValClass >= 1 && $ValPy[0] ne '#NoTrans!'){ # issue s155 $we_are_in_sub_body=1; $we_are_in_sub_body++; # issue s155 %new_state_var_name=(); # hash for own and state variables %new_state_var_init=(); # Perl has two types of sub statements -- prototype and actual $CurSub=$ValPy[1]; my $pd = rindex($CurSub, '.'); # issue s320 if($pd != -1) { # issue s320 $FullyQualifiedCurSub = $CurSub; # issue s320 $CurSub = substr($CurSub, $pd+1); # issue s320 $LocalSub{$FullyQualifiedCurSub} = 1; # issue s320 } # issue s320 push @save_nests, save_nest(); # issue s155 correct_nest(0,0); my $escaped = escape_keywords($CurSub); # issue 41 # issue s155 if(substr($escaped, 0, 7) eq '__END__') { # SNOOPYJC: END block if(special_code_block_name($escaped)) { # issue s155 gen_chunk('def',$escaped,"():"); # SNOOPYJC } else { # issue 41 gen_chunk('def',$CurSub,"($PERL_ARG_ARRAY):"); # def name ([list of arguments]) # isssue 32 # issue s241 if(exists $SubAttributes{$CurSub}{wantarray}) { # issue s3 if(defined get_sub_attribute($CurSub, 'wantarray')) { # issue s3, issue s241 gen_chunk('def',$escaped,"(*$PERL_ARG_ARRAY, wantarray=False):"); # def name (list of arguments) # issue s3 } else { gen_chunk('def',$escaped,"(*$PERL_ARG_ARRAY):"); # def name (list of arguments) # issue 32, issue 41, SNOOPYJC } $LocalSub{$CurSub}=1; # issue s241 if(exists $SubAttributes{$CurSub}{modifies_arglist}) { # SNOOPYJC if(defined get_sub_attribute($CurSub, 'modifies_arglist')) { # SNOOPYJC, issue s241 # This sub uses a shift or pop of the arguments, so we have to copy it # from a tuple to a list. gen_statement(); correct_nest(1,1); if($autovivification) { # issue s348 output_line("$PERL_ARG_ARRAY = " . ($import_perllib ? "$PERLLIB.Array" : 'Array') . "($PERL_ARG_ARRAY)"); # issue s348 } else { # issue s348 output_line("$PERL_ARG_ARRAY = list($PERL_ARG_ARRAY)"); } gen_init_outps($CurSub); # issue s184 correct_nest(-1,-1); } else { # issue s185: Reference out parameters may exist w/o modifies_arglist set gen_statement(); # issue s185 correct_nest(1,1); # issue s185 gen_init_outps($ValPy[1]); # issue s185 correct_nest(-1,-1); # issue s185 } } if (exists($GlobalVar{$CurSub}) ){ gen_statement(); correct_nest(1,1); output_line($GlobalVar{$CurSub}); correct_nest(0,0); } if (exists($InitVar{$CurSub}) ){ # SNOOPYJC: Variable initialization gen_statement(); correct_nest(1,1); my @init = split /\n/, $InitVar{$CurSub}; for $in (@init) { output_line($in); } correct_nest(0,0); } }elsif( $ValPerl[0] =~ /^(?:BEGIN|UNITCHECK|CHECK|INIT)$/ ){ # SNOOPYJC, issue s37 # issue s155 BEGIN can be nested!! correct_nest(0,0); gen_chunk($ValPy[0]," # $ValPerl[0]:"); # SNOOPYJC }elsif( $ValPerl[0] eq 'close' ){ my $or_and = next_same_level_tokens('0o', 0, $#ValClass); # issue s79 my $start = 1; # issue s154 my $end_pos = $#ValClass; if($ValClass[1] eq '(' && $ValClass[-1] eq ')' && matching_br(1) == $#ValClass) { # issue s154 $start = 2; $end_pos = $#ValClass-1; } # issue s154 for( my $i=1; $i<@ValPy; $i++ ){ for( my $i=$start; $i<=$end_pos; $i++ ){ # issue s154 last if($i == $or_and); # issue s79 my $eov = end_of_variable($i); # issue s154: handle close($_[0]->{fh}) from TiedArray.pm if( $eov == $i && ($ValClass[$i] eq 'i' || $ValClass[$i] eq 's') ){ # issue 10, issue s154 # issue close gen_chunk($ValPy[$i].'.f.close;'); # issue 72 gen_chunk($ValPy[$i].'.close()'); # issue close $Pyf{_close_} = 1; # issue test coverage my $escaped = escape_keywords($ValPy[$i]); # issue s25 gen_chunk('_close_', '(', $escaped, ')'); # issue close, issue 72, issue s25, issue test coverage if($or_and > 0) { # issue s79 expression($or_and, $#ValClass, 0); # issue s79 } # issue s79 gen_statement(); } else { # issue s154: handle close($_[0]->{fh}) from TiedArray.pm $Pyf{_close_} = 1; # issue s154 gen_chunk('_close_', '('); # issue s154 $TrStatus=expression($i, $eov, 0); # issue s154 gen_chunk(')'); # issue s154 if($or_and > 0) { # issue s154 expression($or_and, $#ValClass, 0); # issue s154 } # issue s154 gen_statement(); # issue s154 $i = $eov; # issue s154 } } }elsif( $ValPerl[0] =~ /^(?:say|print|printf)$/ ){ # SNOOPYJC $TrStatus=print3(0); }elsif( $ValPerl[0] =~ /^warn$/ ){ # SNOOPYJC # issue s101 $TrStatus=print3(0,'STDERR'); # in Python3 this is a function # issue s288 $TrStatus=print3(0, $#ValClass, 'sys.stderr'); # in Python3 this is a function, issue s101 $Pyf{_warn} = 1; # issue s288 gen_chunk('_warn', '('); # issue s288 my $start = 1; my $end_pos = $#ValClass; if($start <= $#ValClass && $ValPerl[$start] eq '(') { $end_pos = matching_br($start) - 1; $start++; } $TrStatus = expression($start, $end_pos, 2) if $start <= $end_pos; # issue s288 gen_chunk(')'); # issue s288 }elsif( $ValClass[0] eq 's' ){ if( ($TokenStr=~tr/=//) > 1 && $ValClass[-1] eq 'd' && ($ValPerl[-2] eq '+=' || $ValPerl[-2] eq '-=') ){ # multiple assignment with the last increment like $K=$i+=1 need to be expanded due to bug in Python parser $ValPy[-1]=$ValPy[-3].substr($ValPerl[-2],0,1).$ValPy[-1]; $ValPy[-2]=$ValPerl[-2]='='; } # issue s151 my $reg = next_same_level_token('~', 0, $#ValClass); # SNOOPYJC # issue s151 if($reg != -1 && $ValPerl[$reg] ne '~' && $reg+1 <= $#ValClass && $ValPerl[$reg+1] =~ /re|tr/) { # SNOOPYJC my $reg = next_same_level_token('p', 0, $#ValClass); # SNOOPYJC, issue s151 if($reg != -1 && $reg+1 <= $#ValClass && $ValPerl[$reg+1] =~ /re|tr/) { # SNOOPYJC, issue s151 $TrStatus=expression(0, $#ValClass, 0); # SNOOPYJC # issue s129 } elsif($CurSub eq '__main__' || scalar(@ValClass) != 1) { # issue 45: Ignore scalar alone on a line (may be the return value), issue 41 } elsif(&Perlscan::cur_sub() eq '__main__' || end_of_variable(0) != $#ValClass) { # issue 45: Ignore scalar alone on a line (may be the return value), issue 41, issue s129 $TrStatus=assignment(0); } elsif(scalar(@ValClass) > 1) { # issue s129: example: sDi(...) which is a OO function call $TrStatus=expression(0, $#ValClass, 0); # issue s129 } # issue 45 }elsif( $ValClass[0] eq 't' ){ &Perlscan::init_local_typeglobs($CurSub) if($ValPerl[0] eq 'local'); # issue 108 if( scalar(@ValClass)==2 ){ #uninitalise single var declaration like my $line if( $ValPerl[0] eq 'my' || $ValPerl[0] eq 'local'){ # issue 108, SNOOPYJC: don't init 'our' variables my $LHS = $ValPy[1]; # SNOOPYJC if(exists $SpecialVarR2L{$ValPy[1]}) { # SNOOPYJC: Change _nr() to INPUT_LINE_NUMBER etc $LHS = $SpecialVarR2L{$ValPy[1]}; } if(substr($ValPerl[1],0,1) eq '*') { # issue 108: Don't init a typeglob ; # issue s144 update } elsif($ValPerl[0] eq 'local' && $CurSub ne '__main__') { # issue s144 # issue s144 update ; # issue s144: Don't init 'local' in a sub that isn't explicitly initialized - we initialize it in __main__, else we trash the value } elsif(exists $VarType{$ValPy[1]} && exists $VarType{$ValPy[1]}{$CurSub}) { output_line("$LHS = ".init_val($VarType{$ValPy[1]}{$CurSub})); } elsif($ValClass[1] =~ /[ah]/) { # issue s328 output_line("$LHS = ".init_val($ValClass[1])); # issue s328 } else { output_line("$LHS = None"); } }elsif( $ValPerl[0] eq 'own' ){ gen_chunk( $ValPy[0], $ValPy[1] ); }elsif( $ValPerl[0] eq 'state' ){ $new_name=$CurSub.'_'.$ValPy[1]; $new_state_var_name{$ValPy[1]}=$new_name; gen_chunk($ValPy[0],$new_name); } finish(); next; }elsif( scalar(@ValClass)==4 && $ValClass[2] eq '=' ){ if( $ValPerl[0] eq 'my' || $ValPerl[0] eq 'our' || $ValPerl[0] eq 'local' ){ # issue 108 if($ValClass[1] eq 'G') { # issue 108: typeglob # issue s198 $ValPy[1] = &Perlscan::choose_glob($ValPerl[1], $ValPy[1]) ($ValClass[1], $ValPy[1]) = &Perlscan::choose_glob_and_get_type($ValPerl[1], $ValPy[1]); } if($ValClass[1] eq 'h' || $ValClass[1] eq 'a') { # issue s198: Punt the array/hash cases to assignment $TrStatus = assignment(1); # issue s198 } elsif($ValClass[3] eq 'f') { # issue 8: shift generates bad code gen_chunk("$ValPy[1] = "); # issue 8 if($ValPerl[3] eq 'undef') { # issue undef my $val = 'None'; my $u = $ValPy[1]; if(exists $VarType{$u} && exists $VarType{$u}{$CurSub}) { $val = init_val($VarType{$u}{$CurSub}); } elsif($ValClass[1] =~ /[ah]/) { # issue s328 $val = init_val($ValClass[1]); # issue s328 } gen_chunk($val); } else { function(3,3); # Issue 8 } } elsif($ValClass[3] eq 'x') { # issue 42 gen_chunk("$ValPy[1] = "); # Issue 42 expression(3, 3, 0); # issue 42 # SNOOPYJC }elsif($ValClass[3] eq 'i' && $ValPy[3] eq $ValPerl[3]) { # issue 13 }elsif($ValClass[3] eq 'i') { # issue 13, SNOOPYJC gen_chunk("$ValPy[1] = "); # issue 13 if( $LocalSub{$ValPy[3]} ){ # issue 13: local sub call with no parens gen_chunk(escape_keywords($ValPy[3])); # issue 13, issue 41 # issue s241 if(exists $SubAttributes{$ValPy[3]}{wantarray} && if(defined get_sub_attribute($ValPy[3], 'wantarray') && # issue s241 ($ValClass[1] =~ /[ah]/ || ($ValClass[1] eq 'G' && $ValPy[1] =~ /_[ah]$/))) { # issue s3 gen_chunk('(wantarray=True)'); # issue s3 } else { gen_chunk('()'); # issue 13 } } elsif ($Constants{$ValPy[3]}) { # issue 13: constant or file handle gen_chunk($ValPy[3]); # issue 13 } else { # issue 13: bare word - treat as string gen_chunk("'".$ValPy[3]."'"); # issue 13 } }elsif($ValClass[3] eq 'C' && $ValPerl[3] eq 'eval') { # issue 42: my $var = eval {...} $TrStatus=assignment(1); } else { # Issue 8 #output_line("$ValPy[1] = $ValPy[-1]"); if($autovivification && $ValClass[-1] eq 's' && $ValPerl[-1] eq '$_' && $ValPy[-1] =~ /^$PERL_ARG_ARRAY\[/) { # issue s359 $ValPy[-1] =~ s/\[/.get(/; # issue s359 $ValPy[-1] =~ s/\]/)/; # issue s359 } # issue s359 gen_chunk("$ValPy[1]", "=", "$ValPy[-1]"); # issue bootstrap (fileinput) gen_statement(); # issue bootstrap (fileinput) } }elsif( $ValPerl[0] eq 'own' ){ gen_chunk( $ValPy[0], $ValPy[1].' = ',$ValPy[-1] ); }elsif( $ValPerl[0] eq 'state' ){ $new_name=$CurSub.'_'.$ValPy[1]; $new_state_var_name{$ValPy[1]}=$new_name; gen_chunk($ValPy[0],$new_name); # issue 128: If we're initializing this from a non-constant, we can't move that # init out of the sub, as it could be a local variable or a global that has # a different value than where we place the assignment, so instead we generate # a flag variable globally, then check it and reset it here. We do this in a sub # since we also need to handle the case of a more complex expression. if($ValClass[-1] eq 'd' || ($ValClass[-1] eq '"' && substr($ValPy[-1],0,1) ne 'f') || ($ValClass[-1] eq 'f' && $ValPerl[-1] eq 'undef')) { $new_state_var_init{$ValPy[1]}=$ValPy[-1]; } else { handle_dynamic_state_variable_init(); $TrStatus = assignment(1); gen_statement(); correct_nest(-1,-1); } } finish(); next; }elsif($ValClass[1] eq '('){ #this is a more complex case my $last=matching_br(1); if($#ValClass>$last && $ValClass[$last+1] eq '=' && init_has_real_values($last+2)){ # issue undef if($ValPerl[0] eq 'state' ){ rename_state_var(2,$last-1); } elsif($ValPerl[0] eq 'local') { copy_partially_initialized_locals(2, $last-1); } $TrStatus=assignment(1); # SNOOPYJC }else{ }elsif($last+3 == $#ValClass && $ValClass[$last+2] eq '(' && $ValPerl[$last+2] ne '(' && next_same_level_token(',', 2, $last-1) == -1) { # issue s154 # issue s154 Handle my ($aref) = [] -or- my ($href) = {} destroy($last,1); # issue s154 destroy(1,1); # issue s154 $TrStatus = assignment(1); # issue s154 }elsif($ValPerl[0] ne 'our') { # SNOOPYJC: Don't init 'our' variable my $val = undef; # SNOOPYJC for($i=2; $i<$last;$i++){ # SNOOPYJC: Run thru them all and see if they all have the same value my $sval = 'None'; if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{$CurSub}) { $sval = init_val($VarType{$ValPy[$i]}{$CurSub}); } elsif($ValClass[$i] =~ /[ah]/) { # issue s328 $sval = init_val($ValClass[$i]); # issue s328 } if(defined $val && $sval ne $val) { $val = undef; last; } $val = $sval; } if(defined $val) { # SNOOPYJC: they are all the same for($i=2; $i<$last;$i++){ if ($ValPy[$i] eq ','){ gen_chunk(' = '); }elsif($ValPerl[0] eq 'state'){ $new_name=$CurSub.'_'.$ValPy[$i]; $new_state_var_name{$ValPy[$i]}=$new_name; # issue test coverage gen_chunk($new_name); gen_chunk($ValPy[0],$new_name); # issue test coverage gen_statement(); # issue test coverage }else{ gen_chunk($ValPy[$i]); } } gen_chunk(" = $val") if($ValPerl[0] ne 'state'); # issue test coverage } else { # We need to do it one by one for($i=2; $i<$last;$i++){ next if ($ValPy[$i] eq ','); my $val = 'None'; if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{$CurSub}) { $val = init_val($VarType{$ValPy[$i]}{$CurSub}); } elsif($ValClass[$i] =~ /[ah]/) { # issue s328 $val = init_val($ValClass[$i]); # issue s328 } if($ValPerl[0] eq 'state'){ $new_name=$CurSub.'_'.$ValPy[$i]; $new_state_var_name{$ValPy[$i]}=$new_name; # issue test coverage gen_chunk($new_name); gen_chunk($ValPy[0],$new_name); # issue test coverage }else{ gen_chunk($ValPy[$i]); } if($ValPerl[0] ne 'state') { # issue test coverage gen_chunk(" = $val"); } gen_statement(); } } } }elsif( $ValClass[2] eq '=' ){ if( $ValPerl[0] eq 'state' ){ # issue 128: This case wasn't handled at all! $new_name=$CurSub.'_'.$ValPy[1]; $new_state_var_name{$ValPy[1]}=$new_name; gen_chunk($ValPy[0],$new_name); # issue 128: If we're initializing this from a non-constant, we can't move that # init out of the sub, as it could be a local variable or a global that has # a different value than where we place the assignment, so instead we generate # a flag variable globally, then check it and reset it here. handle_dynamic_state_variable_init(); } # issue s151 my $reg = next_same_level_token('~', 3, $#ValClass); # SNOOPYJC # issue s151 if($reg != -1 && $ValPerl[$reg] ne '~' && $reg+1 <= $#ValClass && $ValPerl[$reg+1] =~ /re|tr/) { # SNOOPYJC my $reg = next_same_level_token('p', 3, $#ValClass); # SNOOPYJC, issue s151 if($reg != -1 && $reg+1 <= $#ValClass && $ValPerl[$reg+1] =~ /re|tr/) { # SNOOPYJC, issue s151 $TrStatus=expression(1, $#ValClass, 0); # SNOOPYJC } else { $TrStatus=assignment(1); } if( $ValPerl[0] eq 'state' ) { gen_statement(); correct_nest(-1,-1); } }elsif(scalar(@ValClass) > 6 && $ValPerl[0] eq 'local' && $ValClass[1] eq 's' && $ValClass[2] eq '(' && next_same_level_token('=', 1, $#ValClass) > 2) { # issue 108 # local arr[NDX] = VAL; # local hsh{key] = VAL; gen_statement("$ValPy[1] = $ValPy[1].copy()"); $TrStatus=assignment(1); }elsif( $ValPerl[0] eq 'local') { ; # issue 108 ignore any local we didn't already handle }else{ $TrStatus=-255; } }elsif( $ValClass[0] eq 'h' ){ # hash to has need method copy # if( $#ValClass >= 2 && $ValClass[1] eq '=' ){ if( $ValPerl[2] eq '(' ){ # Special case hash initialization needs to be converted to dictionary initialization if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk($ValPy[0],'=','Hash','({'); } else { gen_chunk($ValPy[0].' = {'); } if(defined $ValCom[2] && length($ValCom[2]) > 1) { # issue s228: special case inline comments gen_chunk(' ' . $ValCom[2] . "\n"); # issue s228 $ValCom[2] = undef; # issue s228 } # issue s228 # issue 13: Handle a list of key, value, key, value by converting it to key: value, key: value #for( my $i=4; $i<$#ValPy; $i+=4 ) { # issue 13 #$ValPy[$i] = ":" if $ValPy[$i] eq ","; # issue 13 #} # issue 13 my $comma_flip = 0; # issue 13 my $last_was_colon = 0; # SNOOPYJC my $gen_expression = 1; # issue s327 for( my $i=3; $i<$#ValPy; $i++ ){ my $sep = next_same_level_tokens('A,)', $i, $#ValClass); # issue 126 if($sep-$i <= 1) { # issue 126 if( $ValClass[$i] eq 'i' ) { # issue 13 if( $LocalSub{$ValPy[$i]} && $ValClass[$i+1] ne 'A'){ # issue 13: local sub call with no parens, but not a hash key gen_chunk(escape_keywords($ValPy[$i])); # issue 13, issue 41 gen_chunk('()'); # issue 13 } elsif ($Constants{$ValPy[$i]}) { # issue 13: constant or file handle gen_chunk($ValPy[$i]); # issue 13 } elsif( $ValPerl[$i] eq $ValPy[$i]) { # issue 13 $ValPy[$i] = "'".$ValPy[$i]."'"; # issue 13 - put in quotes gen_chunk( $ValPy[$i] ); # issue 13 } else { # SNOOPYJC gen_chunk( $ValPy[$i] ); # SNOOPYJC } # issue 13 } elsif($ValPy[$i] eq ',' && $comma_flip == 0) { # issue 97 gen_chunk(': '); # issue 97 $last_was_colon = 1; $comma_flip = 1; # issue 97 } elsif($ValClass[$i] eq 'a' && !$last_was_colon) { # SNOOPYJC: We hit an array (not after a ':') gen_chunk("**{$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)}"); # SNOOPYJC $comma_flip = -1; # SNOOPYJC: Don't gen a colon $last_was_colon = 0; # SNOOPYJC } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '@s' && !$last_was_colon) { # issue s316: We hit an arrayref (not after a ':') if(&Pythonizer::vartype($i, $CurSub) =~ /^[as]/) { # issue s316 gen_chunk("**{$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)}"); # issue s316 } else { # issue s316 gen_chunk("**({$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)} if $ValPy[$i] is not None else {})"); } $comma_flip = -1; # issue s316: Don't gen a colon $last_was_colon = 0; # issue s316 } elsif($ValClass[$i] eq 'h' && !$last_was_colon) { # SNOOPYJC: We got a hash (not after a ':') gen_chunk('**', $ValPy[$i] ); # SNOOPYJC: Double-splat it out $comma_flip = -1; # SNOOPYJC: Don't gen a colon $last_was_colon = 0; # SNOOPYJC } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '%s' && !$last_was_colon) { # issue s316: We got a hashref (not after a ':') if(&Pythonizer::vartype($i, $CurSub) =~ /^[hs]/) { # issue s316 gen_chunk('**', $ValPy[$i] ); # issue s316: Double-splat it out } else { # issue s316 gen_chunk("**($ValPy[$i] if $ValPy[$i] is not None else {})"); # issue s316: Double-splat it out } $comma_flip = -1; # issue s316: Don't gen a colon $last_was_colon = 0; # issue s316 } else { # issue 13 gen_chunk( $ValPy[$i] ); $comma_flip = 1-$comma_flip if($ValPy[$i] eq ',' && $comma_flip != -1); # issue 97 $comma_flip = -1 if($ValPy[$i] =~ /^:\s?$/); # issue 97 if($ValPy[$i] eq ':' || $ValPy[$i] eq ': ') { $last_was_colon = 1; } elsif($ValPy[$i] ne '') { $last_was_colon = 0; # SNOOPYJC if(defined $ValCom[$i] && length($ValCom[$i]) > 1) { # issue s228: special case inline comments gen_chunk(' ' . $ValCom[$i] . "\n"); # issue s228 $ValCom[$i] = undef; # issue s228 } # issue s228 } } } else { # issue 126: have expression my $add_right_paren = 0; # issue s151 if(&Pythonizer::expr_type($i, $#ValClass, $CurSub) =~ /^a/ && !$last_was_colon) { my $t = &Pythonizer::expr_type($i, $sep-1, $CurSub); # issue s228 if($t =~ /^a/ && !$last_was_colon) { # issue s151 # Handle array function like map, and do ** _list_to_hash(expr) $Pyf{_list_to_hash} = 1; gen_chunk('**', '_list_to_hash', '('); $add_right_paren = 1; $comma_flip = -1; # Don't gen a colon } elsif($t =~ /^h/ && !$last_was_colon) { # issue s228 gen_chunk('**'); # Generate **({key=>val}) or **({key=>val} if Condition else {}) if($ValPerl[$i] eq '(' && $ValClass[$i+1] eq '(') { # If we have 2 parens, the first of which being an actual '(' $ValPy[$i+1] = '{'; # Force the second one to be a hash my $m = matching_br($i+1); $ValPy[$m] = '}'; if($m+1 < $#ValClass && $ValPerl[$m+1] eq '?') { # If we have a ? : operation, change both potential results to a hash my $colon = next_same_level_token(':', $m+2, $#ValClass); if($colon != -1 && $ValClass[$colon+1] eq '(') { $ValPy[$colon+1] = '{'; $m = matching_br($colon+1); $ValPy[$m] = '}'; } } } else { if($ValPerl[$i] eq '(') { $ValPy[$i] = '{'; my $m = matching_br($i); $ValPy[$m] = '}'; } # issue s316: Handle ? : without extra parens my $qm = next_same_level_token(':', $i, $sep-1); my $colon = next_same_level_token(':', $qm+1, $sep-1); if($qm != -1 && $colon != -1 && $ValClass[$colon+1] eq '(') { $ValPy[$colon+1] = '{'; $ValPy[matching_br($colon+1)] = '}'; } gen_chunk('('); $add_right_paren = 1; } $comma_flip = -1; } elsif(!$last_was_colon) { # issue s327 # If we have a mixed expression that includes a ? :, handle each term # of the ? : separately and do the combined right thing # At this point we have expr1 if cond else expr2 my $colon1 = next_same_level_token(':', $i, $sep-1); if($colon1 != -1 && $ValPerl[$colon1] eq '?') { my $colon2 = next_same_level_token(':', $colon1+1, $sep-1); if($colon2 != -1) { my $typ1 = &Pythonizer::expr_type($i, $colon1-1, $CurSub); my $typ2 = &Pythonizer::expr_type($colon2+1, $sep-1, $CurSub); if($typ1 =~ /^a/ || $typ2 =~ /^a/) { # Handle array function like map, and do ** _list_to_hash(expr) $Pyf{_list_to_hash} = 1; gen_chunk('**', '_list_to_hash', '('); $add_right_paren = 1; $comma_flip = -1; # Don't gen a colon if($typ1 =~ /^h/) { gen_chunk('['); $TrStatus = expression($i, $colon1-1, 2); # expr1 gen_chunk(']'); gen_chunk($ValPy[$colon1]); $TrStatus = expression($colon1+1, $colon2-1, 0); # cond gen_chunk($ValPy[$colon2]); $TrStatus = expression($colon2+1, $sep-1, 0); # expr2 $gen_expression = 0; $i = $sep-1; } elsif($typ2 =~ /^h/) { $TrStatus = expression($i, $colon1-1, 0); # expr1 gen_chunk($ValPy[$colon1]); $TrStatus = expression($colon1+1, $colon2-1, 0); # cond gen_chunk($ValPy[$colon2]); gen_chunk('['); $TrStatus = expression($colon2+1, $sep-1, 2); # expr2 gen_chunk(']'); $gen_expression = 0; $i = $sep-1; } } } } } $i = expression($i, $sep-1, 0) - 1 if $gen_expression; # issue s327 if($i < 0) { $TrStatus=-1; last; } gen_chunk(')') if $add_right_paren; $last_was_colon = 0; } } gen_chunk('}'); if($autovivification) { # SNOOPYJC gen_chunk(')'); } finish(); next; # SNOOPYJC }elsif( scalar(@ValClass)==2 && ($ValPerl[2] eq 'h' || $ValPerl[2] eq 'q') ){ }elsif( scalar(@ValClass)==3 && $ValClass[2] eq 'h') { # SNOOPYJC # issue 31 gen_chunk("$ValPy[0]=$ValPy[2].copy"); # copy structure not reference if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk("$ValPy[0] = ", 'Hash', "($ValPy[2])"); # SNOOPYJC copy structure not reference # issue 31 } else { gen_chunk("$ValPy[0] = $ValPy[2].copy()"); # copy structure not reference # issue 31 } finish(); next; }elsif( scalar(@ValClass)==3 && $ValClass[2] eq 's' && defined $ValType[2] && $ValType[2] eq '%s') { # issue s316: %h = %$href if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk("$ValPy[0] = ", 'Hash', "($ValPy[2] if $ValPy[2] is not None else {})"); # SNOOPYJC copy structure not reference # issue 31 } else { gen_chunk("$ValPy[0] = ($ValPy[2].copy() if $ValPy[2] is not None else {})"); # copy structure not reference # issue 31 } finish(); next; } elsif($#ValClass==2 && $ValClass[2] eq 'a') { # SNOOPYJC: %hash = @arr if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk("$ValPy[0] = ", 'Hash', "({$ValPy[2]"."[$INDEX_TEMP]:".$ValPy[2]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[2]."),2)})"); } else { gen_chunk("$ValPy[0] = {$ValPy[2]"."[$INDEX_TEMP]:".$ValPy[2]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[2]."),2)}"); } finish(); next; } elsif($#ValClass==2 && $ValClass[2] eq 's' && defined $ValType[2] && $ValType[2] eq '@s') { # issue s316: %hash = @$aref if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk("$ValPy[0] = ", 'Hash', "({$ValPy[2]"."[$INDEX_TEMP]:".$ValPy[2]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[2]."),2)} if $ValPy[2] is not None else {})"); } else { gen_chunk("$ValPy[0] = {$ValPy[2]"."[$INDEX_TEMP]:".$ValPy[2]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[2]."),2)} if $ValPy[2] is not None else {}"); } finish(); next; } elsif($#ValClass==2 && $ValClass[2] eq 'q' && $ValPy[2] =~ /\.split\(\)$/) { # issue s349: handle %h = qw(...) my $qw = $ValPy[2]; $qw =~ s/\.split\(\)$//; $qw = unquote_string($qw); @words = split ' ', $qw; gen_chunk($ValPy[0], '=', '{'); for(my $i = 0; $i < scalar(@words); $i += 2) { gen_chunk(',') unless $i == 0; gen_chunk(&Perlscan::escape_quotes($words[$i]), ':', &Perlscan::escape_quotes($words[$i+1])); } gen_chunk('}'); finish(); next; } } elsif($#ValClass == 0) { # SNOOPYJC: Hash definition (ignore it) finish(); next; } $TrStatus=assignment(0); }elsif($ValClass[0] eq 'a'){ if($#ValClass == 0) { # SNOOPYJC: Array definition (ignore it) finish(); next; } if( $ValClass[1] eq '=' ){ my $need_flatten = 0; # issue 102 if( $ValPerl[2] eq '(' && ($end_pos=matching_br(2)) == $#ValClass){ # issue 102 # array initialization # issue s130 # issue 102: need to smarten this code up. First see if what we have needs to be flattened, # issue s130 # if so and it's just one thing, we can avoid doing that. # issue s130 my $elements = 0; # issue s130 for(my $i=3; $i<$end_pos; $i++) { # issue s130 $elements++; # issue s130 if($ValClass[$i] =~ /[ah]/) { # issue s130 $need_flatten = 1; # issue s130 last if($elements>1); # issue s130 } elsif($ValClass[$i] eq 'f' && substr(&Pythonizer::func_type($ValPerl[$i], $ValPy[$i]),0,1) eq 'a') { # issue s130 $need_flatten = 1; # issue s130 last if($elements>1); # issue s130 $i = end_of_function($i); # issue s24 # issue s130 } elsif($i+2 <= $end_pos && ($ValClass[$i] eq 's' || $ValClass[$i] eq '"') && $ValClass[$i+1] eq '~' && $ValClass[$i+2] eq 'q' && substr($ValPy[$i+1],0,1) ne '.') { # see test_regex, issue s74 # issue s130 $need_flatten = 1; # issue s130 last if($elements>1); # issue s130 } # issue s130 my $pos = next_same_level_token(',', $i, $end_pos-1); # issue s130 $pos = $end_pos if($pos == -1); # issue s130 $i = $pos; # issue s130 } # issue s130 #say STDERR "need_flatten=$need_flatten, elements=$elements"; # issue s130 if($need_flatten && $elements==1) { # issue s130 destroy($end_pos, 1); # issue s130 destroy(2,1); # issue s130 $need_flatten = 0; # issue s130 } flatten_lists(2, 1); # issue s130 # gen_chunk($ValPy[0], '='); # issue s308 # gen_list(2, 1); # issue s308 # finish(); # issue s308 # next; # issue s308 } if( $#ValClass==2 && $ValClass[2] eq 'a'){ # Special case array to array copy # issue 31 gen_chunk("$ValPy[0]=$ValPy[2].copy"); if($ValPerl[2] eq '@_' && ($nested_sub_at_level > 0 || ($CurSub ne '__main__' && # issue s241 !exists $SubAttributes{$CurSub}{modifies_arglist}))) { # SNOOPYJC, issue 41, issue bootstrap !defined get_sub_attribute($CurSub, 'modifies_arglist')))) { # SNOOPYJC, issue 41, issue bootstrap, issue s241 # In this case our args are still a tuple, which has no ".copy()" operation if($autovivification) { # issue_s348 $Pyf{Array} = 1; # issue s348 gen_chunk("$ValPy[0] = ", 'Array', "($ValPy[2])"); # issue s348 } else { # issue s348 gen_chunk("$ValPy[0] = list($ValPy[2])"); } } elsif(substr($ValPy[2],0,1) eq '[') { # issue s338: List comprehension gen_chunk("$ValPy[0] = $ValPy[2]"); # issue s338: No need to copy it } else { gen_chunk("$ValPy[0] = $ValPy[2].copy()"); # issue 31 } finish(); next; } elsif($#ValClass==2 && $ValClass[2] eq 'h') { # SNOOPYJC: @arr = %hash # SNOOPYJC gen_chunk("$ValPy[0] = list(functools.reduce(lambda x,y:x+y,$ValPy[2].items()))"); if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; gen_chunk("$ValPy[0] = ", 'Array', "(itertools.chain.from_iterable($ValPy[2].items()))"); # SNOOPYJC } else { gen_chunk("$ValPy[0] = list(itertools.chain.from_iterable($ValPy[2].items()))"); # SNOOPYJC } finish(); next; } elsif($ValClass[2] eq 'f' && ($ValPerl[2] eq 'keys' || $ValPerl[2] eq 'values')) { # SNOOPYJC # python keys() and values() functions return something not subscriptable! if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; gen_chunk("$ValPy[0] = ", 'Array', '('); } else { gen_chunk("$ValPy[0] = list("); } $TrStatus=expression(2,$#ValClass,0); gen_chunk(')'); finish(); next; }elsif( $ValPerl[2] eq '(' && ($end_pos=matching_br(2)) == $#ValClass){ # SNOOPYJC # array initialization my $flatten = ''; my $flatten_end = ''; if($need_flatten) { $Pyf{'_flatten'} = 1; $flatten = '_flatten('; $flatten = "$PERLLIB.flatten(" if($import_perllib); $flatten_end = ')'; } if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; if($import_perllib) { $flatten = "$PERLLIB.Array(" . $flatten; } else { $flatten = 'Array(' . $flatten; } $flatten_end = ')' . $flatten_end; } # issue s308 gen_chunk($ValPy[0]," = $flatten",'['); # issue s308 for (my $i=3; $i<$end_pos; $i++){ # issue s308 my $pos = next_same_level_token(',', $i, $end_pos-1); # issue 102 # issue s308 $pos = $end_pos if($pos == -1); # issue 102 # issue s308 $TrStatus = expression($i, $pos-1, 0); # issue 102 # issue s308 $i = $pos; # issue s308 gen_chunk(',') if($ValClass[$i] eq ','); # issue s308 } # issue s308 gen_chunk("]$flatten_end"); gen_chunk($ValPy[0], '='); # issue s308 gen_chunk($flatten) if $flatten; # issue s308: Can only have 'Array(' now $ValPy[2] = '['; # issue s308 $ValPy[$end_pos] = ']'; # issue s308 $TrStatus = expression(2, $end_pos, 2); # issue s308 gen_chunk($flatten_end) if $flatten_end; # issue s308 finish(); next; }elsif( $ValPerl[2] =~ /<\w*>/ ){ # Special case of array initialization via slurping # issue 31 gen_chunk("$ValPy[0]=$ValPy[2].copy"); if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; gen_chunk("$ValPy[0] = ", 'Array', "($ValPy[2])"); # issue 31 } else { gen_chunk("$ValPy[0] = $ValPy[2].copy()"); # issue 31 } finish(); next; }elsif( $ValClass[2] eq 'a' && $ValPerl[3] eq '=' ){ my $last_eq=rindex($TokenStr,'='); if( $ValPerl[$last_eq+1] eq '(' ){ # list assignment @x=(1,2,3); $ValPy[$last_eq+1]='['; if( $ValPerl[-1] eq ')' ){ $ValPy[-1]=']'; }else{ $TrStatus=-255; finish(); next; } } for( $i=0; $i<$last_eq; $i+=2 ){ # cascade assignent processing @x=@y=@z if ($ValClass[$i+1] ne '='){ logme('S',"Token $ValPerl[$i+1] was found insted of '=' in what is expected to be array assignment"); $TrStatus=-255; last; } # issue test coverage if( $last_eq+1==@ValClass ){ if( $last_eq+1==$#ValClass ){ # issue test coverage # issue 31 gen_statement("$ValPy[$i]=$ValPy[-1].copy"); # last array is the source # issue s241 if($ValPerl[-1] eq '@_' && $CurSub ne '__main__' && !exists $SubAttributes{$CurSub}{modifies_arglist}) { # SNOOPYJC, issue 41 if(!$autovivification && # issue s348 $ValPerl[-1] eq '@_' && $CurSub ne '__main__' && !defined get_sub_attribute($CurSub, 'modifies_arglist')) { # SNOOPYJC, issue 41, issue s241 # In this case our args are still a tuple, which has no ".copy()" operation gen_statement("$ValPy[$i] = list($ValPy[-1])"); } elsif ($autovivification) { # SNOOPYJC $Pyf{Array} = 1; # issue s157 gen_statement("$ValPy[$i] = ", 'Array', "($ValPy[-1])"); # SNOOPYJC last array is the source # issue 31 gen_statement("$ValPy[$i] = " . ($import_perllib ? "$PERLLIB.Array" : 'Array') . "($ValPy[-1])"); # SNOOPYJC last array is the source # issue 31, issue s157 } else { gen_statement("$ValPy[$i] = $ValPy[-1].copy()"); # last array is the source # issue 31 } }elsif( $ValPerl[$last_eq+1] eq '(' ){ #left side is the list $a=@b=(1,2,3) gen_chunk("$ValPy[$i] = "); if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; gen_chunk('Array', '('); } expression($last_eq+1,$#ValClass); # processing (1,2,3) -- you need brackets here. Recursion level should be 0 if($autovivification) { # SNOOPYJC gen_chunk(')'); } gen_statement(); } } finish(); next; } } $TrStatus=assignment(0); }elsif($ValClass[0] eq 'G' && $#ValClass >= 1 && $ValClass[1] eq '=') { # SNOOPYJC: Handle glob assignment, issue s285 $TrStatus=assignment(0); # issue s3 - if the RHS is a reference to a sub, and we generated a package name for the assignment, # then also generate the assignment to the bare name as well. my $pd = rindex($ValPy[0], '.'); # issue s3 if($pd != -1 && scalar(@ValClass) == 4 && $ValClass[2] eq "\\" && $ValClass[3] eq 'i') { my $name = substr($ValPy[0],$pd+1); gen_statement(); gen_statement("$name = $ValPy[3]"); } }elsif($ValClass[0] eq '*' && $#ValClass >= 1 && $ValClass[1] eq '(' && $ValClass[matching_br(1)+1] eq '=') { # issue s76: *$tag = (changed to *{$tag} = by perlscan) $TrStatus=assignment(0); # issue s76 }elsif( $ValClass[0] eq 'c' ){ #normal control statement: if/while/for, etc -- next line is always nested. # in foreach loop "(" is absent ) do in perl you can's distibush between postfix for and foreach loop without parens # issue 19 if( defined($ValType[0]) && $ValType[0] eq 'P' && $ValClass[1] ne '(' && $ValPy[0] ne 'for' ){ if( defined($ValType[0]) && $ValType[0] eq 'P' && $ValPerl[0] ne 'for' && $ValPerl[0] ne 'foreach'){ # issue 19 # issue 19: If this control statement is not surrounded by parens, then add them in # We were fooled by "if (this or that) and options{debug}" as we assumed the first ( and the last } were # matching parens, which they are obviously not! $add_parens = 1; # issue 19 if($#ValClass >= 1 && $ValClass[1] eq '(') { # issue 19 $end_pos = matching_br(1); # issue 19 if($end_pos == $#ValClass) { $add_parens = 0; } # issue 19 } # issue 19 if($add_parens == 1) { # issue 19 if($#ValClass >= 1) { insert(1,'(','(','('); } else { append('(','(','('); } append(')',')',')'); } # issue 19 } if ($TokenStr=~/^c\([!n]f\(?/ && $ValPerl[3] eq 'open' ){ $TrStatus=open_fun(3,matching_br(1)-1,'c'); # SNOOPYJC: add extra param }elsif ($TokenStr=~/^c\([!n]f\(?/ && $ValPerl[3] eq 'opendir' ){ $TrStatus=open_dir(3,matching_br(1)-1,'c'); # SNOOPYJC: add extra param }else{ $TrStatus=control(0); # control now itself destroy the last ) Oct 14, 2020 --NNB } }elsif( $ValClass[0] eq 'C' ){ #next last continue eval elsif else do if( $ValPerl[0] eq 'elsif' ){ if($ValClass[1] ne '(') { # SNOOPYJC: We could have inserted an array sub expr in before the '(' append(')',')',')'); insert(1,'(','(','('); } $end_pos=matching_br(1); my $adjust = fixup_complex_assignment_in_control(2, $end_pos-1, 0); # issue 58, 103 $adjust = 0 if($adjust == -1); $end_pos -= $adjust; gen_chunk('elif '); if($adjust) { # issue 58: We have a := in there $TrStatus=expression(1,$end_pos,0); # Keep the parens } else { $TrStatus=expression(2,$end_pos-1,0); } gen_chunk(':'); gen_statement(); }elsif( $ValPerl[0] eq 'else' ){ gen_chunk('else:'); gen_statement(); }elsif( $ValPerl[0] eq 'eval' ) { # issue 42 my $was_block = gen_eval(0, 0); # issue 42, issue s13 pop @eval_stack unless($was_block); # issue s13 }elsif( $ValPerl[0] eq 'do' ) { # SNOOPYJC if($#ValClass > 0) { # issue s231 do_use_require(0); # issue s231 } else { gen_statement("$DO_CONTROL$. = True"); # SNOOPYJC gen_chunk("while $DO_CONTROL$.:"); # SNOOPYJC } }elsif($ValPy[0] eq 'default') { # issue s129 gen_chunk('if', '1', ':'); gen_statement(); }elsif($ValPerl[0] eq 'continue') { # issue s129 if(scalar(@Perlscan::nesting_stack)) { # issue s129 $top = $Perlscan::nesting_stack[-1]; # issue s129 if($top->{type} eq 'when') { # issue s129 $top->{fallthrough} = 1; # issue s129 } elsif(&Perlscan::in_when()) { # issue s129 logme('S',"Sorry, conditional continue in a case/when is not supported"); # issue s129 } # issue s129 } } }elsif( $ValClass[0] eq 'f' ){ #this is a left hand function like is substr($line,0,1)='' or open or chomp; if( $ValPerl[0] eq 'substr' ){ $TrStatus=left_hand_substr(0); }elsif( $ValPerl[0] eq 'chomp' ){ if( $#ValPerl==0) { if(default_var_string()) { # issue s104 gen_chunk(qq[$DEFAULT_VAR=$DEFAULT_VAR.rstrip("\\n")]); # chomp with no argumnets # issue 32 } else { gen_chunk(qq[$DEFAULT_VAR=$CONVERTER_MAP{S}($DEFAULT_VAR).rstrip("\\n")]); # issue s104 } }else{ function(0,$#ValClass); } }elsif( $ValPerl[0] eq 'chop' ){ # SNOOPYJC if( $ValPerl[1] eq '(' ){ # SNOOPYJC if( $ValClass[2] eq 's' ){ # SNOOPYJC gen_chunk($ValPy[2].'='.$ValPy[2].'[0:-1]'); # SNOOPYJC } else{ # SNOOPYJC $TrStatus=-1; # SNOOPYJC } # SNOOPYJC }else{ if($#ValPerl==0) { # SNOOPYJC if(default_var_string()) { # issue s104 gen_chunk("$DEFAULT_VAR = ${DEFAULT_VAR}[0:-1]"); # issue 32 } else { gen_chunk("$DEFAULT_VAR = $CONVERTER_MAP{S}(${DEFAULT_VAR})[0:-1]"); # issue s104 } } else { # SNOOPYJC function(0,$#ValClass); # SNOOPYJC } # SNOOPYJC }elsif( $ValPerl[0] eq 'open' ){ $rc=open_fun(0,$#ValClass,'s'); # SNOOPYJC: Add extra param }elsif( $ValPerl[0] eq 'opendir' ){ # SNOOPYJC $rc=open_dir(0,$#ValClass,'s'); }elsif($ValPerl[0] eq 'pos') { # SNOOPYJC: Not supported logme('S',"Sorry, pos assignment is not supported"); # SNOOPYJC $TrStatus=expression(0,$#ValClass,0); # SNOOPYJC: They could have f(s)+f(s) }elsif($ValPy[0] eq '_last_ndx' && ($k=next_same_level_token('=', 0, $#ValClass)) != -1) { # issue s154: handle code in TiedArray.pm: STORESIZE $Pyf{"_set_last_ndx"} = 1; replace(0, 'f', '_set_last_ndx', '_set_last_ndx'); if($ValPy[$k] ne '=' && $ValPy[$k] ne ':=') { # handle +=, -=, etc $op = substr($ValPerl[$split],0,1); append($op,$op,$op); for(my $i=0; $i<$k; $i++) { append($ValClass[$i],$ValPerl[$i],$ValPy[$i]); } } append(')',')',')'); replace($k, ',', ',', ','); destroy($k-1,1); # should be the ')' replace(1, '(', '(', '('); # This may be a '[' - make it a regular '(' $TrStatus=function(0); } elsif($ValPerl[0] eq 'warn') { # issue s288 $Pyf{_warn} = 1; # issue s288 gen_chunk('_warn', '('); # issue s288 my $start = 1; my $end_pos = $#ValClass; if($start <= $#ValClass && $ValPerl[$start] eq '(') { $end_pos = matching_br($start) - 1; $start++; } $TrStatus = expression($start, $end_pos, 2) if $start <= $end_pos; # issue s288 gen_chunk(')'); # issue s288 } elsif($#ValClass == 5 && $ValPerl[0] eq '%SIG' && $ValPerl[1] eq '{' && $ValClass[2] eq 'd' && $ValPerl[3] eq '}' && $ValClass[4] eq '=' && $ValClass[5] eq '"') { # issue s277: $SIG{ALRM} = sub... (multi-line case) gen_chunk($ValPy[0], '(', $ValPy[2], ',', $ValPy[5], ')'); # issue s277: signal.signal(signal.SIGARLM, _fNN) } elsif($#ValClass == 5 && $ValPerl[0] eq '%SIG' && $ValPerl[1] eq '{' && $ValClass[2] eq '"' && $ValPerl[3] eq '}' && $ValClass[4] eq '=' && $ValClass[5] eq '"') { # issue s336 $SIG{ALRM} = sub... (multi-line case) gen_chunk($ValPy[0], '(', unquote_string($ValPy[2]), ',', $ValPy[5], ')'); # issue s336: signal.signal(signal.SIGARLM, _fNN) }else{ # $TrStatus=function(0); $TrStatus=expression(0,$#ValClass,0); # SNOOPYJC: They could have f(s)+f(s) } }elsif( $ValClass[0] eq 'x' ){ # this is backquotes if(1 || $traceback || $trace_run) { # issue traceback - use this always so we can pick the shell on windows $Pyf{_run_s} = 1; # issue 118: use the scalar context version because it's faster gen_chunk('_run_s', '(', $ValPy[0], ')'); # issue 118 gen_statement(); } else { gen_chunk(qq{$DEFAULT_VAR = subprocess.run($ValPy[0],capture_output=True,text=True,shell=True)}); gen_statement(); if($autodie || exists $SpecialVarsUsed{'$?'}) { # SNOOPYJC gen_chunk(qq[$SUBPROCESS_RC = ${DEFAULT_VAR}.returncode]); } if($autodie) { gen_statement(); gen_statement("if $SUBPROCESS_RC:"); correct_nest(1,1); gen_statement("raise Die(f'run(" . escape_string(unquote_string($ValPy[0]), "'") . "): failed with {$SUBPROCESS_RC}')"); correct_nest(-1,-1); } } }elsif( $ValClass[0] eq 'd' ){ if( length($TokenStr)==1 ){ # SNOOPYJC: just ignore it! if($CurSub eq 'main' && scalar(@eval_stack) == 0) { # issue 45: could be the return value of a sub # issue 42 or eval # SNOOPYJC: just ignore it! logme('W','line starts with digit'); # SNOOPYJC: just ignore it! } # issue 45 # issue 45 }else{ }elsif($CurSub eq '__main__' && scalar(@eval_stack) == 0) { # issue 45: could be the return value of a sub # issue 42 or eval, issue 41 $TrStatus=-1; } }elsif( $ValClass[0] eq '(' ){ # (/abc/) && a=b; (a{lno}; my $suffix = $eval_stack[-1]->{suffix}; # issue s13 gen_chunk("$EVAL_RESULT$lno$suffix = "); my $mode = -1; $mode = 0 if($ValClass[1] eq '(' && next_same_level_tokens('=,', 2, $#ValClass-1) != -1); # keep the parens if we have a tuple or assignment expr my $add_paren = convert_return_expression(1, $#ValClass); # issue s9, issue s3 $TrStatus = expression(1,$#ValClass,$mode); # -1 means to eat any surrounding () gen_chunk($add_paren) if($add_paren); } gen_statement(); gen_statement("raise $EVAL_RETURN_EXCEPTION"); $eval_stack[-1]->{had_return} = 1; } elsif($ValPy[0] eq 'return' && &Perlscan::in_BEGIN() && !&Perlscan::in_sub()) { # issue s12, issue s29 if(&Perlscan::return_in_BEGIN_needs_raise()) { # issue s30 my $ex_name = label_exception_name(&Perlscan::begin_loop_label()); $Pyf{_raise} = 1; gen_chunk('_raise', "($ex_name('break'))"); gen_statement(); } else { gen_statement("break"); # issue s12 } } elsif($ValPy[0] eq 'return' && $CurSub eq '__main__' && $nested_sub_at_level < 0) { # SNOOPYJC, issue 41, issue 78 gen_statement("if __name__ == '__main__':"); correct_nest(1,1); gen_statement('raise Die("Can\'t return outside a function")'); # SNOOPYJC correct_nest(-1,-1); logme('W',"Attempt to return outside a subroutine will die if executed from main"); # SNOOPYJC } elsif($ValPerl[0] eq 'use' || $ValPerl[0] eq 'require' || $ValPerl[0] eq 'no') { # SNOOPYJC # issue s152 do_use_require(0); # SNOOPYJC my $cur_pos = do_use_require(0); # SNOOPYJC, issue s152 if($cur_pos <= $#ValClass) { # issue s152 $cur_pos++ if(index('&|-+*/o0', $ValClass[$cur_pos]) != -1); # issue s152: ignore initial operator, if any $TrStatus = expression($cur_pos, $#ValClass, 0); # issue s152: Process the rest } # issue s152 } elsif($ValPerl[0] eq 'goto') { # SNOOPYJC gen_statement('__goto_sub__ = True'); # issue s244e, issue s260: hint for _caller to ignore this frame my $cs = &Perlscan::cur_sub(); # issue s293 if($ValClass[1] eq 'i' && $LocalSub{$ValPy[1]} && $cs ne '__main__') { # issue 41, issue s293 gen_chunk('return'); if(inherited_wantarray(1)) { # issue s241 if(3 <= $#ValClass && $ValPerl[2] eq '(' && $ValPerl[3] ne '@_') { # issue s280: We have to call the sub to get the coderef gen_chunk(escape_keywords($ValPy[1]), '('); # issue s280 $TrStatus = expression(3, $#ValClass-1, 0) if(3 <= $#ValClass-1); # issue s280 gen_chunk(')', "(*$PERL_ARG_ARRAY, wantarray=wantarray)"); # issue s280 } else { gen_chunk(escape_keywords($ValPy[1]),"(*$PERL_ARG_ARRAY, wantarray=wantarray)"); # issue s241 } } else { if(3 <= $#ValClass && $ValPerl[2] eq '(' && $ValPerl[3] ne '@_') { # issue s280: We have to call the sub to get the coderef gen_chunk(escape_keywords($ValPy[1]), '('); # issue s280 $TrStatus = expression(3, $#ValClass-1, 0) if(3 <= $#ValClass-1); # issue s280 gen_chunk(')', "(*$PERL_ARG_ARRAY)"); # issue s280 } else { gen_chunk(escape_keywords($ValPy[1]),"(*$PERL_ARG_ARRAY)"); } } } elsif($ValClass[1] eq '\\' && $ValClass[2] eq 'i' && $LocalSub{$ValPy[2]} && $cs ne '__main__') { # issue 41, issue s293 gen_chunk('return'); if(inherited_wantarray(2)) { # issue s241 gen_chunk(escape_keywords($ValPy[2]),"(*$PERL_ARG_ARRAY, wantarray=wantarray)"); # issue s241 } else { gen_chunk(escape_keywords($ValPy[2]),"(*$PERL_ARG_ARRAY)"); } } elsif($ValClass[1] eq '&' && $ValClass[2] eq 's' && $cs ne '__main__') { # SNOOPYJC goto &$func_ref;, issue s293 gen_chunk('return'); if(inherited_wantarray(2)) { # issue s241 gen_chunk($ValPy[2],"(*$PERL_ARG_ARRAY, wantarray=wantarray)"); # issue s241 } else { gen_chunk($ValPy[2],"(*$PERL_ARG_ARRAY)"); } } elsif($ValClass[1] eq 'f' && $#ValClass == 1 && $cs ne '__main__') { # issue s58, issue s293 append('a', '@_', "$PERL_ARG_ARRAY"); # issue s58 gen_chunk('return'); # issue s58 $TrStatus = function(1); # issue s58 } else { logme('S', "goto $ValPerl[1] is not supported!"); if($Pythonizer::CurNest) { # SNOOPYJC output_line('pass',' #SKIPPED: '.$line); # issue 96 } else { output_line('','#SKIPPED: '.$line); } $line=getline(); next; } } elsif($ValPerl[0] eq 'break' && !&Perlscan::in_when()) { # issue s170 gen_statement('raise Die("Can\'t \'break\' outside a given/switch block")'); # issue s170 logme('W',"Attempt to break outside a given/switch block will die if executed"); # issue s170 } else { if( $#ValClass == 0 ){ #say STDOUT "$ValPy[0], we_are_in_sub_body=$we_are_in_sub_body, CurNest=$Pythonizer::CurNest, NextNest=$Pythonizer::NextNest"; my $cs = &Perlscan::cur_sub(); # issue s241 if($ValPerl[0] eq 'next' && scalar(@Perlscan::nesting_stack) && $Perlscan::nesting_stack[-1]->{type} eq 'when') { # issue s129 $Perlscan::nesting_stack[-1]->{fallthrough} = 1; # issue s129 } elsif($ValPerl[0] eq 'next' && &Perlscan::in_when()) { # issue s129 logme('S',"Sorry, conditional next in a case/when is not supported"); # issue s129 } elsif($ValPerl[0] eq 'next' && exists $aliased_foreach_subs{$cs} && !&Perlscan::in_loop()) { # issue s252 gen_chunk('return', $nested_subs{$cs}); # issue s252 } elsif($ValPerl[0] eq 'return' && defined get_sub_attribute($cs, 'wantarray')) { # issue s241 gen_chunk($ValPy[0]); # issue s241 if($autovivification) { # issue s241 $Pyf{Array} = 1; # issue s241 gen_chunk('Array', '()', 'if', 'wantarray', 'else', 'None'); # issue s241 } else { # issue s241 gen_chunk('[]', 'if', 'wantarray', 'else', 'None'); # issue s241 } # issue s241 } else { # issue s129 if(($ValPerl[0] eq 'next' || $ValPerl[0] eq 'last') && &Perlscan::next_last_needs_raise(0)) { # issue bootstrap my $ex_name = label_exception_name(undef); my $ex_name = label_exception_name(&Perlscan::cur_loop_label()); # issue bootstrap gen_chunk("raise $ex_name('$ValPy[0]')"); } else { gen_chunk($ValPy[0]); } } }elsif($ValPy[0] eq 'return') { # issue s9, issue s3 gen_chunk($ValPy[0]); my $add_paren = convert_return_expression(1, $#ValClass); $TrStatus=expression(1,$#ValClass,0); # Can be this will scan till ')' gen_chunk($add_paren) if($add_paren); # issue s9 }elsif( $ValClass[1] eq '(' ){ $TrStatus=expression(0,$#ValClass,0); # Can be this will scan till ')' }elsif($ValClass[1] eq 'i' && ($ValPerl[0] eq 'next' || $ValPerl[0] eq 'last' || $ValPerl[0] eq 'redo')) { # issue 94 if($ValPerl[1] eq &Perlscan::cur_loop_label() && ($ValPerl[0] eq 'redo' || !&Perlscan::next_last_needs_raise(0))) { gen_chunk($ValPy[0]); } else { # next LABEL or last LABEL, with LABEL not the last one we saw # NOTE: This "last one we saw" business had to be turned off since # not all blocks have to be labeled!! my $ex_name = label_exception_name($ValPerl[1]); gen_chunk("raise $ex_name('$ValPy[0]')"); } }else{ # last 2 gen_chunk($ValPy[0]); $TrStatus=expression(1,$#ValClass); # this will scan till ')' } } }elsif( $ValClass[0] eq 'i' ){ # user defined functon if( $#ValClass>0 && $ValClass[1] eq '(' ){ $right_br=matching_br(1); if( $ValClass[2] eq ')' ){ # function with zero arguments # issue s141 if( $ValPy[0] eq 'main' && $Pythonizer::CurNest==0 ){ # issue s141 my $globals=substr($GlobalVar{$CurSub},length('global')); # issue s141 $globals=~tr/,/=/; # issue s141 gen_statement($globals.'=None'); # issue s141 } &Perlscan::add_package_name_sub(0); # SNOOPYJC # issue s241 if(exists $SubAttributes{$ValPy[0]}{wantarray}) { # issue s226 if(defined get_sub_attribute($ValPy[0], 'wantarray')) { # issue s226, issue s241 gen_chunk(escape_keywords($ValPy[0]).'(wantarray=None)'); # issue s226 } else { gen_chunk(escape_keywords($ValPy[0]).'()'); # issue 13 } gen_extra($right_br+1, $#ValClass); # issue 116 }elsif( $ValClass[2] eq 'f' && ( $ValClass[3] ne '(' || ($ValClass[3] eq '(' && matching_br(3) == $right_br-1)) ){ # bracketless call of built-in function as a single argument: get_config(split / /,$line) # or bracketed call to built-in function call that return list. We do not need sqare brackets &Perlscan::add_package_name_sub(0); # SNOOPYJC gen_chunk(escape_keywords($ValPy[0]),'('); if(need_splat(2)) { # issue s308 gen_chunk('*'); # issue s308 } # issue s308 function(2,$right_br-1); # we assume that evethying in brackets is the function call # issue s241 if(exists $SubAttributes{$ValPy[0]}{wantarray}) { # issue s226 if(defined get_sub_attribute($ValPy[0], 'wantarray')) { # issue s226, issue s241 gen_chunk(', wantarray=None'); # issue s226 } # issue s226 gen_chunk(')'); gen_extra($right_br+1, $#ValClass); # issue 116 }else{ # In all other cases we will put sqare bracket, even if they are redundant: they can be manually deleted. # SNOOPYJC gen_chunk(escape_keywords($ValPy[0])); # issue 13 # SNOOPYJC gen_chunk('('); # SNOOPYJC $TrStatus=expression(2,$#ValClass-1,-1); # this will scan till ')' and should eliminate ')' due to -1 as 3-d arg # SNOOPYJC gen_chunk(')'); # issue s241 if(exists $SubAttributes{$ValPy[0]}{wantarray}) { # issue s226 if(defined get_sub_attribute($ValPy[0], 'wantarray')) { # issue s226, issue s241 &Perlscan::add_package_name_sub(0); # issue s226 gen_chunk(escape_keywords($ValPy[0]),'('); # issue s226 $TrStatus = expression(2, $right_br-1,0); # issue s226 gen_chunk(', wantarray=None)'); # issue s226 gen_extra($right_br+1, $#ValClass); # issue s226 } else { $TrStatus=expression(0,$#ValClass,0); # Generate the entire function call in expression so *arr can be handled } } }elsif($#ValClass == 1 && $ValClass[1] eq ':') { # SNOOPYJC: Label output_line('',"# $ValPerl[0]"); # issue 94 $Perlscan::PREV_HAD_COLON = 0; # SNOOPYJC }else{ $RecursionLevel=-1; $TrStatus=expression(0,$#ValClass); # this will scan till ')' } # issue s151 }elsif( ($split=index($TokenStr,'~'))>-1 && $ValPerl[$split] ne '~') { # issue 73, SNOOPYJC: Handle the '~' operator properly }elsif( ($split=index($TokenStr,'p'))>-1) { # issue 73, SNOOPYJC: Handle the '~' operator properly, issue s151 $k=regex_and_translate(0,0,$split,$#ValClass); # issue 73, issue 106 if($k < 0) { # issue 73 $TrStatus=-1; # issue 73 } # issue 73 }elsif(index($TokenStr,'D')>-1) { # SNOOPYJC: Some sort of OO construct such as $fh->autoflush(1); $RecursionLevel=-1; $TrStatus=expression(0,$#ValClass); # this will scan till ')' }elsif($ValClass[0] eq 'q' && substr($ValPy[0],0,1) eq '(' && substr($ValPy[0],-1,1) eq ')') { # issue s39: handle regex match alone # Example code: # Lexem 0 Current token='q' perl='\A(.*)\z' value='(_m:=re.search(re.compile(r'\A(.*)\Z',re.S),_str(_d)))' Tokenstr |q| if($ValPy[0] =~ /$DEFAULT_MATCH:=/) { $ValPy[0] =~ s/:=/ = /; # We can generate a normal assignment in this case $ValPy[0] = substr($ValPy[0],1,length($ValPy[0])-2); # Remove the opening and closing parens } $TrStatus=expression(0,$#ValClass); # this will scan till the end }else{ if($debug >= 1) { say STDERR "Main loop: Unknown statement (@ValClass)"; } # issue s252 if($CurSub eq '__main__' && scalar(@eval_stack) == 0 && $nested_sub_at_level < 0) { # issue 45: ignore string as statement in sub - may be changed to "return 'string'" # issue 42 or eval, issue 41 # issue s252 $TrStatus=-1; # issue s252 } # issue 45 if(index('0o){ chomp $l; $l=~ s/[\r]//g; say Pythonizer::SYSOUT $l; # Quietly output line } close $fh; } } # # Epilog -- close output file and if you are in debugging mode display the content on the screen # if (scalar(@NoTrans)>0) { say STDERR "\nATTENTION!\nThe following lines were probably translated incorrectly:\n"; say STDERR join("\n",@NoTrans); } Pythonizer::move_defs_before_refs(); # SNOOPYJC Pythonizer::pretty_print_python() if($black); # SNOOPYJC Pythonizer::create_link_if_needed(); # issue s211 $rc=summary(); # print diagnostic messages summary exit $rc; sub handle_dynamic_state_variable_init # issue 128 # We have a state variable that we have to only initialize once so here is where # we make that happen. { my $new_name = $new_state_var_name{$ValPy[1]}; my $flag_name = state_flag_name($new_name); gen_statement(); gen_statement("global $flag_name"); gen_statement("if $flag_name:"); correct_nest(1,1); gen_statement("$flag_name = False"); $new_state_var_init{$ValPy[1]} = '$flag'; # Special value that gets checked below $ValPy[1] = $new_name; } sub fixup_complex_assignment_in_control # issue 58, 103 # See if we have a complex assignment in a control statement like for, foreach, while, elsif # and if so, fix it up to use a simple variable that python allows in a := operation. We play # lots of games to get the actual assignment generated inside the control statement, and also # in an else clause that we generate if there isn't one already. # Returns the # of tokens we removed if it does a replacement, or -1 if we didn't do anything { my $start = shift; # Point after the '(' my $end_pos = shift; # Point before the ')' my $no_delete = shift; # issue ddts: If set, don't delete any tokens, just fill them in with NOPs my $need_deferred_statement = 0; my $add_right_paren = 0; if(($k=next_same_level_token('=', $start, $end_pos))>-1 && ($ValClass[$k-1] !~ /[ahs]/ || $ValPy[$k-1] !~ /[A-Za-z0-9_]+/)) { # issue 58: complex assignment $need_deferred_statement = 1; } elsif($ValClass[$start] eq 'f' && ($ValPerl[$start] eq 'chop' || $ValPerl[$start] eq 'chomp') && $ValClass[$start+1] eq '(' && ($k=next_same_level_token('=', $start+2, $end_pos))>-1) { # issue ddts $need_deferred_statement = 1; $add_right_paren = 1; } if($need_deferred_statement) { $deferred_statement = 1; # In the elif/while/for body we will generate the "complex_stuff=_e" assignment $deferred_statement_nesting = $Perlscan::nesting_level; @DeferredValClass=@ValClass[$start..$k]; @DeferredValCom=@ValCom[$start..$k]; @DeferredValPerl=@ValPerl[$start..$k]; @DeferredValPy=@ValPy[$start..$k]; @DeferredValType=@ValType[$start..$k]; $DeferredValPy[$k-$start] = '='; # Replace := with = my $expr_type = &Pythonizer::expr_type($k+1, $end_pos, $CurSub); $VarType{$ELSIF_TEMP}{$CurSub} = $expr_type; push @DeferredValClass, expr_type_to_token_type($expr_type); push @DeferredValCom, ''; push @DeferredValPerl, $ELSIF_TEMP; push @DeferredValPy, $ELSIF_TEMP; push @DeferredValType, ''; if($add_right_paren) { push @DeferredValClass, ')'; push @DeferredValCom, ''; push @DeferredValPerl, ')'; push @DeferredValPy, ')'; push @DeferredValType, ''; } replace(2, 'a', $ELSIF_TEMP, $ELSIF_TEMP); # Change it to _e:=expression if($no_delete) { for(my $i=3; $i<$k; $i++) { replace($i, 'y', '', ''); } } else { destroy(3,$k-3) if($k >= 3); } my $result = ($no_delete ? 0 : ($k-3)); say STDERR "fixup_complex_assignment_in_control = $result =|$TokenStr|=, ValPy=@ValPy" if($debug); return $result; } return -1; # didn't do anything } sub replace_incr_decr_stmt # SNOOPYJC # Replace ++x --x x++ and x-- if on the statement level with x+-1 or x-=1 # This is what we have to produce anyway and it simplifies the checking # in fix_type_issues. { return if(scalar(@ValClass) < 2); my $pop = '+='; # issue s158 if($ValClass[0] eq '^') { my $com = ''; # issue s228 if($ValClass[0] eq '^' && end_of_variable(1) == $#ValClass) { # issue s158: handle ++$errors, subcall(); $pop = '-=' if($ValPerl[0] eq '--'); destroy(0, 1); # issue s158 } elsif($ValClass[$#ValClass] eq '^' && $ValClass[0] eq 's') { } elsif($ValClass[$#ValClass] eq '^' && $ValClass[0] eq 's' && end_of_variable(0) == $#ValClass-1) { # issue s158: handle subcall(), $errors++ $pop = '-=' if($ValPerl[$#ValClass] eq '--'); $com = $ValCom[$#ValClass] if(scalar(@ValCom) > $#ValClass); # issue s228 destroy($#ValClass, 1); } else { return; } # At this point all we have left is the operand append('=', $pop, $pop); append('d', '1', '1'); $ValCom[$#ValClass] = $com if $com; # issue s228 say STDERR "replace_incr_decr_stmt: now =|$TokenStr|=" if($debug >= 1); } sub end_of_variable # Given a 's' scalar variable reference, return the end_pos of the reference, # e.g. if it's $s, then return the same pos, but if it's $s[4]{'k'} then return # the end of those tokens. # Also works if you give it a parenthesized expression, function, or sub ref { my $pos = shift; my $k; my $result; $pos++ if($ValClass[$pos] eq '\\'); # issue s184: Skip taking the address of a variable if($ValClass[$pos] =~ /[if]/ && $pos+1 <= $#ValClass && $ValClass[$pos+1] eq '(') { $result = matching_br($pos+1); return ($result==-1 ? $pos : $result); } if($ValClass[$pos] eq '(') { $result = matching_br($pos); #return ($result==-1 ? $pos : $result); return $pos if $result < 0; $pos = $result; } while($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '(' && ($ValPerl[$pos+1] eq '{' || $ValPerl[$pos+1] eq '[') && ($k = matching_br($pos+1)) != -1) { $pos = $k; } # issue bootstrapping return $pos if($ValClass[$pos] ne 's'); if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'D') { # '->' if($pos+2 <= $#ValClass && $ValClass[$pos+2] eq 'i') { # $obj->field if($pos+3 <= $#ValClass && $ValClass[$pos+3] eq '(') { # Method call $result = matching_br($pos+3); return ($result==-1 ? $pos+2 : $result); } return $pos+2; } $pos += 1; # Could be $href->{...} or $aref->[...] } return $pos; } sub operator_type # If this is an operator, what type is needed? If not an operator, return undef { my $p = shift; my $left = shift; # 1 if we want the left operand type, else 0 (if it matters) $cl = $ValClass[$p]; return 'S' if($cl eq '.'); if($cl eq '~') { # issue s151 return 'N' if($ValPerl[$p] eq '~'); # real int '~' operator, not a match # issue s151 return 'S' return ($uses_integer ? 'I' : 'N'); # issue s151: bitwise-not, use integer } elsif($cl eq 'p') { # issue s151: pattern match return 'S'; # issue s151 } # issue s151 if(index('HI^>=+*/%-', $cl) >= 0) { # issue s65 return 'S' if($left && $cl eq '*' && $ValPerl[$p] eq 'x'); # x operator is string x integer if($left && $cl eq '*' && $ValPerl[$p] eq 'x') { # issue s65: x operator is string x integer (usually) # issue s65: if the operand is in parens or is a qw// list, then don't convert it to a string if($p != 0 && ($ValClass[$p-1] eq ')' || ($ValClass[$p-1] eq 'q' && $ValPy[$p-1] =~ /\.split\(\)$/))) { return undef; } return 'S' } return undef if(!$left && $cl eq '*' && ($p == 0 || index(',;(=o0', $ValClass[$p-1]) != -1)); # issue s151: * at the beginning is NOT a multiply return undef if(!$left && $cl eq '+' && ($p == 0 || index(',;(=o0', $ValClass[$p-1]) != -1)); # issue s223: unary + does not change the type in perl - it does nothing! return 'I' if(!$left && $cl eq '*' && $ValPerl[$p] eq 'x'); # x operator is string x integer return 'S' if($cl eq '>' && $ValPerl[$p] =~ /^[a-z]/); # e.g. ne, eq, le, cmp, ... return 'S' if($cl eq '=' && $ValPerl[$p] eq '.='); return undef if($cl eq '=' && $ValPerl[$p] eq '='); # Regular assignment return 'I' if $uses_integer; # use integer return 'N'; } elsif(index('&|', $cl) >= 0) { # And/Or return 'I'; } elsif($cl eq 'f' && exists $PyFuncType{$ValPy[$p]}) { return substr($PyFuncType{$ValPy[$p]}, 0, 1) if(!$left); } elsif($cl eq 'f' && exists $FuncType{$ValPerl[$p]}) { return substr($FuncType{$ValPerl[$p]}, 0, 1) if(!$left); } elsif(!$left && $cl eq ':' && $ValPy[$p] eq 'else') { # issue s96 my $prior = get_prior_operator_from_if_else($p); # issue s96 return undef unless($prior); # issue s96 return operator_type($prior); # issue s96 } return undef; } sub tighter_type # issue s151 # Return the tighter of the 2 types, e.g. I & N gives I { my $t1 = shift; my $t2 = shift; return $t1 unless defined $t2; return $t2 unless defined $t1; return $t1 if $t1 eq $t2; return $t2 if $t1 =~ /^[msu]$/ && $t2 =~ /^[NIFSHs]$/; return $t1 if $t2 =~ /^[msu]$/ && $t1 =~ /^[NIFSHs]$/; return $t2 if $t1 eq 'N' && $t2 =~ /^[IFB]$/; return $t1 if $t2 eq 'N' && $t1 =~ /^[IFB]$/; if($t1 =~ /^a of / && $t2 =~ /^a of /) { $t1 =~ s/^a of //; $t2 =~ s/^a of //; return 'a of ' . tighter_type($t1, $t2); } if($t1 =~ /^h of / && $t2 =~ /^h of /) { $t1 =~ s/^h of //; $t2 =~ s/^h of //; return 'h of ' . tighter_type($t1, $t2); } return $t2 if $t2 =~ /^a of / && $t1 eq 'a'; return $t1 if $t1 =~ /^h of / && $t2 eq 'h'; return $t2 if $t2 =~ /^a of / && $t1 eq 'a'; return $t1 if $t1 =~ /^h of / && $t2 eq 'h'; return $t2 if $t1 =~ /^[msu]$/ && $t2 ne 'u'; return $t2 if $t1 =~ /^[a-z]$/ && $t2 =~ /^[A-Z]$/; return $t1; } sub get_prior_operator_from_if_else # issue s96 # Given the ':' (else) operator, return the operator before the ':' (if), if any, else return undef { my $else = shift; my $if = get_if_from_else($else); return undef unless defined($if); return undef if $if == 0; my $start = start_of_expr($if-1); return undef if $start == 0; return $start-1; } sub get_if_from_else # issue s96 # Given the ':' (else) operator, return the ':' (if) operator. This is from a transformed ? : operation { my $else = shift; for(my $p = $else - 1; $p >= 1; $p--) { $p = start_of_expr($p); if($p-1 > 0 && $ValClass[$p-1] eq ':') { if($ValPy[$p-1] eq 'else') { $p = get_if_from_else($p-1); } elsif($ValPy[$p-1] eq 'if') { return $p-1; } } } return undef; } sub insert_converter # If we need a converter, insert it and return the # of elements inserted, else return 0 { my $start = shift; # Start of expr my $limit = shift; # End of expr my $i = shift; # Start of item my $k = shift; # End of item my $type = shift; # Type we need return 0 if($k < $i); $t_left = $t_right = undef; #no warnings 'uninitialized'; return 0 if($i != 0 && $ValClass[$i-1] eq '\\'); # issue s188: Don't convert a reference return 0 if($ValClass[$i] eq '\\'); # issue s188: " return 0 if $ValClass[$i] eq '(' && $ValPerl[$i] eq '(' && $i+1 == $k && $ValClass[$k] eq ')' && $ValPerl[$k] eq ')'; # issue s315: Don't convert a '()' if($i-1 >= $start) { $t_left = operator_type($i-1, 0); #say STDERR "operator_type($i-1) = $t_left"; # TEMP } if($k+1 <= $limit) { $t_right = operator_type($k+1, 1); # issue s8 return 0 if($ValClass[$k+1] eq '~' && $i == $start); # $var =~ s/a/b/; or something like that # issue s151 if($ValClass[$k+1] eq '~' && $ValPerl[$k+1] eq '=~' && $ValClass[$start] eq '(' && matching_br($start) == $k && if($ValClass[$k+1] eq 'p' && $ValClass[$start] eq '(' && matching_br($start) == $k && # issue s151 next_same_level_token('=', $start+1, $k-1) != -1) { # issue s143: If this is like ($x = $y) =~ regex, then don't return 0; # issue s143: insert a converter around the parens } # issue s143 #say STDERR "operator_type($k+1) = $t_right"; # TEMP # issue s151 } elsif($k+1 <= $#ValClass && $ValClass[$k+1] eq '~' && $ValPerl[$k+1] eq '=~' && $ValClass[$start] eq '(' && matching_br($start) == $k && } elsif($k+1 <= $#ValClass && $ValClass[$k+1] eq 'p' && $ValClass[$start] eq '(' && matching_br($start) == $k && # issue s151 next_same_level_token('=', $start+1, $k-1) != -1) { # issue s143: If this is like ($x = $y) =~ regex, then don't return 0; # issue s143: insert a converter around the parens } # issue s143 my $t = (defined $t_left) ? $t_left: $t_right; if(defined $t_left && defined $t_right) { my $p_left = $Perlscan::token_precedence{$ValClass[$i-1]}; my $p_right = $Perlscan::token_precedence{$ValClass[$k+1]}; $t = $t_right if($p_right > $p_left); } $t = $type if(!defined $t); $t = $type if(defined $type && index('IF', $type) >= 0 && defined $t && $t ne 'I'); my $converter = get_converter($i, $k, $t); if($debug >= 3 && defined $converter) { no warnings 'uninitialized'; say STDERR "insert_converter($start, $limit, $i, $k, $type): for =|$TokenStr|=, $ValPerl[$i], t=$t, converter=$converter"; } return 0 if(!defined $converter); my $adjust = 0; my $j; if($k+1 <= $#ValClass && $ValClass[$k+1] eq '=') { if($ValPerl[$k+1] ne '=') { no warnings 'uninitialized'; say STDERR "insert_converter($start, $limit, $i, $k, $type): for =|$TokenStr|=, $ValPerl[$i], t=$t, converter=$converter - calling expand_augmented_assignment" if($debug >= 3); my $adj; ($i, $k, $adj) = expand_augmented_assignment($i, $k+1, $limit, 0); $limit += $adj; $adjust += $adj; } else { return 0; # Don't put the function directly on the LHS of an assignment! } } elsif(($j = next_same_level_token('=', $i, $k))!= -1) { # If this is an assignment, point to the RHS if($ValPerl[$j] eq '=') { # Regular '=' $i = $j+1; } else { say STDERR "insert_converter($start, $limit, $i, $k, $type): for =|$TokenStr|=, $ValPerl[$i], t=$t, converter=$converter, j=$j - calling expand_augmented_assignment" if($debug >= 3); my $adj; ($i, $k, $adj) = expand_augmented_assignment($i, $j, $limit, 0); $limit += $adj; $adjust += $adj; } } insert($k+1, ')', ')', ')'); while($i-2 >= 0 && $ValClass[$i-1] eq 'D' && $ValClass[$i-2] eq 'i') { # Handle FH->autoflush(1) $i -= 2; } insert($i, '(', '(', '('); insert($i, 'f', $converter, $converter); if($debug >= 3) { no warnings 'uninitialized'; say STDERR "insert_converter($start, $limit, $i, $k, $type): new =|$TokenStr|=, $ValPerl[$i], result = 3+$adjust"; } return 3 + $adjust; } sub expand_augmented_assignment # Take an augumented assignment, like $i += 2, and change it to $i = $i + 2 so we can do a type conversion on $i. # Of course this is the simplest case. We need to handle the hard cases like $arr[$i+=1]+=1 too! # Returns the new start and end of the expression we moved to the RHS and the adjustment factor of how many tokens # we added or removed. { my $start = shift; # start of expression my $equals = shift; # points to the '=' my $end_pos = shift; # issue s257 my $pre_assign = shift; # issue s148: if true, pre-assign the temp variable instead of using := my $total_adjust = 0; # How many tokens we added # Determine the token, perl, and python versions of the operation my $pl = $op = substr($ValPerl[$equals], 0, length($ValPerl[$equals])-1); my $py = substr($ValPy[$equals], 0, length($ValPy[$equals])-1); $op = 'H' if($op eq '<<'); $op = 'I' if($op eq '>>'); $op = '*' if($op eq '**'); replace($equals, '=', '=', '='); # Change to plain '=' insert($equals+1, $op, $pl, $py); # Insert the +,-,* or whatever operator it is $total_adjust++; my $i; for($i = $equals-1; $i >= $start; $i--) { # Insert a full copy of the LHS insert($equals+1, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); $total_adjust++; } my $new_start = $equals+1; my $new_end = $new_start+$total_adjust-2; # issue s257: If the expression on the RHS includes a lower precedence operator, then we need to put it in parens # else the +/-/* or whatever we just added will be done first! Example: $url .= $vh || server_name(); was being # incorrectly transformed to $url = $url . $vh || server_name();, which is evaluated as # $url = $url . $vh || server_name();, but it actually should be: # $url = $url . ($vh || server_name()); $end_pos += $total_adjust; # issue s257 my $lower = next_lower_or_equal_precedent_token($op, $new_end+2, $end_pos); # issue s257 if($lower != -1) { # issue s257 insert($end_pos+1, ')', ')', ')'); # issue s257 insert($new_end+2, '(', '(', '('); # issue s257: $new_end+2 points one after the $op $total_adjust += 2; # issue s257 } if(is_expression_simple($start, $equals-1)) { say STDERR "expand_augmented_assignment($start, $equals, $end_pos, $pre_assign) simple: gives =|$TokenStr|=, ValPy=@ValPy, new_start=$new_start, new_end=$new_end, adjust=$total_adjust" if($debug>=1); return ($new_start, $new_end, $total_adjust); } # Now the fun begins! Walk thru looking for subscripts that we can grab the value of in # a temp variable (using the := operator in python) and replace the corresponding LHS with # a reference to that temp variable. my $copy = $equals+1; # Where our copy starts $i = $start; my $suffix = 0; my $adjust = 0; my $eq = $equals; #$DB::single = 1; for($i = index($TokenStr, '(', $i); $i >= 0 && $i < $eq; $i = index($TokenStr, '(', $i+1)) { my $sub_start = $i+1; my $sub_end = matching_br($i)-1; $i = $sub_end+1; next if($ValPerl[$sub_start-1] ne '{' && $ValPerl[$sub_start-1] ne '['); last if($sub_end < 0); if(is_expression_simple($sub_start, $sub_end)) { say STDERR "expand_augmented_assignment: Leaving $sub_start..$sub_end alone - simple expression" if($debug >= 3); next; } # We found something to do, start by creating our temp var and then finding the corresponding spot in the RHS $temp = $SUBSCRIPT_TEMP . $suffix; $suffix++; my $rhs_start = $sub_start + $copy - $start; my $rhs_end = $sub_end + $copy - $start; insert($rhs_end+1, ')', ')', ')') unless($pre_assign); # issue s148 my $rhs_eq = next_same_level_token('=', $rhs_start, $rhs_end); # issue s148 if($rhs_eq != -1 && !$pre_assign) { # issue s148 insert($rhs_end+1, ')', ')', ')'); # issue s148 insert($rhs_start, '(', '(', '('); # issue s148 } # issue s148 if($pre_assign) { # issue s148 insert($rhs_start, '=', '=', '='); # issue s148 } else { insert($rhs_start, '=', '=', ':='); } insert($rhs_start, 's', $temp, $temp); insert($rhs_start, '(', '(', '(') unless($pre_assign); if($pre_assign) { assignment($rhs_start, $rhs_end+2); gen_statement(); replace($rhs_start, 's', $temp, $temp); destroy($rhs_start+1, ($rhs_end+3)-($rhs_start+1)); } replace($sub_start, 's', $temp, $temp); destroy($sub_start+1, $sub_end-$sub_start); $adjust = 4 - ($sub_end-$sub_start); $adjust += 2 if($rhs_eq != -1 && !$pre_assign); # issue s148 $adjust -= (($rhs_end+3)-($rhs_start+1)) if $pre_assign; # issue s148 $i = $sub_start+1; # Point back to the ']' $eq -= ($sub_end-$sub_start); # Point back to '=' $new_start -= ($sub_end-$sub_start); # Point back to the start of our expression on the RHS $new_end += $adjust; $copy += 4; # Adjust by the # we inserted $total_adjust += $adjust; say STDERR "expand_augmented_assignment($start, $equals, $limit, $pre_assign) did =|$TokenStr|= i=$i, eq=$eq, new_start=$new_start, new_end=$new_end, copy=$copy, adjust=$adjust, total_adjust=$total_adjust, ValPy=@ValPy" if($debug >= 5); } say STDERR "expand_augmented_assignment($start, $equals, $limit, $pre_assign) gives =|$TokenStr|=, new_start=$new_start, new_end=$new_end, adjust=$total_adjust, ValPy=@ValPy" if($debug>=1); return ($new_start, $new_end, $total_adjust); } sub get_converter # Get the right converter for this variable to the specified type. Returns undef if no conversion is needed. { my $var_start = shift; my $var_end = shift; my $type = shift; return undef if(!defined $type); return undef if(!exists $CONVERTER_MAP{$type}); return undef if($ValClass[$var_start] eq 'y'); # special python code $v_type = &Pythonizer::expr_type($var_start, $var_end, $CurSub); return undef if($type eq $v_type); return undef if($type eq 'N' && $v_type =~ /[IF]/); return undef if($type eq 'a of N' && $v_type =~ /^a of [IF]/); # test list util # issue code coverage: do some constant conversions here: if($var_start == $var_end) { if($ValClass[$var_start] eq 'd') { if($type eq 'I') { $ValPy[$var_start] =~ s/_//g; $ValPy[$var_start] = int($ValPy[$var_start]); return undef; } elsif($type eq 'F') { if($ValPy[$var_start] =~ /^0x/) { # issue s69 $ValPy[$var_start] = hex($ValPy[$var_start]) . '.0'; return undef } elsif($ValPy[$var_start] =~ /^0o/) { # issue s69 $ValPy[$var_start] = int(0+('0' . substr($ValPy[$var_start],2))) . '.0'; return undef } elsif($ValPy[$var_start] !~ /\./ && $ValPy[$var_start] !~ /e/i) { $ValPy[$var_start] .= '.0'; return undef; } } elsif($type eq 'S') { replace($var_start, '"', $ValPerl[$var_start], "'" . $ValPy[$var_start] . "'"); return undef; } } elsif($ValClass[$var_start] eq '"' && substr($ValPy[$var_start],0,1) ne 'f') { if(exists $CONSTANT_MAP{$ValPerl[$var_start]} && $ValPy[$var_start] =~ /$CONSTANT_MAP{$ValPerl[$var_start]}/) { # issue s277 replace($var_start, 'd', $ValPerl[$var_start], unquote_string($ValPy[$var_start])); # issue s277: Don't map e.g. signal.SIGALRM to 0!! return undef; } elsif($type eq 'I') { no warnings 'numeric'; replace($var_start, 'd', $ValPerl[$var_start], int(0+unquote_string($ValPy[$var_start]))); return undef; } elsif($type eq 'F' || $type eq 'N') { no warnings 'numeric'; replace($var_start, 'd', $ValPerl[$var_start], 0+unquote_string($ValPy[$var_start])); return undef; } } } return $CONVERTER_MAP{$type}; } sub fix_type_issues # Fixup issues with variable types and how perl automatically converts things to the proper type e.g. # strings used in numeric contexts. This is a recursive function, and returns the adjustment factor # of how many tokens we added. It uses the functions _num(), _str(), and _int() to make the conversions. # _int() is used in subscripts. We make use of the type information we gathered in pass 1 to see # if we can eliminate as many of these conversions as possible. FIXME: As a desired enhancement, we # should "peephole optimize" the code, which means keeping track of the exact type of each variable # in assignment statements in each basic block of code, so that if you say "$j = 1", we know that # "$j" is an int in the same block even if it gets set to a string elsewhere. Once we hit a merge # point, e.g. a "}", then all bets are off! { my $start = shift; my $limit = shift; my $type = shift; if($debug >= 3) { no warnings 'uninitialized'; debug_start_end("fix_type_issues($start, $limit, $type) =|%|= ValPerl=@ValPerl, ValPy=@ValPy", $start, $limit); } my $total_adjust = 0; my $k; my $ot; my $adjust; my $opt; return if(scalar(@ValClass) == 0 || ($ValClass[0] eq 'k' && $ValPerl[0] eq 'sub')); return 0 if($start > $limit); my $orig_type = $type; # issue s151 $type = undef if defined $type && &Pythonizer::expr_type($start, $limit, $CurSub) eq $type; # issue s151 return fix_type_issues($start+1, $limit, $type) if($ValClass[$start] eq 'f' && ($ValPy[$start] eq 'print' || $ValPy[$start] eq 'wprint' || $ValPy[$start] eq 'printf')); # issue printf, issue s101 if(defined $type && $type eq 'I') { # issue s129: Handle range in subscript my $r = next_same_level_token('r', $start, $limit); if($r != -1) { return fix_type_issues($start, $r-1, $type) + fix_type_issues($r+1, $limit, $type); } # Issue s148: Handle @arr[sub1,sub2,sub3] my $c = next_same_level_token(',', $start, $limit); if($c != -1) { return fix_type_issues($start, $c-1, $type) + fix_type_issues($c+1, $limit, $type); } } for(my $i=$start; $i<=$limit; $i++) { $k = $i; no warnings 'uninitialized'; say STDERR "fix_type_issues($start, $limit, $type): checking $ValPerl[$i] at $i, limit=$limit" if($debug >= 5); if($ValClass[$i] eq 'f') { #next if(!exists $PyFuncType{$ValPy[$i]}); my $f_type = undef; if(exists $PyFuncType{$ValPy[$i]}) { $f_type = $PyFuncType{$ValPy[$i]}; } elsif(exists $FuncType{$ValPerl[$i]}) { $f_type = $FuncType{$ValPerl[$i]}; } else { logme('W', "fix_type_issues($start, $limit, $type): no PyFuncType{$ValPy[$i]} nor FuncType{$ValPerl[$i]}"); $i+=2 if($i+2 <= $limit && $ValClass[$i+1] eq '(' && $ValClass[$i+2] eq ')'); next; } my $t_pos = 0; my $last_t; # test list util my $eof = end_of_function($i); # test list util if($i+1 <= $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '(') { # issue s154: Handle bless {...}, $class my $endbr = matching_br($i+1); return if($endbr < 0); for(my $j = $i+2; $j < $endbr; $j++) { my $comma = -1; if($ValClass[$j] eq 'f') { # issue s237: if we have _logical_xor(0, max 2, 3) - the second comma isn't ours! my $l = end_of_function($j)+1; # issue s237 # issue s271 $comma = next_same_level_token(',', $l, $endbr) if $l <= $endbr; # issue s237 $comma = next_same_level_tokens(',A', $l, $endbr) if $l <= $endbr; # issue s237, issue s271 } else { # issue s237 # issue s271 $comma = next_same_level_token(',', $j, $endbr); $comma = next_same_level_tokens(',A', $j, $endbr); # issue s271 } my $ep = (($comma==-1) ? $endbr-1 : $comma-1); my $t = substr($f_type, $t_pos, 1); if($t eq 'a' && substr($f_type, $t_pos) =~ /^a of ?/) { # test list util $t = substr($f_type, $t_pos, 6); # test list util $t_pos += 5; # test list util $last_t = $t; # test list util } $t = substr($f_type, ++$t_pos, 1) if($t eq '?'); if($t eq ':') { if(defined $last_t) { # test list util $t = $last_t; # test list util $t_pos--; # test list util } else { $t = substr($f_type, --$t_pos, 1); } } $t = substr($f_type, --$t_pos, 1) if($t eq '?'); $t_pos++; if($t eq 'H' && $ValClass[$j] =~ /[isf]/) { # e.g. print(H a,b); $j = end_of_variable($j); $j++ if($j+1 == $comma); next; # issue bootstrap } elsif($ValClass[$j] =~ /[ah]/) { # We will * an array, and iterate a hash, so just skip this # issue bootstrap last; } elsif($t eq 'S' && $ValPerl[$i] eq 'grep' && $ValPerl[$i+1] eq '{') { $adjust = fix_type_issues($j, $endbr-1, undef); $endbr += $adjust; $limit += $adjust; $total_adjust += $adjust; $endbr = end_of_variable($endbr+1); # bump past the @arr at the end last; # Don't convert the function result on a grep {...} @arr } else { if($ValClass[$j] eq 'q' && $ValClass[$ep] eq 'i' && $j+1 == $ep) { # ignore flags on regex $adjust = fix_type_issues($j, $j, $t); } elsif($ValClass[$j] =~ /[ah]/) { # We will * an array, and iterate a hash, but do check if it's subscripted if($t =~ /^a of ?/) { # test list util $adjust = fix_type_issues($j, $ep, $t); # test list util } else { # test list util $adjust = fix_type_issues($j, $ep, undef); # issue bootstrap } } elsif($t =~ /^a of ?/ && !need_splat($j)) { # test list util $adjust = fix_type_issues($j, $endbr-1, $t); # test list util $ep = $endbr-1; # test list util } else { $adjust = fix_type_issues($j, $ep, $t); } $ep += $adjust; $endbr += $adjust; $limit += $adjust; $total_adjust += $adjust; } $j = $ep+1; } $k = $endbr; } else { # Unbracketed function call my $end_pos = $limit; if($i != 0 && $ValClass[$i-1] eq '(') { # If the whole thing is in brackets, we know where to stop $end_pos = matching_br($i-1) - 1; return if $end_pos < 0; } my $j; for($j = $i+1; $j <= $end_pos; $j++) { my $comma = next_lower_or_equal_precedent_token('F', $j, $end_pos); my $close = next_same_level_token(')', $j, $end_pos); my $ep = (($comma==-1) ? $end_pos : $comma-1); $ep = $close-1 if($close!=-1 && $close-1 < $ep); my $optional = 0; my $t = substr($f_type, $t_pos, 1); if($t eq 'a' && substr($f_type, $t_pos) =~ /^a of ?/) { # test list util $t = substr($f_type, $t_pos, 6); # test list util $t_pos += 5; # test list util $last_t = $t; # test list util } $optional = 1 if($t_pos < length($f_type) && substr($f_type, $t_pos+1, 1) eq '?'); # issue s80 $t = substr($f_type, ++$t_pos, 1) if($t eq '?'); if($t eq ':') { if(defined $last_t) { # test list util $t = $last_t; # test list util $t_pos--; # test list util } else { $t = substr($f_type, --$t_pos, 1) if($t_pos > 0); # issue s151 $t = substr($f_type, --$t_pos, 1) if($t eq '?'); } # itest list util last if($t ne 'a'); last if(substr($t,0,1) ne 'a'); # test list util } $t_pos++; if($t eq 'H' && $ValClass[$j] =~ /[isf]/) { # e.g. print H a,b; $j = end_of_variable($j); $j++ if($j+1 == $comma); next; # issue bootstrap } elsif($ValClass[$j] =~ /[ah]/) { # We will * an array, and iterate a hash, so just skip this # issue bootstrap last; } elsif($optional && ($j == 0 || $ValClass[$j-1] ne ',') && # issue s52 # issue s52 index("^*~/%+-.HI>&|0or?:=,A", $ValClass[$j]) >= 0) { # issue s151 index("^*~/%.HI>&|0or?:=,A", $ValClass[$j]) >= 0) { # issue s52: Eliminated unary ops here index("^*p/%.HI>&|0or?:=,A", $ValClass[$j]) >= 0) { # issue s52: Eliminated unary ops here, issue s151 $j--; last; } else { if($ValClass[$j] eq 'q' && $ValClass[$ep] eq 'i' && $j+1 == $ep) { # ignore flags on regex $adjust = fix_type_issues($j, $j, $t); } elsif($ValClass[$j] =~ /[ah]/) { # We will * an array, and iterate a hash, but do check if it's subscripted if($t =~ /^a of ?/) { # test list util $adjust = fix_type_issues($j, $ep, $t); # test list util } else { $adjust = fix_type_issues($j, $j, undef); # issue bootstrap } } elsif($t =~ /^a of ?/ && !need_splat($j)) { # test list util my $en = $eof; $en = $end_pos if($en > $end_pos); # test list util if($j <= $en) { # test list util $adjust = fix_type_issues($j, $en, $t); # test list util $ep = $en; # test list util } else { # test list util $adjust = fix_type_issues($j, $ep, undef); # test list util } # test list util } else { $adjust = fix_type_issues($j, $ep, $t); } $comma += $adjust; $ep += $adjust; $end_pos += $adjust; $limit += $adjust; $total_adjust += $adjust; } # issue s271 if($comma >= 0 && $ValClass[$comma] ne ',') { if($comma >= 0 && $ValClass[$comma] ne ',' && $ValClass[$comma] ne 'A') { # issue s271 $j = $ep; last; } $j = $ep+1; } # issue s151 $k = $j; $k = end_of_function($k); # issue s151 $k = $end_pos if($k > $end_pos); } } elsif($ValClass[$i] eq 'i' && ($LocalSub{$ValPy[$i]} || $i+1 <= $#ValClass && $ValClass[$i+1] eq '(')) { # Known local sub call or unknown sub call if($i+1 <= $#ValClass && $ValClass[$i+1] eq '(') { # sub(...) my $endbr = matching_br($i+1); return if($endbr < 0); for(my $j = $i+2; $j < $endbr; $j++) { # issue s271 my $comma = next_same_level_token(',', $j, $endbr); my $comma = next_same_level_tokens(',A', $j, $endbr); # isseu s271 my $ep = (($comma==-1) ? $endbr-1 : $comma-1); if($ValClass[$j] eq 'a') { # We will * an array, so just skip this last; } $adjust = fix_type_issues($j, $ep, undef); $ep += $adjust; $endbr += $adjust; $limit += $adjust; $total_adjust += $adjust; $j = $ep+1; } $k = $endbr; } else { # Unbracketed function call my $end_pos = $limit; if($i != 0 && $ValClass[$i-1] eq '(') { # If the whole thing is in brackets, we know where to stop $end_pos = matching_br($i-1) - 1; return if $end_pos < 0; } my $j; for($j = $i+1; $j <= $end_pos; $j++) { my $comma = next_lower_or_equal_precedent_token(',', $j, $end_pos); my $ep = (($comma==-1) ? $end_pos : $comma-1); if($ValClass[$j] eq 'a') { # We will * an array, so just skip this $j--; # issue s11 last; # issue s151 } elsif(index("^*~/%+-.HI>&|0or?:=,A", $ValClass[$j]) >= 0) { # Operator is next - that's it! } elsif(index("^*~p/%+-.HI>&|0or?:=,A", $ValClass[$j]) >= 0) { # Operator is next - that's it!, issue s151 $j--; # issue s11 last; } $adjust = fix_type_issues($j, $ep, undef); $ep += $adjust; $comma += $adjust; $limit += $adjust; $end_pos += $adjust; $total_adjust += $adjust; # issue s271 if($comma >= 0 && $ValClass[$comma] ne ',') { if($comma >= 0 && $ValClass[$comma] ne ',' && $ValClass[$comma] ne 'A') { # issue s271 $j = $ep; last; } $j = $ep+1; } $k = $j; $k = $end_pos if($k > $end_pos); } } elsif($ValClass[$i] =~ /[sd"]/ || # Scalar, digits, or string ($ValClass[$i] =~ /[ah]/ && $ValPy[$i] !~ /^len\(/)) { # issue bootstrap: @{$hash{key}} wasn't converting key to str $k = end_of_variable($i); say STDERR "end_of_variable $ValPerl[$i] at $i = $k" if($debug >= 5); my $t = undef; if($k != $i) { # Process subscripts if($ValPerl[$i] eq '$ENV' && $k+2 <= $#ValClass && $ValClass[$k+1] eq '=') { # issue s298 $adjust = fix_type_issues($k+2, $limit, 'S'); # issue s298 $total_adjust += $adjust; # issue s298 } # issue s298 my $firstsub = next_same_level_token('(', $i, $k); if($firstsub != -1) { for(my $j = $firstsub; $j < $k; $j++) { $t = 'S'; next unless $ValClass[$j] eq '('; # issue s236: Skip '->' etc if($ValPerl[$j] eq '[') { # Array subscript $t = 'I'; } elsif($ValPerl[$j] eq '(') { # This is like s->i(...) - not a subscript! last; } my $m = matching_br($j); return if $m < 0; # issue bootstrap: Handle array as hash key or array index on the last one my $ty; if($ValClass[$i] =~ /[ah]/ && $m == $k && ($ty = &Pythonizer::expr_type($j+1, $k-1, $CurSub)) =~ /^a/) { $t = 'a of ' . $t; $t = undef if($t eq $ty); # it's already correct } $adjust = fix_type_issues($j+1, $m-1, $t); # this should work if we have @arr[sub1,sub2,sub3] $m += $adjust; $limit += $adjust; $k += $adjust; $total_adjust += $adjust; $j = $m; } } } } elsif($ValClass[$i] =~ /[ah]/ && $ValPy[$i] =~ /^len\(/) { # Scalar context $k = $i; # Not good to look backwards because we may have a function with non-parenthesised arguments #} elsif(defined ($ot = operator_type($i))) { #if($ValClass[$i-1] eq ')' && $ValPerl[$i-1] eq ')') { #my $j=reverse_matching_br($i-1); #while($j-1 >= 0 && $ValClass[$j-1] =~ /[if]/) { #$j--; #} #$adjust = insert_converter($start, $limit, $j, $i-1, $ot); #$total_adjust += $adjust; #$i += $adjust; #$limit += $adjust; #} # Not good to look forward since our $adjust will only pertain to SOME of the pointers #if($i+1 <= $#ValClass && $ValClass[$i+1] eq '(') { #$k = matching_br($i+1); #$adjust = insert_converter($start, $limit, $i+1, $k, $ot); #$total_adjust += $adjust; #$limit += $adjust; #} #next; } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '(') { $k = matching_br($i); return $total_adjust if $k < 0; if(&Pythonizer::expr_type($i+1, $k-1, $CurSub) =~ /^a/ && $k+1 < $limit && $ValPerl[$k+1] eq '[') { # issue s129: Array expression subscript my $m = matching_br($k+1); return $total_adjust if $m < 0; $adjust = fix_type_issues($k+2, $m-1, 'I'); # subscript needs to be int type $m += $adjust; $limit += $adjust; $total_adjust += $adjust; $k = $m; if(defined $type) { $adjust = insert_converter($start, $limit, $i, $k, $type); # Convert the whole thing $total_adjust += $adjust; return $total_adjust; } } if($k+1 < $limit && defined($ot = operator_type($k+1, 1))) { $adjust = fix_type_issues($i, $k, $ot); $k += $adjust; $limit += $adjust; $total_adjust += $adjust; $i = $k; } elsif(defined $type && $type =~ /^a of / && next_same_level_token(',', $i+1, $k-1) != -1) { # If we're trying to fix the type of an expression as an array of something, and we hit a parenthesized list, # then we don't want to make each element of the list into an array of something. $adjust = fix_type_issues($i, $k, undef); $k += $adjust; $limit += $adjust; $total_adjust += $adjust; $i = $k; } next; } elsif($ValClass[$i] eq ')' && $ValPerl[$i] eq ')') { $k = reverse_matching_br($i); if($k > 0 && defined($ot = operator_type($k-1, 0))) { $adjust = insert_converter($start, $limit, $k, $i, $ot); $total_adjust += $adjust; $i += $adjust; $limit += $adjust; } next; #} elsif($opt = operator_type($i) && $opt ne $type) { #$adjust = insert_converter($start, $limit, $start, $i-1, $opt); #$total_adjust += $adjust; #$i += $adjust; #$k += $adjust; #$limit += $adjust; } elsif(($opt = operator_type($i, 0)) && $opt ne $orig_type && $i+1 < $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '(') { # issue s151 # Apply the operator right hand type to the parenthesized expression $k = matching_br($i+1); return $total_adjust if $k < 0; if(&Pythonizer::expr_type($i+2, $k-1, $CurSub) =~ /^a/ && $k+1 < $limit && $ValPerl[$k+1] eq '[') { # issue s129: Array expression subscript my $m = matching_br($k+1); return $total_adjust if $m < 0; $adjust = fix_type_issues($k+2, $m-1, 'I'); # subscript needs to be int type $m += $adjust; $limit += $adjust; $total_adjust += $adjust; $k = $m; $adjust = fix_type_issues($i+1, $k, $opt); } else { $adjust = fix_type_issues($i+2, $k-1, $opt); } $k += $adjust; $limit += $adjust; $total_adjust += $adjust; $i = $k; next; } elsif(($opt = operator_type($i, 0)) && $opt ne $orig_type && $i+1 < $#ValClass) { # issue s151: convert what follows ~ operator my $nlet = next_lower_or_equal_precedent_token($ValClass[$i], $i+1, $limit); my $close = next_same_level_tokens(');', $i+1, $limit); $nlet = $close if $close != -1 && ($close < $nlet || $nlet == -1); $nlet = $limit+1 if $nlet == -1; $tt = tighter_type($opt, $orig_type); { no warnings 'uninitialized'; say STDERR "fix_type_issues: for $ValClass[$i] with type $tt = tighter_type($opt, $orig_type), recursing" if($debug); } $adjust = fix_type_issues($i+1, $nlet-1, $tt); $limit += $adjust; $total_adjust += $adjust; $nlet += $adjust; $i = $nlet-1; next; } elsif($ValClass[$i] eq ';' && $ValPy[0] ne 'for') { # See it inside a anon sub return $total_adjust + fix_type_issues($i+1, $k, $type) if($i+1 >= $k); return $total_adjust; } elsif($ValClass[$i] eq ':' && $ValPy[$i] eq 'if') { # issue 90: Converted ? : operator - first part - next is bool expr my $colon = next_same_level_token(':', $i+1, $limit); if($colon != -1) { $adjust = fix_type_issues($i+1, $colon-1, undef); $colon += $adjust; $limit += $adjust; $total_adjust += $adjust; $i = $colon; next; } } elsif($ValClass[$i] eq '(' && $ValPerl[$i] ne '(' && defined $type && $type =~ /^a of /) { # When entering a list, we no longer want an array type for each element $k = matching_br($i); return if $k < 0; $adjust = fix_type_issues($i+1, $k-1, undef); $k += $adjust; $limit += $adjust; $total_adjust += $adjust; $i = $k; next; } else { next; } # issue s113: If this is an OO call, then include that as part of the expression if($k+1 < $#ValClass && $ValClass[$k+1] eq 'D') { # issue s113 $k += 2; if($k+1 < $#ValClass && $ValClass[$k+1] eq '(') { $k = matching_br($k+1); } } # issue s264: If this is an expression followed by a hash key or array index, then include # that as part of the expression if($type && $k+1 < $#ValClass && $ValClass[$k+1] eq '(') { # issue s264 $k = matching_br($k+1); } if($type =~ /^a of / && ($start != $i || $limit != $k)) { # test list util: Don't convert each argument - we do the whole thing later $adjust = 0; # test list util } else { # test list util $adjust = insert_converter($start, $limit, $i, $k, $type); } $total_adjust += $adjust; $i = $k + $adjust; $limit += $adjust; } # Do one last check to make sure the whole expression is of the desired type $adjust = insert_converter($start, $limit, $start, $limit, $type); $total_adjust += $adjust; if($total_adjust && $debug >= 3) { say STDERR "After fix_type_issues: =|$TokenStr|=, \@ValPy: @ValPy"; } return $total_adjust; } sub fix_multi_subscripts # issue 84 { # Replace code that pulls multiple subscripts from an array or expression # e.g. @arr[0,1,4] @{$hash{$key}}[0,1,4] (array_func())[0,1,4] # Generate: [arr[_i] for _i in [0,1,4]] return if($ValClass[0] eq 'f' && $ValPerl[0] eq 'delete'); # issue delete - don't do this transformation return if($ValClass[0] eq 'f' && $ValPerl[0] eq 'undef'); # issue s171 - don't do this transformation my $start = 0; # issue s34 $start = 2 if($ValClass[0] =~ /[Cc]/ && 1 <= $#ValClass && $ValClass[1] eq '('); # issue s34 $start = 2 if($ValClass[0] eq 'f' && $#ValClass >= 1 && $ValClass[1] eq '('); # issue s148 for(my $i = $start; $i <= $#ValClass; $i++) { # isue s34 # issue s299 if(index('a@(', $ValClass[$i]) >= 0) { if(index('sa@(', $ValClass[$i]) >= 0) { # issue s299: Handle 's' with $ValType = '@s' my $sub_start = $i+1; if($ValClass[$i] eq '@') { $sub_start = matching_br($i+1) + 1; next if($sub_start == 0); } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '(') { $sub_start = matching_br($i) + 1; next if($sub_start == 0); } elsif($ValClass[$i] eq 's') { next if(!defined $ValType[$i]); next if($ValType[$i] ne '@s'); } elsif($ValClass[$i] ne 'a') { next; # { or [ } last if($sub_start > $#ValClass); next if($ValPerl[$sub_start] ne '[' && $ValPerl[$sub_start] ne '{'); my $sub_end = matching_br($sub_start); return if($sub_end < 0); my $commas = 0; my $range = 0; for(my $j = $sub_start+1; $j < $sub_end; $j++) { $commas++ if($ValClass[$j] eq ','); $range++ if($ValClass[$j] eq 'r'); } if(!$commas && !$range) { # issue bootstrap: if we don't have commas, and this is not a range (handled by slice), # check if the subscript is an array - that's like the same thing if(&Pythonizer::expr_type($sub_start+1, $sub_end-1, $CurSub) =~ /^a/) { $commas = 1; } } my $open = $ValPerl[$sub_start]; $t = 'I'; $t = 'S' if $open eq '{'; $ValPerl[$sub_start] = '['; # So we don't try to generate a '.get()' if it's a hash $ValPerl[$sub_end] = ']'; if($commas >= 1 || ($ValClass[0] eq 'f' && $range)) { # We have a winner! - updated!, issue s148: Handle range too in a chop/chomp insert($sub_end+1,')',']',']'); # Add the ending ']' if($open eq '{') { insert($sub_start, 'y', 'multi', ".get($KEY_TEMP) for $KEY_TEMP in "); # 'y' is a special token type for "extra python code" } else { #insert($sub_start, 'y', 'multi', "[$INDEX_TEMP] for $INDEX_TEMP in "); # 'y' is a special token type for "extra python code" # issue s43: Multi-index of a function that returns an empty array doesn't work insert($sub_start, 'y', 'multi', " for $INDEX_TEMP in "); # 'y' is a special token type for "extra python code" insert($sub_start,')',')',')'); insert($sub_start,'s',$INDEX_TEMP,$INDEX_TEMP); insert($sub_start,',',',',','); insert($i,'(','(','('); $Pyf{_get_element} = 1; insert($i, 'f', '_get_element', '_get_element'); $sub_start += 5; $sub_end += 5; } insert($i, '(', '[', '['); # Add the opening '[' if($debug > 3) { say STDERR "fix_multi_subscripts: found $commas commas, updated code (before fix_type_issues): =|$TokenStr|= ValPy=@ValPy"; } my $adjust = fix_type_issues($sub_start+2,$sub_end+2, "a of $t"); $i = $sub_end+3+$adjust; if($debug > 3) { say STDERR "fix_multi_subscripts: found $commas commas, updated code (after fix_type_issues): =|$TokenStr|= ValPy=@ValPy"; } } } } } sub remove_dereferences # issue 50 { # Run over the statement removing dereferences of the form &{...}, @{...} or %{...} # because python doesn't need them. Also fix up hashref initialization. # issue s3 - fixup references of the form ${expr}[index] -or- ${expr}{key} as we were # generating code to look up expr in the class dictionary, but in actual code it's a function or # method call that returns an array or a hash. e.g. from Complex.pm: ${$z->_polar}[0] # issue s169 - spit out reference removal warnings here where we can still tell if it's a scalar # reference or not! # issue s210 - handle complex references such as &{$self->{key}} by pre-generating the code and grabbing it my %class_map = ('&'=>'i', '@'=>'a', '%'=>'h'); my $change = 0; my $to; # issue s176 for(my $i = 0; $i <= $#ValClass; $i++) { if($ValClass[$i] eq '&' || $ValClass[$i] eq '@' || $ValClass[$i] eq '%') { if($i < $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '{') { $to=matching_br($i+1); next if($to < 0); # issue s143 $ValClass[$i+2] = $class_map{$ValClass[$i]} if($ValClass[$i+2] eq 's'); my $use_helper = 0; # issue s176 if($ValPy[$i] =~ /^len\(/) { # issue s341: This '@' is in scalar context (via fix_scalar_context()) insert($to+1, ')', ')', ')'); # issue s341 insert($i, '(', '(', '('); # issue s341 insert($i, 'f', 'scalar', 'len'); # issue s341 $i += 2; # issue s341 $to += 2; # issue s341 } # issue s341 if($ValClass[$i] ne '&' && &Pythonizer::expr_type($i+2, $to-1, $CurSub) eq 'S') { # issue s361: Symbolic reference, not a subref $use_helper = 1; # issue s361 logme('S', "$ValClass[$i]\{Symbolic reference} requires the use of the -M option for proper code generation") if $implicit_global_my; } elsif($ValClass[$i+2] eq 's') { # issue s143 if($ValClass[$i] eq '&' && $i+2 < $to-1) { # issue s210: Complex case of subref in a hash or array element say STDERR "remove_deferences: evaluating expression" if $debug; expression($i+2, $to-1, 0); # issue s210: Generate the code for this my $code = &Perlscan::format_chunks(); # issue s210: Grab the code as a string @Perlscan::PythonCode = (); # issue s210: clear out the generated code replace($i+2, 'i', join('', $ValPerl[$i+2..$to-1]), $code); # issue s210 destroy($i+3, ($to - ($i+3))); # issue s210 $to -= $to - ($i+3); # issue s210: we destroy $to below } elsif($ValClass[$i] eq '&' || $to+1 > $#ValClass || $ValClass[$to+1] ne '(') { # issue s143: Don't change it to 'a' if it's subscripted replace($i+2, $class_map{$ValClass[$i]}, $ValPerl[$i+2], $ValPy[$i+2]); # issue s143: Replace also fixes $TokenStr } if($autovivification && $ValClass[$i] eq '%' && $to == $i+3 && $Pythonizer::VarType{$ValPy[$i+2]}{$CurSub} !~ /^h/ && (($i-1 >= 0 && $ValClass[$i-1] eq 'f') || ($i-2 >= 0 && $ValClass[$i-1] eq '(' && $ValClass[$i-2] eq 'f'))) { # issue s215 # Passing a %{$var} to a function like keys with autovivification makes it spring to life as a Hash $Pyf{Hash} = 1; # issue s215 my $perllib = $import_perllib ? "$PERLLIB." : ''; # issue s215 $ValPy[$i+2] = "($ValPy[$i+2] if $ValPy[$i+2] is not None else ${perllib}Hash())"; # issue s215 } # issue s143 $change = 1; } if(!$implicit_global_my) { # issue s176 for(my $j = $i+2; $j < $to; $j++) { if($ValClass[$j] eq '"' && index($ValPy[$j], '::') != -1) { $use_helper = 1; last; } } my $infer_suffix = 0; if($use_helper || $ValClass[$i+2] eq '"') { # We only add the suffix here if this is a package variable name or if # the name of the variable is specified by a string, as we can't add the suffix for # cases like @{$h{a}}, as this is most likely an arrayref stored in a hash, not the name # of the array. my $suffix = generic_var_name($ValPerl[$i], $to+1); # issue s244 $infer_suffix = 1 if($ValPerl[$i] eq '*'); if($suffix) { $change = 1; insert($to, '"', $suffix, "'" . $suffix . "'"); insert($to, '.', '.', '+'); $to += 2; } } if($use_helper) { if($to+1 <= $#ValClass && $ValClass[$to+1] eq '=') { # On LHS of an assignment logme('S', 'Complex assignment to dynamic package variable not supported') if($ValPerl[$to+1] ne '='); my $end_pos = $#ValClass; if($i != 0 && $ValClass[$i-1] eq '(') { $j = matching_br($i-1); $end_pos = $j if $j > 0; } my $method_type = 0; if($to+2 <= $#ValClass && $ValClass[$to+1] eq '=' && $ValClass[$to+2] eq '"' && $ValPy[$to+2] =~ /^$ANONYMOUS_SUB\d+[a-z]?$/ && ($to+2 == $#ValClass || $ValClass[$to+3] ne '(')) { if(defined get_sub_attribute($ValPy[$to+2], 'blesses')) { $method_type = 'True'; } else { $method_type = 'None'; } } insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', 'method', ", method_type=$method_type") if($method_type); insert($end_pos+1, 'y', 'infer', ', infer_suffix=True') if($infer_suffix); replace($to+1, ',', ',', ','); $Pyf{_store_perl_global} = 1; destroy($to, 1); replace($i+1, '(', '(', '('); replace($i, 'f', '_store_perl_global', '_store_perl_global'); } else { $Pyf{_fetch_perl_global} = 1; replace($to, ')', ')', ')'); replace($i+1, '(', '(', '('); replace($i, 'f', '_fetch_perl_global', '_fetch_perl_global'); } $change = 1; } } # issue s143 # issue s280 if($ValClass[$i+2] eq 'i') { # subref if($ValClass[$i+2] eq 'i' && $ValPerl[$i+3] ne '(') { # subref, issue s280: not a sub call if(!$use_helper) { # issue s229 if(exists $Pythonizer::VarType{$ValPy[$i+2]} && ((exists $Pythonizer::VarType{$ValPy[$i+2]}{$CurSub} && $Pythonizer::VarType{$ValPy[$i+2]}{$CurSub} eq 'C') || (exists $Pythonizer::VarType{$ValPy[$i+2]}{__main__} && $Pythonizer::VarType{$ValPy[$i+2]}{__main__} eq 'C'))) { ; # If it's a coderef, do nothing } else { my $getter = '_get_subref'; # issue s229 $Pyf{$getter} = 1; # issue s229 $getter = "$PERLLIB.get_subref" if($import_perllib); # issue s229 $ValPy[$i+2] = "$getter($ValPy[$i+2])"; # issue s229 } } # issue s229 $LocalSub{$ValPy[$i+2]} = 4; } if(!$use_helper) { # issue s176 $ValType[$i+2] = $ValClass[$i] if(!defined $ValType[$i+2] || $ValType[$i+2] eq ''); # issue s351 destroy($to,1); # Delete the '}' destroy($i,2); # Delete the '@{' $change = 1; $i--; } } elsif($i < $#ValClass && $ValClass[$i+1] eq 's' && ($i-1 < 0 || ($ValClass[$i-1] eq 'f' && $ValPerl[$i-1] eq 'defined') || # issue s229 (defined $ValType[$i] && $ValType[$i] eq ($ValClass[$i] . '{')) || # issue s250 index(')sdah"iifx', $ValClass[$i-1]) == -1 )) { # Like &$subref @$arrref %$hashref, but not 'and' or 'mod' # issue s143 $ValClass[$i+1] = $class_map{$ValClass[$i]}; my $new_class = $class_map{$ValClass[$i]}; # issue s229 my $to = end_of_variable($i+1); # issue s210 if($to != $i+1) { # issue s210 say STDERR "remove_deferences: evaluating expression" if $debug; expression($i+1, $to, 0); # issue s210: Generate the code for this my $code = &Perlscan::format_chunks(); # issue s210: Grab the code as a string @Perlscan::PythonCode = (); # issue s210: clear out the generated code replace($i+1, ($new_class eq 'i' ? 'i' : 'y'), join('', @ValPerl[$i+1..$to]), $code); # issue s210 destroy($i+2, ($to+1 - ($i+2))); # issue s210 } elsif($ValClass[$i] eq '&' || $i+2 > $#ValClass || $ValClass[$i+2] ne '(') { # issue s143: Don't change it to 'a' if it's subscripted replace($i+1, $class_map{$ValClass[$i]}, $ValPerl[$i+1], $ValPy[$i+1]); # issue s143 } # issue s143 if($new_class eq 'i') { # issue s229: subref if(exists $Pythonizer::VarType{$ValPy[$i+1]} && ((exists $Pythonizer::VarType{$ValPy[$i+1]}{$CurSub} && $Pythonizer::VarType{$ValPy[$i+1]}{$CurSub} eq 'C') || (exists $Pythonizer::VarType{$ValPy[$i+1]}{__main__} && $Pythonizer::VarType{$ValPy[$i+1]}{__main__} eq 'C'))) { ; # If it's a coderef, do nothing } else { my $getter = '_get_subref'; # issue s229 $Pyf{$getter} = 1; # issue s229 $getter = "$PERLLIB.get_subref" if($import_perllib); # issue s229 $ValPy[$i+1] = "$getter($ValPy[$i+1])"; # issue s229 } $LocalSub{$ValPy[$i+1]} = 4; } destroy($i,1); # delete the '@' etc $change = 1; $i--; } elsif($ValClass[$i] eq '@') { # issue s308: '@' is never an operator - just eat it $ValType[$i+1] = '@'; # issue s308: So we know it was a '@' destroy($i,1); # issue s308: delete the '@' $change = 1; # issue s308 $i--; # issue s308 } } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '{') { # This case happens in like $hash_ref = {this=>'that', these=>'those'} # as by default all '{' are changed to '[', but in this case # they need to be restored to '{' and '}'. $to = matching_br($i); next if($to < 0); my $j; if(($j = index($TokenStr,'A',$i+1)) > 0 && $j < $to) { # $TokenStr is a string representation of @ValClass $ValPy[$i] = '{'; $ValPy[$to] = '}'; $change = 1; } } elsif($ValClass[$i] eq 's' && $ValPerl[$i] eq '$' && $i+3 <= $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '{' && $ValClass[$i+2] ne '"' && ($to = matching_br($i+1)) >= 0 && $to+3 <= $#ValClass && $ValClass[$to+1] eq '(' && $ValPy[$to+1] eq '[') { # issue s3, issue s176 #my $to = matching_br($i+1); #next if($to < 0); #next if($to+3 > $#ValClass); #next if($ValClass[$to+1] ne '('); #next if($ValPy[$to+1] ne '['); # Must be hash key or array index $ValPy[$i+1] = '('; # Change to regular parens $ValPy[$to] = ')'; destroy($i,1); # Remove the '$' $i--; $change = 1; } elsif($ValClass[$i] eq 's' && $ValPerl[$i] =~ m'^[*@%&$]$' && $i+3 <= $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '{') { # issue s176 $to = matching_br($i+1); next if($to < 0); if(!$implicit_global_my) { my $suffix = generic_var_name($ValPerl[$i], $to+1); # issue s244 my $infer_suffix = 0; $infer_suffix = 1 if($ValPerl[$i] eq '*'); if($suffix) { $change = 1; insert($to, '"', $suffix, "'" . $suffix . "'"); insert($to, '.', '.', '+'); $to += 2; } my $use_helper = 0; for(my $j = $i+2; $j < $to; $j++) { if($ValClass[$j] eq '"' && index($ValPy[$j], '::') != -1) { $use_helper = 1; last; } } if($use_helper) { if($to+1 <= $#ValClass && $ValClass[$to+1] eq '=') { # On LHS of an assignment logme('S', 'Complex assignment to dynamic package variable not supported') if($ValPerl[$to+1] ne '='); my $end_pos = $#ValClass; if($i != 0 && $ValClass[$i-1] eq '(') { $j = matching_br($i-1); $end_pos = $j if $j > 0; } my $method_type = 0; if($to+2 <= $#ValClass && $ValClass[$to+1] eq '=' && $ValClass[$to+2] eq '"' && $ValPy[$to+2] =~ /^$ANONYMOUS_SUB\d+[a-z]?$/ && ($to+2 == $#ValClass || $ValClass[$to+3] ne '(')) { if(defined get_sub_attribute($ValPy[$to+2], 'blesses')) { $method_type = 'True'; } else { $method_type = 'None'; } } insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', 'method', ", method_type=$method_type") if($method_type); insert($end_pos+1, 'y', 'infer', ', infer_suffix=True') if($infer_suffix); replace($to+1, ',', ',', ','); $Pyf{_store_perl_global} = 1; destroy($to, 1); replace($i+1, '(', '(', '('); replace($i, 'f', '_store_perl_global', '_store_perl_global'); } else { $Pyf{_fetch_perl_global} = 1; replace($to, ')', ')', ')'); replace($i+1, '(', '(', '('); replace($i, 'f', '_fetch_perl_global', '_fetch_perl_global'); } $change = 1; } } } } say STDERR "After remove_dereferences =|$TokenStr|=, ValPy = @ValPy" if $change && $debug; } sub remove_scalar_dereferences # issue s185 { # Run over the statement removing scalar dereferences of the form ${$i} or ${$_[N]}, replacing them with $$i or $$_[N] (effectively) # so our code later on can be simpler in checking these things. Set $ValType[$pos] to 'ss' which represents '$$'. my $change = 0; for(my $i = 0; $i <= $#ValClass; $i++) { if($ValClass[$i] eq 's' && $ValPerl[$i] eq '$' && $i+3 <= $#ValClass && $ValClass[$i+1] eq '(' && $ValPerl[$i+1] eq '{' && $ValClass[$i+2] eq 's' && $ValClass[$i+3] eq ')') { # issue s185: Change ${$i} to $$i and ${$_[N]} similarly $ValType[$i+2] = 'ss' unless defined $ValType[$i+2] && $ValType[$i+2] ne ''; # This was a $$ destroy($i+3, 1); # remove the '}' destroy($i, 2); # remove the '${' $i -= 2; $change = 1; } } say STDERR "After remove_scalar_dereferences =|$TokenStr|=, ValPy = @ValPy" if $change && $debug; } #sub fix_multistmt_bracket_functions # issue s39: handle multi statement bracket functions like @files = map { /\A(.*)\z/s; $1 } readdir $d; # ^ #{ # return if($TokenStr !~ /f\(.*;.*\)/); # return if(defined $split_multiple_assignment); # Already in use # $split_multiple_assignment = package_tokens(); # Borrow the global from "split multiple assignment" # my $did_one = 0; # while ($TokenStr =~ /f\(.*;.*\)/g) { # my $k = $-[0]; # match pos # $k++; # point to the '{' # next if($ValPerl[$k] != '{'); # my $m = matching_br($k); # next if($m < 0); # my $subname = new_anonymous_sub(); # $nested_subs{$subname} = "$DEFAULT_VAR"; # Define the argument # p_replace($split_multiple_assignment, $k+1, 'i', $subname, $subname); # p_destroy($split_multiple_assignment, $k+2, $m-($k+2)); # destroy( # $did_one = 1; # } # $split_multiple_assignment = undef if(!$did_one); # Didn't find any real ones #} sub fix_global_and_eval_regex # SNOOPYJC # Fixup regex with non-existant re.G or re.E flags { my $q = index($TokenStr, 'q'); if($q < 0) { # Look for f/re for(my $i = 0; $i <= $#ValClass; $i++) { if($ValClass[$i] eq 'f') { if($ValPerl[$i] eq 're') { $q = $i; last; } elsif($ValPerl[$i] eq $ARRAY_INDEX_FUNCS{'~re'} || $ValPerl[$i] eq '_substitute_global') { # issue s328 # test GPT regex: The regex is not always at $i+6 as the index can be an arbitrary expression! # test GPT regex: $q = $i + 6; my $comma = next_same_level_token(',', $i+2, $#ValClass); # test GPT regex $comma = next_same_level_token(',', $comma+1, $#ValClass); # test GPT regex $q = $comma + 1 unless $comma < 0; # test GPT regex last; } } } } return if($q < 0); return if($ValPy[$q] !~ /re\.[GE]/); if($ValPy[$q] =~ /re\.E/) { # issue 78 # re.sub(re.compile(rf"\$(\w+)",re.G|re.E),'expr' $ValPy[$q] =~ s/,re\.E\|/,/; $ValPy[$q] =~ s/.re\.E//; $ValPy[$q] =~ /,e'''(.*)'''/s; my $expr = $1; # issue s26my $subname = "$ANONYMOUS_SUB$."; my $subname = new_anonymous_sub(); # issue s26 $nested_subs{$subname} = "$DEFAULT_MATCH"; #say STDERR "expr=$expr, subname=$subname"; $ValPy[$q] =~ s/,e'''.*'''/,$subname/s; $saved_eval_tokens = package_tokens(); $saved_eval_lno = $.; my $t; # issue s179 my @tmpBuffer = @Perlscan::BufferValClass; # SNOOPYJC: Skip the block on getting the next line @saved_eval_BufferValClass = @Perlscan::BufferValClass; # issue s179 @Perlscan::BufferValClass = (); while(($t = getline())) { push @saved_eval_buffer, $t; say STDERR "pushed $t onto saved_eval_buffer" if($debug >= 5); } # issue s179 @Perlscan::BufferValClass = @tmpBuffer; $saved_eval_token_buffer_active = $token_buffer_active; # issue s179 $token_buffer_active = 0; # issue s179 my @lines = split(/^/m, $expr); getline("sub $subname {"); for my $ln (@lines) { say STDERR "pushed $ln to special buffer" if($debug >= 5); getline($ln,1); # Push to special buffer } say STDERR "pushed } to special buffer" if($debug >= 5); getline('}',1); # Push to special buffer destroy(1, $#ValClass) if($#ValClass > 0); replace(0, 'C', 'nop', ''); # make it a no-op return; # We handle the 'G' flag when generating the code on this one } return if($ValPy[$q] !~ /re\.G/); # '(_m:=re.search(re.compile(r'G',re.G),' # 2 cases: if($ValClass[0] eq 'c' && $ValPerl[0] eq 'while') { # 1. while($scalar =~ /pat/g) {...} # Generate: for _m in re.finditer(...) $ValPy[$q] =~ s/,re\.G\|/,/; $ValPy[$q] =~ s/.re\.G//; $ValPy[$q] =~ s/\($DEFAULT_MATCH:=re\.search/(re.finditer/; $ValPy[$q] =~ s/^\(re\.search/(re.finditer/; # issue s40 $ValPy[$q] =~ s/^re\.search/re.finditer/; $ValPy[0] = $ValPerl[0] = 'for'; insert($q+1, ')',')', ')'); insert(1,'(','(','('); insert(1,'s',$DEFAULT_MATCH,$DEFAULT_MATCH); say STDERR "fix_global_and_eval_regex($q) produced =|$TokenStr|=, ValPy=@ValPy" if($debug); } else { # 2. anything else: # Generate: [_m[0] for _m in re.finditer(...)] # This is handled in regex_and_translate() ; } } sub fix_undef # SNOOPYJC # Change $a=$b=$c=undef; to undef $a, $c, $d; so we can generate the code that sets the # value to the proper type (if we know it). { return if(scalar(@ValClass) < 3); return if($ValClass[-1] ne 'f'); return if($ValPerl[-1] ne 'undef'); return if($ValClass[-2] ne '='); return if($ValClass[-3] ne 's'); $start = 0; if($ValClass[0] eq 't') { return; # issue undef: we handle this in the 't' handler now #return if($ValPerl[0] ne 'my'); #$start++; } insert($start, 'f', 'undef', $ValPy[-1]); destroy($#ValClass, 1); for(my $i = $start+1; $i<=$#ValClass; $i++) { replace($i, ',', ',', ',') if($ValClass[$i] eq '='); } destroy($#ValClass, 1) if($ValClass[-1] eq ','); } sub fix_expression_issues { my $start = 0; my $limit = $#ValClass; my $end_pos = $limit; my $pos; # issue 74: Handle ++ and -- while(($pos = next_matching_token('^', $start, $limit)) >= 0) { # issue 74 my $adjust = handle_incr_decr($start, $pos, $limit, 0); # issue 74 last if(!$adjust); # issue 74 $end_pos += $adjust; # issue 74 $limit += $adjust; # issue 74 } # issue 74 # issue s3: Handle ||= and &&= my $st = $start; while(($pos = next_matching_token('=', $st, $limit)) >= 0) { if($ValPerl[$pos] eq '||=' || $ValPerl[$pos] eq '&&=') { my $adjust = handle_double_or_and_assignment($st, $pos, $limit); $end_pos += $adjust; $limit += $adjust; } else { $st = $pos+1; } } # SNOOPYJC: Handle cmp and <=> $st = $start; while(($pos = next_matching_token('>', $st, $limit)) >= 0) { if($ValPerl[$pos] eq 'cmp' || $ValPerl[$pos] eq '<=>') { my $adjust = handle_cmp_spaceship($st, $pos, $limit); $end_pos += $adjust; $limit += $adjust; } else { $st = $pos+1; } } # issue s237: Implement xor $st = $start; while(($pos = next_matching_token('o', $st, $limit)) >= 0) { if($ValPerl[$pos] eq 'xor') { my $adjust = handle_xor($start, $pos, $limit); $st = $pos+1+$adjust; $end_pos += $adjust; $limit += $adjust; } else { $st = $pos+1; } } # issue s287: Implement isa operator $st = $start; while(($pos = next_matching_token('S', $st, $limit)) >= 0) { my $adjust = handle_isa($start, $pos, $limit); $st = $pos + $adjust + 1; $end_pos += $adjust; $limit += $adjust; } # issue s307 Implement more range operators $st = $start; while(($pos = next_matching_token('r', $st, $limit)) >= 0) { my $adjust = handle_range($start, $pos, $limit); $st = $pos + $adjust + 1; $end_pos += $adjust; $limit += $adjust; } # issue s305: Handle resetting 'each' on keys/values my $cs = &Perlscan::cur_sub(); if(exists $SpecialVarsUsed{'each'} && exists $SpecialVarsUsed{'each'}{$cs}) { $st = $start; my $perl = $SpecialVarsUsed{'each'}{$cs}; while(($pos = next_matching_token('f', $st, $limit)) >= 0) { next if $ValPerl[$pos] ne 'keys' && $ValPerl[$pos] ne 'values'; my $sta = $pos+1; $sta++ if $ValPerl[$sta] eq '('; next if $ValPerl[$sta] ne $perl; my $adjust = handle_reset_each_on_keys_or_values($start, $pos, $limit); $pos += $adjust; $end_pos += $adjust; $limit += $adjust; } continue { $st = $pos+1; } } # issue 52 # issue 52: handle ? : operator while(($pos = next_matching_token('?', $start, $limit)) >= 0) { # issue 52 my $adjust = handle_question_mark_colon($start, $pos, $limit); # issue 52 last if($adjust < 0); # SNOOPYJC: Error case $end_pos += $adjust; # issue 52 $limit += $adjust; # issue 52 } # issue 52 # issue 88: handle -bareword # We have to do it here and not in the lexer because of things like: t -timelocal(...) # was converting timelocal to "-timelocal"!! $st = $start; while(($pos = next_matching_token('-', $st, $limit)) >= 0) { if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && (($pos+2 <= $#ValClass && $ValClass[$pos+2] eq 'A') || # issue s205: -bareword=> is always a '-bareword', not a sub call (!$LocalSub{$ValPy[$pos+1]} && !$Constants{$ValPy[$pos+1]})) && ($pos == 0 || $ValClass[$pos-1] !~ /[s)]/)) { my $adjust = handle_negative_bareword($pos); $end_pos += $adjust; $limit += $adjust; } else { $st = $pos+1; } } # Check for use of IO::File: $fh->read(scalar my $oorp = index($TokenStr, 'sDi(s'); if($oorp >= 0 && exists $VarType{$ValPy[$oorp]} && exists $VarType{$ValPy[$oorp]}{$CurSub} && $VarType{$ValPy[$oorp]}{$CurSub} eq 'H' && ($ValPerl[$oorp+2] eq 'read' || $ValPerl[$oorp+2] eq 'sysread')) { # Change it from an OO call to a normal function call so we can process it, as we can't change # the scalar in an OO call. # $fh->read(scalar => read($fh, scalar # 0 1 2 3 4 0 1 2 3 4 replace($oorp+3,',',',',','); my $perl = $ValPerl[$oorp+2]; my $py = '.' . $ValPy[$oorp+2]; replace($oorp+2,$ValClass[$oorp],$ValPerl[$oorp],$ValPy[$oorp]); replace($oorp+1,'(','(','('); replace($oorp,'f',$perl,$py); } # Check for use of IO::File: $fh->open(...) or $fh->binmode(...) my $oop = index($TokenStr, 'sDi('); if($oop >= 0 && exists $VarType{$ValPy[$oop]} && exists $VarType{$ValPy[$oop]}{$CurSub} && $VarType{$ValPy[$oop]}{$CurSub} eq 'H' && ($ValPerl[$oop+2] eq 'open' || $ValPerl[$oop+2] eq 'fdopen' || $ValPerl[$oop+2] eq 'binmode' || $ValPerl[$oop+2] eq 'write')) { if($ValPerl[$oop+2] eq 'write') { # This one is easy as we just have to change it to "write_" as there already is # a fh.write() function, in fact we call it from "write_"!! $ValPy[$oop+2] = 'write_'; } else { # Change it from an OO call to a normal function call so we can change the $fh to # the result of the function. # $fh->open(path => open($fh, path # 0 1 2 3 4 0 1 2 3 4 replace($oop+3,',',',',','); my $func = $ValPerl[$oop+2]; my $py = '_' . $func; if($func eq 'open') { $func = 'IOFile_open'; $py = '_IOFile_open'; } elsif($func eq 'fdopen') { $py = '_fdopen'; } replace($oop+2,$ValClass[$oop],$ValPerl[$oop],$ValPy[$oop]); replace($oop+1,'(','(','('); replace($oop,'f',$func,$py); } $oop = -1; # issue s236 } $st = $start; # issue s236 my $did_one = 0; # issue s236 while(1) { # issue s236 $oop = index($TokenStr, 'sDi(', $st); my $var; # issue s236 if($oop < 0) { # issue s236 $oop = index($TokenStr, 'Di(', $st); # issue s236 if($oop > 0) { # issue s236 $var = start_of_var($oop-1); # issue s236 if($ValClass[$var] eq 'i' && $var == $oop-1) { # issue s236: iDi( is handled separately below $oop = -1; # issue s236 } else { # issue s236 $oop--; # issue s236 } # issue s236 } # issue s236 } else { # issue s236 $var = $oop; # issue s236 } if($oop >= 0 && ($ValPerl[$oop+2] eq 'isa' || $ValPerl[$oop+2] eq 'can')) { # issue s180: add 'can' # issue s54: Check for use of $obj->isa('ClassName'), and change it to a normal function call replace($oop+3,',',',',','); my $func = $ValPerl[$oop+2]; my $py = '_' . $func; # issue s236 replace($oop+2,$ValClass[$oop],$ValPerl[$oop],$ValPy[$oop]); # issue s236 replace($oop+1,'(','(','('); # issue s236 replace($oop,'f',$func,$py); destroy($oop+1, 2); # issue s236: remove the 'Di' insert($var, '(', '(', '('); # issue s236 insert($var, 'f', $func, $py); # issue s236 $did_one = 1; # issue s236 } $oop = index($TokenStr, 'iDi(', $st); # issue s180 if($oop >= 0 && ($ValPerl[$oop+2] eq 'isa' || $ValPerl[$oop+2] eq 'can')) { # issue s180 replace($oop+3,',',',',','); my $func = $ValPerl[$oop+2]; my $py = '_' . $func; # issue s18 replace($oop+2,$ValClass[$oop],$ValPerl[$oop],$ValPy[$oop]); replace($oop+2,'"',$ValPerl[$oop],$ValPy[$oop]); # issue s18: replace the class with a pseudo-string replace($oop+1,'(','(','('); replace($oop,'f',$func,$py); $did_one = 1; # issue s236 } last unless $did_one; # issue s236 $did_one = 0; # issue s236 $st = $oop+1; # issue s236 } # issue s236 # SNOOPYJC: Handle read in expressions $st = $start; while(($pos = next_matching_tokens('f', $st, $limit)) >= 0) { if($ValPy[$pos] eq '.read' || $ValPy[$pos] eq '.sysread') { my $adjust = fixup_read_in_expression($pos); $end_pos += $adjust; $limit += $adjust; } $st = $pos+1; } # SNOOPYJC: Handle assignment in expressions $st = $start; # issue s151 while(($pos = next_matching_tokens('=~', $st, $limit)) >= 0) { while(($pos = next_matching_tokens('=p', $st, $limit)) >= 0) { # issue s151 my $adjust = handle_assignment_in_expression($pos); $end_pos += $adjust; $limit += $adjust; $st = $pos+1; } # SNOOPYJC: Handle eval in expressions $st = $start; while(($pos = next_matching_tokens('C', $st, $limit)) >= 0) { if($ValPerl[$pos] eq 'eval') { my $adjust = handle_eval_in_expression($pos); $end_pos += $adjust; $limit += $adjust; } $st = $pos+1; last if($st > $limit); } # issue s150: Handle statement generating functions like getopt/getopts/GetOptions in expressions or control statements $st = $start+1; while(($pos = next_matching_tokens('f', $st, $limit)) >= 0) { if(exists $STATEMENT_FUNCTIONS{$ValPerl[$pos]}) { my $adjust = handle_statement_function_in_expression($pos); $end_pos += $adjust; $limit += $adjust; } $st = $pos+1; last if($st > $limit); } # SNOOPYJC: Handle i=>x in sub/function calls and also fixup "new" method calls that are built-in functions $st = $start; while(($pos = next_matching_tokens('if', $st, $limit)) >= 0) { last if $pos == 1 && $ValPerl[0] =~ /^(?:use|require|sub|package)$/; # issue s244 if($ValClass[$pos] eq 'i') { # issue s244 if($pos+2 <= $#ValClass && $ValClass[$pos+1] eq 'D' && $ValClass[$pos+2] eq 'i') { # issue s244: Class->method $pos += 2; } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'A') { # issue s244: key=>'value' next; } next if exists $Constants{$ValPy[$pos]}; # issue s244 } my $end_pos; #say STDERR "=|$TokenStr|= pos=$pos on line $."; if($pos+1 <= $limit && $ValClass[$pos+1] eq '(' && $ValPerl[$pos+1] eq '(') { # Only handle parenthesized arglists for now $end_pos = matching_br($pos+1); $pos++; # issue s201 } elsif($ValClass[$pos] eq 'f') { # issue s244 $end_pos = end_of_function($pos); if($pos+1 <= $#ValClass && $ValPerl[$pos+1] eq '(') { $pos++; } else { $end_pos++; } } elsif($ValClass[$pos] eq 'i') { $end_pos = end_of_call($pos); } next unless defined $end_pos; while(1) { my $arrow = next_same_level_token('A', $pos+1, $end_pos-1); # '=>' operator, issue s201 #say STDERR "arrow=$arrow"; last if($arrow == -1); $ValPy[$arrow] = ','; $pos = $arrow; } } continue { # issue s244 $st = $pos+1; last if($st > $limit); } # issue 127: Need to flatten qw inside anonymous arrays $st = $start; while(($pos = next_matching_token('q', $st, $limit)) >= 0) { if($pos-1 >= 0 && $pos+1 <= $limit && $ValPy[$pos] =~ /\.split\(\)$/ && $ValClass[$pos-1] eq '(' && $ValPerl[$pos-1] eq '[' && $ValClass[$pos+1] eq ')' && $ValPerl[$pos+1] eq ']') { $ValType[$pos] = 's'; # Flag it as a scalar so we don't splat it destroy($pos+1,1); destroy($pos-1,1); $limit -= 2; } $st = $pos+1; last if($st > $limit); } # issue s55 - change [@arr] to \@arr and {%hash} to \%hash # issue s202 - also change [f(...)] to \f(...), where f is a function returning an array or hash $st = $start; while(($pos = next_matching_tokens('fahs@%', $st, $limit)) >= 0) { # issue s202: also handle a function that returns an array like sort, issue s243: also handle 's' that's cast to an array or hash, issue s341: also handle [ @{...} ] and { %{...} } if($pos-1 >= 0 && $pos+1 <= $limit) { my $typ = $ValClass[$pos]; # issue s202 if($typ eq 's') { # issue s243 next if !defined $ValType[$pos]; # issue s243 if($ValType[$pos] eq '%s') { # issue s243 $typ = 'h'; # issue s243 } elsif($ValType[$pos] eq '@s') { # issue s243 $typ = 'a'; # issue s243 } else { # issue s243 next; # issue s243 } # issue s243 } # issue s243 my $end_pos = $pos; # issue s202 if($typ eq 'f') { # issue s202 $typ = &Pythonizer::func_type($ValPerl[$pos], $ValPy[$pos]); # issue s202 next if $typ ne 'a' && $typ ne 'h'; # issue s202 $end_pos = end_of_function($pos); # issue s202 } if($typ eq '@' && $ValClass[$pos+1] eq '(') { # issue s341 $typ = 'a'; # issue s341 $end_pos = matching_br($pos+1); # issue s341 } elsif($typ eq '%' && $ValClass[$pos+1] eq '(') { # issue s341 $typ = 'h'; # issue s341 $end_pos = matching_br($pos+1); # issue s341 } my $open = ($typ eq 'a' ? '[' : '{'); my $close = ($typ eq 'a' ? ']' : '}'); if($ValPerl[$pos-1] eq $open && $end_pos+1 <= $#ValClass && $ValPerl[$end_pos+1] eq $close && ($pos-2 < 0 || $ValClass[$pos-2] !~ /[sahG\)]/) # issue bootstrap ) { $ValPy[$pos] .= '.copy()' if $ValClass[$pos] ne 'f'; # issue s252: We must make a copy, e.g. $array_copy = [@array]; if($ValClass[$pos] eq 'f' && $end_pos+2 <= $#ValClass && $ValClass[$end_pos+2] eq ',') { # issue s252: Could be confusing # Fix error in test_operator_precedence replace($pos-1, '(', '(', '('); replace($end_pos+1, ')', ')', ')'); insert($pos-1, '\\', '\\', ''); $limit++; $pos++; } else { replace($pos-1, '\\', '\\', ''); destroy($end_pos+1,1); # issue s202 $limit--; } } } } continue { $st = $pos+1; last if($st > $limit); } # issue s65 - x operator with a (number) doesn't generate proper code $st = $start; while(($pos = next_matching_token('*', $st, $limit)) >= 0) { if($ValPerl[$pos] eq 'x' && $pos != 0 && $ValClass[$pos-1] eq ')' && $ValPerl[$pos-1] eq ')') { my $open = reverse_matching_br($pos-1); if($open >= 0) { if(&Pythonizer::expr_type($open, $pos-1, $CurSub) !~ /^a/) { replace($pos, 'y', 'x', ' for _ in range '); $end_pos = $limit; my $add_closing_bracket = 0; if($open != 0 && $ValClass[$open-1] eq '(') { $end_pos = matching_br($open-1)-1; } elsif(!$autovivification) { insert($open, '(', '(', '['); $add_closing_bracket = 1; $pos++; $end_pos++; $limit++; } $nlet = next_lower_or_equal_precedent_token('*', $pos+1, $end_pos); $end_pos = $nlet-1 if($nlet >= 0); if($add_closing_bracket) { insert($end_pos+1, ')', ')', ']'); $limit++; } insert($end_pos+1, ')', ')', ')'); insert($pos+1, '(', '(', '('); $limit += 2; } } } $st = $pos+1; last if($st > $limit) } # issue s154: replace OO method calls to local functions with normal calls # in tied package definitions because we pass object.__dict__ instead of object # when we call it externally. # issue s203: Revamp this code to also transform $self->PACKAGE::method(...) to PACKAGE::method($self, ...) my $tied_package = 0; # if((exists $LocalSub{TIEHASH} && $LocalSub{TIEHASH} == 1) || # (exists $LocalSub{TIEARRAY} && $LocalSub{TIEARRAY} == 1)) { # issue s154 # We don't have to do this anymore now that we don't pass object.__dict__: $tied_package = 1; # Plus it causes problems for $obj->method, where $obj was an object of a DIFFERENT class, not this class, # but both classes have a method with the same name - it was calling the wrong one (in CGI). # } $st = $start; while(($pos = next_matching_token('D', $st, $limit)) >= 0) { next if($pos+1 > $limit); next if($ValClass[$pos+1] ne 'i'); if(index($ValPy[$pos+1], '.') == -1) { # issue s203 next if(!$tied_package || !exists $LocalSub{$ValPy[$pos+1]} || $LocalSub{$ValPy[$pos+1]} != 1); } next if($pos-1 < 0 || $ValClass[$pos-1] ne 's'); if($pos+3 > $limit || $ValPerl[$pos+2] ne '(') { insert($pos+2,')',')',')'); insert($pos+2,'(','(','('); $limit++; } if($ValClass[$pos+3] ne ')') { insert($pos+3, ',', ',', ','); $limit++; } insert($pos+3, $ValClass[$pos-1], $ValPerl[$pos-1], $ValPy[$pos-1]); destroy($pos-1, 2); $limit--; } continue { $st = $pos+1; last if($st > $limit); } # issue s166: Handle open with 2 args and the file handle in a string $st = $start; while(($pos = next_matching_tokens('f', $st, $limit)) >= 0) { if($ValPerl[$pos] eq 'open') { my $adjust = handle_open_dup($pos); $end_pos += $adjust; $limit += $adjust; } $st = $pos+1; last if($st > $limit); } # NOTE: Add new updates here, not at the bottom of this function! # issue 81: Handle anonymous sub in expression # It's always the last thing because we stop lexxing there if($#ValClass != 0 && $ValClass[$#ValClass] eq 'k' && $ValPerl[$#ValClass] eq 'sub') { handle_anonymous_sub_in_expression(); } # issue s251 Implement ~~ (smartmatch) # We do this after handle_anonymous_sub_in_expression because the second arg to ~~ can # be an anonymous sub! $st = $start; while(($pos = next_matching_token('M', $st, $limit)) >= 0) { my $adjust = handle_smartmatch($start, $pos, $limit); $end_pos += $adjust; $limit += $adjust; } # issue s74: Handle do in expression # It's always the last thing because we stop lexxing there if($#ValClass != 0 && $ValClass[$#ValClass] eq 'C' && $ValPerl[$#ValClass] eq 'do') { handle_do_in_expression(); } # issue s219 Handle eval in conditional statement # It's always the last thing because we stop lexxing there # issue s318 if($#ValClass != 0 && $ValClass[$#ValClass] eq 'C' && $ValPerl[$#ValClass] eq 'eval' && if(scalar(@ValClass) != 0 && $ValClass[$#ValClass] eq 'C' && $ValPerl[$#ValClass] eq 'eval' && # issue s318 exists $Perlscan::line_contains_stmt_modifier{$Perlscan::statement_starting_lno}) { handle_conditional_eval(); } # NOTE: Do NOT add new updates here! } sub insert_method_calls # issue s236 # issue s236: Perl supports calling thru the name of a class. We use _method_call to handle that, but we # try not to use it for $self->method(...) or $obj->method(...). This is a bit of a kludge, but we # insert _method_call if the thing before the '->' is anything complex or if we know it's a string. { my $start = 0; my $limit = $#ValClass; $st = $start; while(($pos = next_matching_token('D', $st, $limit)) >= 0) { next if($pos+1 > $limit); next if($ValClass[$pos+1] ne 'i' && $ValClass[$pos+1] ne 's'); # issue s324: allow 's' also next if($pos-1 < 0); my $sov = start_of_var($pos-1); next if($ValClass[$pos+1] eq 'i' && $sov == $pos-1 && $ValPerl[$sov] =~ /^\$[A-Za-z0-9_]+$/ && $CurSub ne 'import' && # issue s324: add check for 'i' &Pythonizer::expr_type($sov, $sov, $CurSub) ne 'S' && &Pythonizer::expr_type($sov, $sov, '__main__') ne 'S'); next if($ValClass[$sov] eq 'f' && $ValPerl[$sov] ne '_method_call'); # see issue s113: stat("$archive_dir/$script_name")->mtime, issue s317: Keep going if this is already a _method_call if($ValClass[$sov] eq 'i' && !exists $Constants{$ValPy[$sov]}) { # In the case of CGI->binmode(...), we need to pass CGI in as the first parameter # unless this is already a MethodType # issue s241 next if(exists $CLASS_METHOD_SET{$ValPy[$pos+1]} || (exists $SubAttributes{'->' . $ValPy[$pos+1]}{blesses} && # issue s241 !exists $SubAttributes{'->' . $ValPy[$pos+1]}{overloads})); # Skip if MethodType like new, make, etc next if($ValClass[$pos+1] eq 'i' && exists $CLASS_METHOD_SET{$ValPy[$pos+1]} || (defined get_sub_attribute($ValPy[$pos+1], 'blesses', 1) && # issue s324: add check for 'i' !defined get_sub_attribute($ValPy[$pos+1], 'overloads', 1))); # Skip if MethodType like new, make, etc, issue s241 if($pos+2 > $limit || $ValClass[$pos+2] ne '(') { insert($pos+2, ')', ')', ')'); insert($pos+2, '(', '(', '('); $limit += 2; } if($ValPerl[$pos+3] ne ')') { insert($pos+3, ',', ',', ','); $limit++; } insert($pos+3, 'y', $ValPerl[$sov], escape_keywords($ValPy[$sov])); next; } $Pyf{_method_call} = 1; if($pos+2 > $limit || $ValClass[$pos+2] ne '(') { insert($pos+2, ')', ')', ')'); insert($pos+2, '(', '(', '('); $limit += 2; } if($ValPerl[$pos+3] ne ')') { insert($pos+3, ',', ',', ','); $limit++; } if($ValClass[$pos+1] eq 'i') { # issue s324 my $escaped = escape_keywords($ValPy[$pos+1]); insert($pos+3, '"', $ValPerl[$pos+1], "'$escaped'"); } else { # issue s324 insert($pos+3, 's', $ValPerl[$pos+1], $ValPy[$pos+1]); # issue s324 } # issue s324 insert($pos+3, ',', ',', ','); destroy($pos, 3); # eat the Di( insert($sov, '(', '(', '('); insert($sov, 'f', '_method_call', '_method_call'); $limit += 1; } continue { $st = $pos+1; last if($st > $limit); } } sub insert_sl # issue s308 # Helper function for insert_splat_lists: Insert the _sl(...) call { my ($pos, $ep) = @_; insert($ep+1, ')', ')', ')'); insert($pos, '(', '(', '('); insert($pos, 'f', '_sl', '_sl'); } sub isHashKey # issue s308 # Is this 'i' token a hash key? { my $pos = $_[0]; return 1 if $pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'A'; return 0; } sub insert_splat_lists # issue s308 # issue s308 - inserts splats with calls to this lambda function, which checks if # the value is an iterator or not. If it's not, it makes a list of one element out of # the value so the splat operation will still work. Issue was found using a sub that # returns an array which is then passed as an argument to another sub. That array needs # to be splatted (*) out into separate elements, and not passed as an entity. # _sl = lambda r: [r] if isinstance(r, str) or not hasattr(r, '__iter__') else r # The _sl lambda is typed as an array function, so need_splat() will return true for it. { my ($start, $end_pos, $in_list) = @_; debug_start_end(">insert_splat_lists($start, $end_pos, $in_list) =|%|= ValPerl=@ValPerl, ValPy=@ValPy", $start, $end_pos); my $pos = $start; my $adjust = 0; my $adj; if($in_list) { if($ValPerl[$pos] eq '(') { $end_pos--; $pos++; } my $ep = $end_pos; while($pos <= $end_pos) { $ep = $end_pos; my $eq = next_same_level_token('=', $pos, $end_pos); if($eq != -1) { $pos = $eq + 1; # Don't adjust anything on the LHS of an '=' } my $comma = next_same_level_token(',', $pos, $end_pos); if($pos == $comma) { $ep = $comma; next; } $ep = $comma-1 if $comma != -1; next if $pos == $ep && $ValClass[$pos] ne 'i'; next if $ValClass[$pos] eq 'i' && (($FileHandles{$ValPerl[$pos]} || substr($ValPy[$pos],0,4) eq 'sys.') || isHashKey($pos) || $Constants{$ValPy[$pos]} || !$LocalSub{$ValPy[$pos]}); if($ValClass[$pos] eq '(' && ($ValPerl[$pos] eq '[' || $ValPerl[$pos] eq '{')) { next if !defined $ValType[$pos]; next if $ValType[$pos] ne '@'; # '@' means it was a @{[list...]} we removed in remove_dereferences } if($ValClass[$pos] ne 'f' && $ValClass[$pos] ne 'i' && !need_splat($pos) && &Pythonizer::expr_type($pos, $ep, $CurSub) =~ /^a/ && next_same_level_token('r', $pos, $ep) == -1) { insert_sl($pos, $ep); $adjust += 3; $ep += 3; next; } if($ValClass[$pos] eq 'i' && !inDotOp($pos)) { my $eoc = end_of_call($pos); $ep = $eoc if $eoc > $ep; if($eoc == $ep && sub_returns_array($pos)) { insert_sl($pos, $ep); $adjust += 3; $ep += 3; next; } } my $colon1 = next_same_level_token(':', $pos, $ep); # This is actually a converted '?' operation if($colon1 >= 0) { # tResult :(if) expr : fResult # ^colon1 ^colon2 my $colon2 = next_same_level_token(':', $colon1+1, $ep); next if $colon2 < 0; my $typ1 = 'a'; if($ValClass[$pos] eq 'i' && !inDotOp($pos)) { my $eoc = end_of_call($pos); if($eoc == $colon1-1 && sub_returns_array($pos)) { $typ1 = 'a'; } elsif($eoc == $colon1-1) { $typ1 = 's'; } } else { $typ1 = &Pythonizer::expr_type($pos, $colon1-1, $CurSub); } my $typ2 = 'a'; if($ValClass[$colon2+1] eq 'i' && !inDotOp($colon2+1)) { my $eoc = end_of_call($colon2+1); if($eoc == $ep && sub_returns_array($colon2+1)) { $typ2 = 'a'; } elsif($eoc == $ep) { $typ2 = 's'; } } else { $typ2 = &Pythonizer::expr_type($colon2+1, $ep, $CurSub); } if($typ1 =~ /^a/ || $typ2 =~ /^a/) { if($typ1 =~ /^h/) { # issue s327 insert($colon1, ')', ']', ']'); insert($pos, '(', '[', '['); $adjust += 2; $ep += 2; } elsif($typ2 =~ /^h/) { # issue s327 insert($ep+1, ')', ']', ']'); insert($colon2+1, '(', '[', '['); $adjust += 2; $ep += 2; } insert_sl($pos, $ep); $adjust += 3; $ep += 3; } } } continue { $pos = $ep + 1; } } else { if($start == 0 && $ValClass[$start] =~ /[cCk]/ && $start+1 <= $#ValClass && $ValPerl[$start+1] eq '(') { $end_pos = matching_br($pos+1)-1; $pos += 2; return 0 if $end_pos < 0; } elsif($start == 0 && $ValClass[$start] =~ /[cCk]/ && $start+2 <= $#ValClass && $ValClass[$start+1] eq '!' && $ValPerl[$start+2] eq '(') { $end_pos = matching_br($pos+2)-1; $pos += 3; return 0 if $end_pos < 0; } while(($pos = next_same_level_tokens('if(', $pos, $end_pos)) != -1) { if($ValClass[$pos] eq 'f') { my $eof = end_of_function($pos); $pos = $eof; # Not a good idea - we don't normally splat function args: #if($pos+1 <= $eof) { #$adj = insert_splat_lists($pos+1, $eof, 1); #$pos = $eof + $adj; #$adjust += $adj; #} } elsif($ValClass[$pos] eq 'i' && ($LocalSub{$ValPy[$pos]} || ($pos-1 >= 0 && $ValClass[$pos-1] eq 'D') || ($pos+1 <= $#ValClass && $ValPerl[$pos+1] eq '('))) { my $eoc = end_of_call($pos); if($pos+1 <= $eoc) { $adj = insert_splat_lists($pos+1, $eoc, 1); $pos = $eoc + $adj; $adjust += $adj; } } else { # (...) my $eb = matching_br($pos); return 0 if $eb < 0; if($eb+1 <= $#ValClass && $ValClass[$eb+1] eq '=') { # skip LHS list, but look for one on the RHS return insert_splat_lists($eb+2, $end_pos, 0); } # issue s316 if(is_list($pos, $eb)) { if(is_list($pos, $eb) && next_same_level_token('A', $pos+1, $eb-1) == -1) { # issue s316: Not a hash!! $adj = insert_splat_lists($pos, $eb, 1); $pos = $eb + $adj; $adjust += $adj; } else { $pos = $eb; } } } continue { $pos++; } } say STDERR "{eval_nest}); # issue 42, issue s13 my $cs = &Perlscan::cur_sub(); # issue s252 if(($CurSub ne '__main__' || scalar(@eval_stack) != 0 || $nested_sub_at_level > 0) && # issue 42, issue 41, issue 78 defined $line && # issue 42 !exists $aliased_foreach_subs{$cs} && # issue s252 (!special_code_block_name($cs) || scalar(@eval_stack) != 0) && # issue s155: No need to return a value from BEGIN/END etc blocks (except from an eval inside) ($got_new_line && # issue s322 ($line eq '}' || $line =~ m'^}\s*#' || $line eq '};' || exists $line_needs_added_return{$Perlscan::statement_starting_lno} || # issue implicit conditional return # issue s262 (substr($line,0,1) eq '}' && &Perlscan::could_be_anonymous_sub_close()) || # issue s26 ($line =~ /^\s*}/ && &Perlscan::could_be_anonymous_sub_close()) || # issue s26, issue s262 $line =~ m'^\s*}\s*$' || $line =~ m'^\s*};\s*$' || # SNOOPYJC $line =~ m'^\s*};\s*#')) && # issue 42 #$ValPerl[0] ne 'return' && $Pythonizer::CurNest==1) { # issue 45 $ValPerl[0] ne 'return' && ($Perlscan::nesting_level==1 || # issue 45, SNOOPYJC: Handle sub with try block (scalar(@Perlscan::nesting_stack) && $Perlscan::nesting_level==($top = $Perlscan::nesting_stack[-1])->{level}+1 && $top->{type} eq 'def') || # issue s155 exists $line_needs_added_return{$Perlscan::statement_starting_lno} || # issue implicit conditional return $Pythonizer::CurNest == $eval_nest+1 || # issue s13 $Perlscan::nesting_level == $nested_sub_at_level)) { # issue 78 if($debug >= 5) { # issue 45 say STDERR "finish: prev_line=$prev_lno: $prev_line, line=$.: $line, PythonCode=@Perlscan::PythonCode"; # issue 45 } # issue 45 my $comment=''; # SNOOPYJC $comment = $1 if($line =~ m'^\s*}(;)$'); # SNOOPYJC: Don't lose a trailing semicolon $comment = $1 if($line =~ m'^\s*}(;?\s*#.*)$'); # SNOOPYJC if(!$comment && (($got_new_line && &Perlscan::could_be_anonymous_sub_close()) || exists $line_needs_added_return{$Perlscan::statement_starting_lno}) && # issue s79 $line ne '}' && $line ne '};') { # issue s26, issue s322 # issue s26: if we have like $prev_line = "2}));" and $line = "}));", remove from $prev_line what # we have in $line, but save it (sans the '}') in $comment for the next round. if(substr($line,0,1) eq '}' && # issue s79 rindex($prev_line, $line) != -1) { # issue s26 $prev_line = substr($prev_line, 0, length($prev_line)-length($line)); # issue s26 $comment = substr($line,1); # issue s26 if($debug >= 5) { say STDERR "finish: updated prev_line=$prev_line, comment=$comment"; } } elsif(substr($line,0,2) eq '},' && rindex($prev_line, '}'.substr($line,2)) != -1) { # issue s39 - we snuck in a ',' $prev_line = substr($prev_line, 0, length($prev_line)-(length($line)-1)); # issue s26/issue s39 $comment = substr($line,1); # issue s26/issue s39 if($debug >= 5) { say STDERR "finish: updated prev_line=$prev_line, comment=$comment"; } } else { # issue s311 $comment = $1 if($line =~ m'^\s*}(.+;(?:\s*#.*)?)$'); # issue s311: handle '} @$tables;' from map {...} } } if($ValClass[0] eq 'f' && $ValPerl[0] =~ /^(?:close)$/) { # issue s89 ; # issue s89 } elsif($generated_code == 0 && $ValClass[0] eq 'f' && exists $PYF_OUT_PARAMETERS{$ValPy[0]}) { # issue s183 # In this case, we already generated full statements to handle the function e.g. chop(@arr), so # we can't sneak in a return - we handle only a few specific cases here if($ValPerl[0] eq 'open') { # attempt to extract the filehandle from the source code $prev_line =~ s/open\(?//; $prev_line =~ s/\s+#.*$//; # remove comments $prev_line =~ s/\s+$//; # remove trailing spaces $prev_line =~ s/,.*$//; # everything after the first comma goes away - should only have the file handle left $line = "return defined openhandle($prev_line);"; $reparse_with_return = 1; getline('}'.$comment); } } elsif($generated_code == 0 && index('fds"(-aj', $ValClass[0]) >= 0) { # issue 45, issue s97 - handle $prev_line =~ s/\s+(#.*)$//; # issue 45: remove comments, issue test_comments: Grab that comment my $prev_comment = $1 if defined $1; # issue test_comments undef $prev_comment if defined $prev_comment && index($line, $prev_comment) != -1; # issue test_comments: see issue_comments.pl # LINE 3 (was being duplicated) $prev_line =~ s/\s+$//; # SNOOPYJC: remove trailing spaces $last_c = substr($prev_line,-1,1); # issue 45 # issue s129 if($last_c eq '}' && ($ValClass[-1] ne ')' || $prev_lno == $.)) { # issue 45, issue bootstrap if($last_c eq '}' && $ValClass[-1] ne ')') { # issue 45, issue bootstrap, issue s129: FIXME! chop $prev_line; # issue 45 $prev_line =~ s/\s+$//; # issue 45 $last_c = substr($prev_line,-1,1); # issue 45 } # issue 45 if(substr($prev_line,-2,2) eq '};' && $prev_lno == $. && $line =~ m'};') { # issue bootstrap chop $prev_line; chop $prev_line; $last_c = substr($prev_line,-1,1); } if($comment eq '' && ($line ne $orig_prev_line || $prev_lno != $.) && exists $line_needs_added_return{$Perlscan::statement_starting_lno}) { # issue implicit conditional return say STDERR "finish: calling getline($line) due to line_needs_added_return on line $Perlscan::statement_starting_lno" if($::debug >= 5); getline($line); # issue implicit conditional return } else { # issue implicit conditional return say STDERR "finish: calling getline(}".$comment.")" if($::debug >= 5); getline('}'.$comment); # issue 45, SNOOPYJC, issue implicit conditional return } if($last_c eq ';') { # issue 45 $line = "return ".$prev_line; # issue 45 } else { # issue 45 $line = "return ".$prev_line.';'; # issue 45 } # issue 45 if(defined $prev_comment) { # issue test_comments $line .= ' ' . $prev_comment; # issue test_comments } # issue test_comments $reparse_with_return = 1; # issue implicit conditional return getline('}'.$comment); # issue 45, SNOOPYJC } elsif($ValClass[0] eq 'f' || ($ValClass[0] eq 'i' && $LocalSub{$ValPy[0]}) || # issue 45 ok_to_insert_return()) { # issue s3 # In this case, we generated the code for a function or local sub call - sneak the 'return' in just before it my $return = 'return'; # issue 45 if(scalar(@eval_stack) != 0 && !in_sub_in_eval_at($#eval_stack)) { # issue 45, issue s243 $return = undef; # issue 45 if(exists $eval_stack[-1]->{assignment}) { # issue 45 my $lno = $eval_stack[-1]->{lno}; # issue 45 my $suffix = $eval_stack[-1]->{suffix}; # issue s13 $return = "$EVAL_RESULT$lno$suffix = "; # issue 45: for an a = eval {...};, we set the EVAL_RESULT instead of returning } # issue 45 } # issue s89 # issue s89 } elsif($ValPerl[0] eq 'undef' && $#ValClass >= 1) { # issue 45: "undef $var;" generates an assignment statement, so handle like that my $rp; # issue s79 if($ValPerl[0] eq 'undef' && $#ValClass >= 1) { # issue 45: "undef $var;" generates an assignment statement, so handle like that, issue s89 # issue anon_sub my $p = index($prev_line,'='); # issue 45 # issue anon_sub $line = "return ".substr($prev_line, 0, $p); # issue 45 $line = "return undef"; # issue anon_sub $line .=';'; # issue 45 $reparse_with_return = 1; getline('}'.$comment); # issue 45, SNOOPYJC $return = undef; # issue 45 } elsif($ValPerl[0] eq 'unshift') { # issue bootstrap: unshift also generates an assignment stmt if($prev_line =~ /unshift\s*\(?([^,]+),/) { # pull out the array $line = "return scalar($1);"; # unshift returns the # of element now in the array $reparse_with_return = 1; getline('}'.$comment); } $return = undef; # issue s151 } elsif($ValPerl[0] eq '_str' && $ValClass[1] eq '(' && ($rp = matching_br(1)+1) <= $#ValClass && $ValClass[$rp] eq '~') { # issue s79 } elsif($ValPerl[0] eq '_str' && $ValClass[1] eq '(' && ($rp = matching_br(1)+1) <= $#ValClass && $ValClass[$rp] eq 'p') { # issue s79, issue s151 # # issue s184: This is the WRONG result - it should be either the status of the match or the count of substitutions made, # but it's NOT the value of the string being matched! # # issue s184 my $p = index($prev_line, '='); # issue s184 if($p > 0) { # issue s184 $line = "return ".substr($prev_line, 0, $p); # issue 45 $line = "return $prev_line"; # issue s184: Put the return in front @Perlscan::PythonCode = (); # issue s184: Throw away the prior generated code $reparse_with_return = 1; getline('}'.$comment); # issue s184 } $return = undef; } elsif($ValPerl[0] eq 're') { # issue s79 $line = 'return $_;'; $reparse_with_return = 1; getline('}'.$comment); $return = undef; } elsif($ValPerl[0] eq 'bless' && !ok_to_insert_return()) { # issue s266: bless as a statement may generate an assignment # attempt to extract the blessee from the source code $prev_line =~ s/bless\(?//; $prev_line =~ s/\s+#.*$//; # remove comments $prev_line =~ s/\s+$//; # remove trailing spaces $prev_line =~ s/=>.*$//; # everything after the => goes away $prev_line =~ s/,.*$//; # everything after the comma goes away - should only have the object left $line = "return $prev_line;"; $reparse_with_return = 1; getline('}'.$comment); $return = undef; } elsif($Perlscan::PythonCode[0] =~ /^(?:(?:raise )|(?:return ))/) { # issue 45 $return = undef; # issue 45 } elsif($Perlscan::PythonCode[0] =~ /^[\w.\[\]]+\s*=/ || (scalar(@Perlscan::PythonCode) > 1 && $Perlscan::PythonCode[1] eq '=')) { # SNOOPYJC: as in fh = _open(...), issue s183: handle _args[0] = ..., _args[0] = open(...) # # issue s183: The function result is NOT the same as the out parameter, so reparse it with 'return' in front, # e.g. open(...) returns 1 or 0, not the file handle. # # issue s183 my $perl_name = (($ValClass[1] eq '(') ? $ValPerl[2] : $ValPerl[1]); # issue s183 $line = "return $perl_name;"; $line = "return $prev_line"; # issue s183: Put the return in front @Perlscan::PythonCode = (); # issue s183: Throw away the prior generated code $reparse_with_return = 1; getline('}'.$comment); $return = undef; } # issue 45 #say STDERR "PythonCode[0] = $Perlscan::PythonCode[0]"; # TEMP if($return) { if($CurSub eq 'TIEHASH' || $CurSub eq 'TIEARRAY' || $CurSub eq 'TIESCALAR') { # issue s216, issue s301 $Pyf{_add_tie_methods} = 1; # issue s216 my $atm = $import_perllib ? "$PERLLIB.add_tie_methods" : '_add_tie_methods'; # issue s216 unshift @Perlscan::PythonCode, '('; # issue s216 unshift @Perlscan::PythonCode, $atm; # issue s216 push @Perlscan::PythonCode, ')'; # issue s216 } # issue s216 for(my $i = 0; $i < @Perlscan::PythonCode; $i++) { # issue s241 $Perlscan::PythonCode[$i] =~ s/wantarray=None/wantarray=False/; # issue s241: we thought this was void context, but now it's not } # issue s241 unshift @Perlscan::PythonCode,$return; # issue 45 } } elsif($ValClass[0] !~ /[cCk]/ && index($TokenStr,'=') > 0) { # issue 45 my $new_line = $line; # issue implicit conditional return $prev_line =~ s/^\s*my\s+//; # issue 45 $prev_line =~ s/^\s*own\s+//; # issue 45 $prev_line =~ s/^\s*local\s+//; # issue s277 $prev_line =~ s/[+*\/\|\&.-]=/=/; # issue 45: Remove + from +=, etc $prev_line =~ s/^\s*\(// unless $prev_line =~ /\) =/; # issue 45: Remove (, issue s9: but not on ($v1, $v2) = my $p = index($prev_line,'='); # issue 45 if($p < 0) { # issue 45 if($prev_line =~ s/^\s*(?:(?:\+\+)|(?:--))//) { # issue 45: pre-incr/pre-decr $line = "return $prev_line"; # issue 45 $line =~ s/;.*$//; # issue 45 $line = remove_unbalanced_curly_brackets($line); # issue s13 $line =~ s/\s+#.*$//; # issue s13 } elsif($prev_line =~ /\+\+\s*;/ || # issue 45: post-incr $prev_line =~ /\+\+\s*$/ || # issue s13 $prev_line =~ /\+\+\s+#/) { # issue s13 $line = $prev_line; # issue 45 $line =~ s/^(.*)\+\+\s*;?.*$/return $1-1/; # issue 45, issue s13 $line =~ s/\s+#.*$//; # issue s13 } elsif($prev_line =~ /\+\+\s*}/) { # issue s13: post-incr $line = $prev_line; # issue s13 $line =~ s/^(.*)\+\+\s*}.*$/return $1-1/; # issue s13 } elsif($prev_line =~ /--\s*;/ || # issue 45: post-decr $prev_line =~ /--\s*$/ || # issue s13 $prev_line =~ /--\s+#/) { # issue s13 $line = $prev_line; # issue 45 $line =~ s/^(.*)--\s*;?.*$/return $1+1/; # issue 45, issue s13 $line =~ s/\s+#.*$//; # issue s13 } elsif($prev_line =~ /--\s*}/) { # issue s13: post-decr $line = $prev_line; # issue s13 $line =~ s/^(.*)--\s*}.*$/return $1+1/; # issue s13 } elsif($prev_line !~ /^\s*}/) { # issue s277 - could just be "my $var;" or "local $var;" $line = "return ".$prev_line; # issue s277 } # issue 45 } else { # issue 45 $line = "return ".substr($prev_line, 0, $p); # issue 45 $line =~ s/\s*[.+*\/\|\&-]$//; # issue 45: remove char prior to '=', like in '+=' } # issue 45 $line .=';'; # issue 45 $reparse_with_return = 1; if($comment eq '' && ($new_line ne $orig_prev_line || $prev_lno != $.) && (($new_line !~ /^\s*}\s*$/ && $new_line !~ /^\s*}\s+#/) || # issue s239 exists $line_needs_added_return{$Perlscan::statement_starting_lno})) { # issue implicit conditional return say STDERR "finish: calling getline($new_line) due to extra stuff after '}' or line_needs_added_return on line $Perlscan::statement_starting_lno" if($::debug >= 5); getline($new_line); # issue implicit conditional return } elsif(defined $orig_line && $orig_line =~ /^\s*\}/) { # issue s79 say STDERR "finish: calling getline(}".$comment.")" if($::debug >= 5); getline('}'.$comment); # issue 45, SNOOPYJC, issue implicit conditional return } } # issue 45 if($debug >= 5) { # issue 45 say STDERR "finish: Resetting line to $line"; # issue 45 } # issue 45 } # issue 45 if($reparse_with_return) { $token_buffer_active = 4 if($token_buffer_active==2); # issue s79: Sneak the 'return' inside the 'if' my $force = 1; # issue s79 if(exists $line_needs_added_return{$Perlscan::statement_starting_lno}) { # issue s79 $force = 0; # issue s79 $line_needs_added_return{$Perlscan::statement_starting_lno}--; # issue s79: Handle multiple instances if(!$line_needs_added_return{$Perlscan::statement_starting_lno}) { # issue s79: Delete if we get to 0 delete $line_needs_added_return{$Perlscan::statement_starting_lno}; # issue implicit conditional return: only do this once! } } $TrStatus = 0; &Perlscan::clone_line_varclasses($force) unless($prev_lno == $.); # issue s102, issue s79, issue s328 } else { if( defined($TrStatus) && $TrStatus < 0 ){ push(@NoTrans,"[$prev_lno]: $orig_prev_line"); } } gen_statement(); # issue 45 if(defined $code_to_update_array) { # issue s252 my @lines_to_update_array = split(/\n/, $code_to_update_array); # issue s252 for (@lines_to_update_array) { # issue s252 gen_statement($_); # issue s252 } # issue s252 } # issue s252 getline(1); # issue 45 $eval_nest = ((scalar(@eval_stack) == 0) ? -2 : $eval_stack[-1]->{eval_nest}); # issue 42 if($debug >= 3 && scalar(@eval_stack)) { say STDERR "eval_stack=@eval_stack, eval_nest=$eval_nest"; } if($eval_nest == $Pythonizer::CurNest && !$Perlscan::PREV_HAD_COLON) { # issue 42 gen_statement(); # issue 42 if(exists $SpecialVarsUsed{'$@'}) { correct_nest(1,1); # issue 42 gen_statement("$EVAL_ERROR = ''"); # issue 42, issue bootstrap correct_nest(-1,-1); # issue 42 } if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 correct_nest(1,1); # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = ''"); # issue s282 correct_nest(-1,-1); # issue s282 } # issue s282 if(exists $eval_stack[-1]->{had_return}) { # issue 42: there was a "return" statement gen_statement("except $EVAL_RETURN_EXCEPTION:"); # issue 42 correct_nest(1,1); # issue 42 if(exists $SpecialVarsUsed{'$@'} || exists $SpecialVarsUsed{'$^S'}) { # issue s282 if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = ''"); # issue s282 } if(exists $SpecialVarsUsed{'$@'}) { # issue 42 gen_statement("$EVAL_ERROR = ''"); # issue 42, issue bootstrap } } else { # issue s13 gen_statement('pass'); # issue s13 } correct_nest(-1,-1); # issue 42 } # issue 42 if(exists $SpecialVarsUsed{'$@'}) { gen_statement('except Exception as _e:'); # issue 42 } else { gen_statement('except Exception:'); # issue 42 } correct_nest(1,1); # issue 42 output_line('traceback.print_exc()') if($traceback); # SNOOPYJC if(exists $SpecialVarsUsed{'$@'} || exists $SpecialVarsUsed{'$^S'}) { # issue s282 if(exists $SpecialVarsUsed{'$@'}) { $Pyf{"_exc"} = 1; # issue 42 #gen_statement('EVAL_ERROR = _exc(_e)'); # issue 42 gen_chunk("$EVAL_ERROR = ", '_exc', '(_e)'); # SNOOPYJC: Gen separately to support perllib gen_statement(); # SNOOPYJC } if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = ''"); # issue s282 } } else { gen_statement('pass'); } correct_nest(-1,-1); # issue 42 if(exists $eval_stack[-1]->{assignment}) { # issue 42 unpackage_tokens($eval_stack[-1]->{assignment}); # issue 42 if(exists $eval_stack[-1]->{continue}) { # issue s329 push @saved_sub_tokens_stack, $saved_sub_tokens; # issue s329 push @saved_sub_tokens_level, $nested_sub_at_level; # issue s329 $saved_sub_tokens = package_tokens(); # isssu s329 #say STDERR "Restoring saved_sub_tokens - continuing to tokenize $line" if($debug); # issue s329 #$skip_bash_style_or_and_fix = 1; # issue s329 #tokenize($line, 1); # issue s329: Continue where we left off #$skip_bash_style_or_and_fix = 0; # issue s329 #$line=getline(0) if $got_new_line; # issue s329 } elsif($ValClass[0] eq 's' && $ValPy[0] eq $ValPy[2] && $#ValClass == 2) { # issue 42: Skip generating _eval_result = _eval_result, issue s329 ; # issue 42 } else { # issue 42 assignment($ValClass[0] eq 't' ? 1 : 0); # issue 42 - generate the code for the assignment we packaged up } # issue 42 gen_statement(); # issue 42 } # issue 42 pop @eval_stack; # issue 42 } if($context_manager_nest == $Pythonizer::CurNest-1 && $ValClass[0] ne 'c') { # issue 66 if($debug >= 3) { # issue 66 say STDERR "Resetting context manager nest"; # issue 66 } correct_nest(-1); # issue 66 $context_manager_nest = -2; # issue 66 } # issue 66 correct_nest(); if($Perlscan::nesting_level < $nested_sub_at_level) { # issue 78 pop @nested_sub_at_levels; # issue s241 $nsal = scalar(@nested_sub_at_levels) ? $nested_sub_at_levels[-1] : -1; # issue s241 say STDERR "Setting nested_sub_at_level = $nsal (was $nested_sub_at_level), nested_sub_at_levels=@nested_sub_at_levels" if $debug >= 3; # issue s241 # issue s241 $nested_sub_at_level = -1; $nested_sub_at_level = $nsal; # issue s241 } elsif(!$we_are_in_sub_body && $nested_sub_at_level == 0 && $Perlscan::nesting_level == 0) { # issue s252 pop @nested_sub_at_levels; # issue s252 say STDERR "Setting nested_sub_at_level = -1 (was $nested_sub_at_level), nested_sub_at_levels=@nested_sub_at_levels" if $debug >= 3; # issue s252 $nested_sub_at_level = -1; # issue s252 } } # finish sub copy_partially_initialized_locals # issue 108 # If we have locals that are only partially initialized (e.g. local ($arr[0]) = val;), then we must make a copy first { ($from,$to)=@_; for(my $i=$from; $i<=$to; $i++) { if($ValClass[$i] eq 's' && $ValClass[$i+1] eq '(') { gen_statement("$ValPy[$i] = $ValPy[$i].copy()"); $i = end_of_variable($i); } } } sub rsv # issue 129 # Given a {state_var}, return {renamed_state_var}, if found { my $name = shift; $name = substr($name,1,length($name)-2); # eat the '{' and '}' if(exists($new_state_var_name{$name})) { return '{' . $new_state_var_name{$name} . '}'; } return '{' . $name . '}'; } sub rename_state_var { ($from,$to)=@_; for(my $i=$from; $i<=$to; $i++ ){ if( defined($ValClass[$i]) && $ValClass[$i]=~/[sah]/ && exists($new_state_var_name{$ValPy[$i]}) ){ my $new_name = $new_state_var_name{$ValPy[$i]}; if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{$CurSub}) { # SNOOPYJC: Copy it's type over $VarType{$new_name}{$CurSub} = $VarType{$ValPy[$i]}{$CurSub}; } $ValPy[$i]=$new_name; } elsif(defined($ValClass[$i]) && ($ValClass[$i] =~ /["qx]/ || ($ValClass[$i] eq 'f' && $ValPerl[$i] eq 're')) && $ValPy[$i] =~ /\br?f['"]/) { # issue 129 $ValPy[$i] =~ s/\{\w+\}/rsv($&)/ge; # issue 129 } } } sub initialize_globals_for_state_vars { my @state_var = keys %new_state_var_name; # SNOOPYJC # SNOOPYJC my @renamed_state_var=values(%new_state_var_name); if($debug >= 3) { # SNOOPYJC say STDERR "initialize_globals_for_state_vars: @state_var"; } return unless( scalar(@state_var) && defined($state_var[0]) ); # nothing to do # SNOOPYJC foreach $sv (@state_var) { # SNOOPYJC my $renamed_sv = $new_state_var_name{$sv}; my $val = 'None'; # SNOOPYJC $renamed_sv =~ /^(.*)_$sv$/; my $sv_sub = $1; # SNOOPYJC: Get the sub name from the renamed sv name #say STDERR "sv_sub = $sv_sub"; if( exists($new_state_var_init{$sv}) ){ $val = $new_state_var_init{$sv}; if($val eq '$flag') { # issue 128: We have to gen a flag instead my $flag_sv = state_flag_name($renamed_sv); gen_statement("$flag_sv = True"); next; } } elsif(exists($VarType{$sv}{$sv_sub})) { # SNOOPYJC $val = init_val($VarType{$sv}{$sv_sub}); # SNOOPYJC: Use our computed type for the init } gen_statement($renamed_sv.' = '.$val); } } # # Print statement for Python 3 # sub print3 { my $begin=$start=$_[0]; my ($k,$handle); my $end_pos=$#ValClass; # issue 10 $end_pos = $_[1] if(scalar(@_) >= 2); # issue s278 # end="") instead of trailing comma in Python 2 if($start+1 <= $#ValClass && $ValClass[$start+1] eq '(') { # issue printf: handle bracketed $end_pos = matching_br($start+1) - 1; $start++; } if( $start+1 <= $#ValClass && $ValClass[$start+1] =~ /[is]/ ){ # issue 32 $handle=$ValPy[$start+1]; $k=$start+2; if($k <= $#ValClass && ($ValClass[$k] eq ',' || $ValClass[$k] eq 'D')) { # issue 32; handle print $session->elapsed_time(...), issue 93 $handle=''; $k = $start+1; }elsif($ValClass[$start+1] eq 's' && ($end_pos == $start+1 || $ValClass[$start+2] eq '(')) { # issue 32 $handle=''; $k = $start+1; }elsif($ValClass[$start+1] eq 's' && $start+3 >= $#ValClass && $ValClass[$start+2] eq '.') { # SNOOPYJC: handle print $str . "\n"; $handle=''; $k = $start+1; }elsif(($ValClass[$start+1] eq 'i' && ($LocalSub{$ValPy[$start+1]}) || (!$Constants{$ValPy[$start+1]} && $start+3 < $#ValClass && $ValClass[$start+2] eq '('))) { # SNOOPYJC: Handle print &sub -or- print sub() $handle=''; $k = $start+1; } }else{ $handle=''; $k=$start+1; $handle=$_[2] if(scalar(@_) >= 3); # SNOOPYJC: warn, issue s278 } # issue 10 if( $#ValClass>$k ){ if($debug >= 3) { say STDERR "print3($begin) start=$start, handle=$handle, k=$k, end_pos=$end_pos\n"; } # issue s278 if($begin != 0 && $ValClass[$begin-1] eq '(' && $ValClass[-1] eq ')') { # issue 10: Surrounded by ( ) # issue s278 $end_pos--; # issue s278 if($debug >= 3) { # issue s278 say STDERR "setting end_pos = $end_pos\n"; # issue s278 } # issue s278 } my $sep = ''; # if($SpecialVarsUsed{'$,'}) { # $sep = ($import_perllib ? ", sep=$PERLLIB.OUTPUT_FIELD_SEPARATOR" : ', sep=OUTPUT_FIELD_SEPARATOR'); # } # if((!exists $SpecialVarsUsed{'$\\'}) && $start == 0 && ($traceback == 0 || $handle eq '' || $handle eq 'sys.stdout' || $handle eq 'sys.stderr')) { # issue 77 # gen_chunk($ValPy[$start],'('); # } else { # issue 77 # $sep = ''; # it's built-in to _perl_print $Pyf{"_perl_print"} = 1; # issue 77 gen_chunk('_perl_print', '('); # issue 77 - this print returns 1 on success # } # issue 77 if( $end_pos>=$k ){ # issue 10 # issue 10 $TrStatus=expression($k,$#ValClass,0); if($ValPerl[$begin] eq 'printf') { # issue printf if($ValClass[$k] eq '(' && $ValPerl[$k] eq '(') { # issue printf my $close = matching_br($k); $k++; $end_pos = $close-1; } my $comma=next_same_level_token(',',$k,$end_pos); $comma = $end_pos+1 if($comma < 0); $Pyf{_format} = 1; # SNOOPYJC gen_chunk('_format', '('); # SNOOPYJC $TrStatus=expression($k,$comma-1,0); # format return -1 if ($TrStatus<0); if($ValClass[$k] eq 'a' && $comma == $end_pos+1) { # format is first element of the array # SNOOPYJC gen_chunk('[0] % (', $ValPy[$k], '[1:])'); gen_chunk('[0], (', $ValPy[$k], '[1:])'); # SNOOPYJC } else { # SNOOPYJC gen_chunk(' % ('); if($comma+1 <= $end_pos) { # SNOOPYJC gen_chunk(', ('); # SNOOPYJC $TrStatus=expression($comma+1,$end_pos,0); # list gen_chunk(')'); } } gen_chunk(')'); # SNOOPYJC } else { $TrStatus=expression($k,$end_pos,2); # issue 10, issue print array } return -1 if ($TrStatus<0); }else{ $end = ($ValPerl[$begin] eq 'print' || $ValPerl[$begin] eq 'printf') ? ', end=""' : ''; # issue 59 $def = $DEFAULT_VAR; # issue printf $def = "$CONVERTER_MAP{S}($def)" unless default_var_string(); # issue s104 if($ValPerl[$begin] eq 'printf') { $def .= ' % ()'; } if(length($handle)>0){ # issue 59 gen_chunk("file=$handle)"); gen_chunk("$def, file=$handle$end)"); # issue 59 }else{ # issue 59 gen_chunk(')'); gen_chunk("$def$end)"); # issue 59 } return 0; } if (($ValPerl[$begin] eq 'print' || $ValPerl[$begin] eq 'printf') && $ValClass[-1] eq '"' ){ if( $Perlscan::PythonCode[-1]=~qr[\\n["']$] && $Perlscan::PythonCode[-1]!~qr[\\\\n["']$]){ # issue ddts substr($Perlscan::PythonCode[-1],-3,2)=''; # Perl print was actually say }else{ gen_chunk(',end=""'); } } elsif($ValPerl[$begin] eq 'print' || $ValPerl[$begin] eq 'printf') { # issue 59 gen_chunk(',end=""'); } if( $handle){ #printing to file handle gen_chunk(',file=',$handle); # Python 3.x: print('hello world', file=file_object) } #say gen_chunk(')'); #if($end_pos != $#ValClass) { # issue 10 #gen_chunk(')'); # issue 10 #} # issue 10 return scalar(@ValClass); } # print3 sub assignment # # Analyse and generate code for Perl assignment statement # { my $start=$_[0]; # start of analysys of assignment statement if( $start<0 || $TrStatus<0 ){ return -255; } my $limit=(scalar(@_)>1) ? $_[1] : $#ValClass; # Nov 11, 2019 accept not only the index of the first token, but also index of the last. if($debug >= 3) { say STDERR "assignment($start, $limit) =|$TokenStr|= @ValPerl\n" } my ($k,$split,$post_processing,$comma_pos,$colon_pos,$from,$to); # # Assignment with post condition need to be transformed into regular control structure in Python # my $viv_me; # issue s198: Variable that needs to be autovivified (if possible) $k=$start; if(exists $SpecialVarR2L{$ValPy[$k]}) { # SNOOPYJC: Change _nr() to INPUT_LINE_NUMBER etc $ValPy[$k] = $SpecialVarR2L{$ValPy[$k]}; } # issue s214: Replace stores to package.__dict__ with setattr calls if($ValPerl[$k] eq '*' && $ValPy[$k] =~ /^([A-Za-z0-9_.]+)\.__dict__$/ && $k+1 <= $#ValClass && $ValClass[$k+1] eq '(' && $ValPerl[$k+1] eq '{') { my $close = matching_br($k+1); last if $close < 0; next if $close+1 > $#ValClass; next if $ValClass[$close+1] ne '='; my $end_pos = end_of_assignment($k, $close+1); insert($end_pos+1, ')', ')', ')'); replace($close+2, 'y', $ValPerl[$close+2], $ValPy[$close+2]) if($ValClass[$close+2] eq 'k'); replace($close+1, ',', ',', ','); destroy($close, 1); replace($k+1, ',', ',', ','); replace($k, 'y', $1, $1); insert($k, '(', '(', '('); insert($k, 'f', 'setattr', 'setattr'); return function($k); } # # C-style ++ and -- # if( $ValClass[$#ValClass] eq '^' ){ if ($#ValClass-$start==1){ if($ValPy[$k] =~ /^\(len\((.*)\)-1\)$/) { # issue 14 - increment or decrement array length $arrName = $1; # issue 14 if($ValPerl[$#ValClass] eq '++') { # issue 14: add one element to array gen_chunk("$arrName.append(None)"); # issue 14 } else { # issue 14 gen_chunk("del $arrName".'[len('.$arrName.')-1:]'); # issue 14 } } else { # issue 14 gen_chunk($ValPy[$k],$ValPy[$k+1]); } return $#ValClass+1; }else{ replace($#ValClass,'=','=',substr($ValPy[-1],0,2)); append('d','1','1'); $limit+=1; if($debug >= 3) { say STDERR "assignment_updated($start, $limit) =|$TokenStr|= @ValPerl\n" } } } # # We assume this is a regular assignment with "=". Let's analyse the left side. # my $add_right_paren = 0; # issue 14 my $skip_assign_op = 0; # issue 14 my $extra = -1; # SNOOPYJC my $orig_limit = $limit; # SNOOPYJC my $number_of_elements = undef; # issue 56, SNOOPYJC: Handle () my $left_composite = ''; # issue s198: Flag if left has an array or hash in it my $left_extra_start = undef; # issue s198: Start of extra elements after an array or hash # issue 105 if( ($split=index($TokenStr,'=',$k))>-1 ){ if( ($split=next_same_level_token('=', $k, $#ValClass)) != -1) { # issue 105: skip any := in the LHS if($split+1 <= $#ValClass && $ValClass[$split+1] eq 'C' && $ValPerl[$split+1] eq 'eval') { # issue 42, issue s231 if(handle_assign_eval($split+1)) { # issue 42 return $#ValClass; # issue 42 } # issue 42 $limit = $#ValClass; # issue 42 - we deleted the (...) } # issue 42 $extra = next_lower_or_equal_precedent_token(',', $split+1, $limit); # SNOOPYJC # Handle things like $j=$i, $k=$j, ... if($extra >= 0 && $extra < $limit) { # Watch out for an unparenthesized function or sub call though, as those commas belong to him! for(my $x = $split+1; $x < $extra; $x++) { if($ValClass[$x] =~ /[if]/ && $ValPerl[$x+1] ne '(') { $extra = -1; last; } } if($extra >= 0) { $limit = $extra-1; my $dot = rindex($ValPy[$k], '.'); # issue s328 if($dot != -1) { # issue s328 $Pyf{_assign_global} = 1; # issue s328 gen_chunk('_assign_global'); # issue s328 } gen_chunk('('); $add_right_paren = 1; if($ValPy[$split] ne '=' && $ValPy[$split] ne ':=') { # Handle +=, etc # Change $a+=2 to $a = $a + 2 insert($split+1,$ValClass[$k],$ValPerl[$k],$ValPy[$k]); $op = substr($ValPerl[$split],0,1); insert($split+2,$op,$op,$op); $limit += 2; $extra += 2; $orig_limit += 2; # issue 116 } $ValPy[$split] = ':='; if($dot != -1) { # issue s328 my $a = substr($ValPy[$k], 0, $dot); # issue s328 my $b = substr($ValPy[$k], $dot+1); # issue s328 $ValPy[$k] = "'$a', '$b', "; # issue s328 $ValPy[$split] = ''; # issue s328 } # issue s328 } } else { $extra = -1; } if( $split-$k==1 ){ if($ValPy[$k] =~ /^\(len\((.*)\)-1\)$/) { # issue 14 - assign array last element index if($ValPy[$split] ne '=' && $ValPy[$split] ne ':=') { # issue 14 - handle +=, -=, etc $ValPy[$split] = '='; # issue 14 insert($split+1,$ValClass[$k],$ValPerl[$k],$ValPy[$k]); # issue 14 $op = substr($ValPerl[$split],0,1); # issue 14 insert($split+2,$op,$op,$op); # issue 14 $limit += 2; # issue 14 } # issue 14 $Pyf{"_set_last_ndx"} = 1; # issue 14 gen_chunk('_set_last_ndx', "($1,"); # issue 14 $add_right_paren = 1; # issue 14 $skip_assign_op = 1; # issue 14 } else { # issue 14 # single token on the left side -- regular assignment; gen_chunk($ValPy[$k]); # simple scalar assignment -- varible of left side $left_composite = $ValClass[$k] if($ValClass[$k] eq 'a' || $ValClass[$k] eq 'h'); # issue s198 if(defined $ValType[$k]) { # issue s261 if($ValType[$k] eq '@s') { # issue s261 $left_composite = 'a'; # issue s261 gen_chunk('[:]'); # issue s261 } elsif($ValType[$k] eq '%s') { # issue s261 $left_composite = 'h'; # issue s261 gen_chunk('.clear()'); # issue s261 gen_statement(); # issue s261 gen_chunk($ValPy[$k], '.update('); # issue s261 $add_right_paren = 1; # issue s261 $skip_assign_op = 1; # issue s261 } } if($ValPerl[$k] eq '$?' && substr($CurSub, 0, 7) eq '__END__') { # SNOOPYJC logme('W', "Sorry, python does not support setting the exit code in an END (atexit) block"); } } # issue 14 }elsif( $ValPerl[$k] eq '(' && $ValPerl[$k+1] eq ')') { # SNOOPYJC: goatse $number_of_elements = 0; # SNOOPYJC gen_chunk('[]'); }elsif($k+2 < $split && $ValPerl[$k] eq '(' && ($ValClass[$k+1] eq 'a' || $ValClass[$k+1] eq 'h' || ($ValClass[$k+1] eq 'G' && (&Perlscan::choose_glob_and_get_type($ValPerl[$k+1], $ValPy[$k+1], 1))[0] =~ /[ah]/)) && $ValPerl[$k+2] eq ')') { # SNOOPYJC local (@arr) = ..., issue s198: Handle hash and typeglob too $left_composite = $ValClass[$k+1]; # issue s198 $start = $k+1; # issue s198 if($ValClass[$k+1] eq 'G') { # issue s198 gen_chunk(&Perlscan::choose_glob($ValPerl[$k+1], $ValPy[$k+1])); # issue s198 } else { gen_chunk($ValPy[$k+1]); } $k += 3; # issue s43 } elsif($ValPy[$k] eq '[' && $k+3 < $#ValClass && $ValClass[$k+1] =~ /[as]/ && $ValClass[$k+2] eq 'y' && $ValPerl[$k+2] eq 'multi' && # issue s43 $ValPy[$k+2] !~ /\.get\(/ && # issue s43 ($ValPy[$k+3] eq '[' || ($ValClass[$k+3] eq 'f' && $ValPy[$k+3] eq $CONVERTER_MAP{'a of I'} && $ValPy[$k+5] eq '['))) { # issue s43 # [@a[_i] for _i in [list]] = values => _assign_sparse(a, [list], [values]) # issue s43 $Pyf{_assign_sparse} = 1; # issue s43 gen_chunk('_assign_sparse', '(', $ValPy[$k+1], ','); # issue s43 my $open = $k+3; # issue s43 $open = $k+5 if($ValClass[$open] eq 'f'); # issue s43 my $l = matching_br($open); # issue s43 $TrStatus = expression($open, $l, 0); # issue s43 gen_chunk(','); # issue s43 $add_right_paren++; # issue s43 $skip_assign_op = 1; } elsif($ValPy[$k] eq '[' && $k+7 < $#ValClass && $ValClass[$k+1] eq 'f' && $ValClass[$k+3] =~ /[as]/ && (($ValClass[$k+7] eq 'y' && $ValPerl[$k+7] eq 'multi') || ($k+12 < $#ValClass && $ValClass[$k+10] eq 'y' && $ValPerl[$k+10] eq 'multi'))) { # issue s43 # [@a[_i] for _i in [list]] = values => _assign_sparse(a, [list], [values]) $Pyf{_assign_sparse} = 1; gen_chunk('_assign_sparse', '(', $ValPy[$k+3], ','); my $y = $k+7; $y = $k+10 unless($ValClass[$y] eq 'y'); # There could be a converter on the _i my $open = $y+1; $open = $y+3 if($ValClass[$open] eq 'f'); # There could be a converter here too on the [...,...] my $l = matching_br($open); $TrStatus = expression($open, $l, 0); gen_chunk(','); $add_right_paren++; $skip_assign_op = 1; } elsif($ValPy[$k] eq '[' && $k+3 < $#ValClass && $ValClass[$k+1] =~ /[as]/ && $ValClass[$k+2] eq 'y' && $ValPerl[$k+2] eq 'multi' && $ValPy[$k+2] =~ /\.get\(/ && ($ValPy[$k+3] eq '[' || ($ValClass[$k+3] eq '\\' && array_or_array_func($k+4)) || # issue s160: we change [@arr] to \@arr, so handle that here, issue s202 ($ValClass[$k+3] eq 'q' && $ValPy[$k+3] =~ /\.split\(\)$/) || # issue s38 ($ValClass[$k+3] eq 'f' && $ValPy[$k+3] eq $CONVERTER_MAP{'a of S'} && ($ValPy[$k+5] eq '[' || ($ValClass[$k+5] eq '\\' && array_or_array_func($k+6))) # issue s160: handle _map_str(\@arr) too, issue s202 ))) { # issue bootstrap # [@a.get(_i) for _i in [list]] = values => _assign_hash(a, [list], [values]) $Pyf{_assign_hash} = 1; gen_chunk('_assign_hash', '(', $ValPy[$k+1], ','); my $open = $k+3; if($ValClass[$open] eq 'q') { # issue s38: qw/.../ $TrStatus = expression($open, $open, 0); # issue s38 } elsif($ValClass[$open] eq '\\') { # issue s160 my $l = matching_br($k); # issue s160 $ValPy[$open+1] =~ s/\.copy\(\)$// if $open+1 == $l-1; # issue s321: No need to copy it here $TrStatus = expression($open+1, $l-1, 0); # issue s160 } elsif($ValClass[$open] eq 'f') { # issue s160 $open = $k+5; # issue s160 if($ValClass[$open] eq '\\') { # issue s160 my $l = matching_br($k+4); # issue s160 $ValPy[$open+1] =~ s/\.copy\(\)$// if $open+1 == $l-1; # issue s321: No need to copy it here $TrStatus = expression($open+1, $l-1, 0); # issue s160 } else { my $l = matching_br($open); $ValPy[$open+1] =~ s/\.copy\(\)$// if $open+1 == $l-1; # issue s321: No need to copy it here $TrStatus = expression($open+1, $l-1, 0); } } else { my $l = matching_br($open); $ValPy[$open+1] =~ s/\.copy\(\)$// if $open+1 == $l-1; # issue s321: No need to copy it here $TrStatus = expression($open+1, $l-1, 0); } gen_chunk(','); $add_right_paren++; $skip_assign_op = 1; }elsif( $ValPerl[$k] eq '(' ){ # brackets on the left side -- we assume that this is the list on the left side # # Issue 56: perl allows the length of the list on the lhs and rhs to be different. Handle this # by inserting a function surrounding the rhs which returns the proper number of elements # corresponding to the lhs. Pass that # to the function. # gen_chunk('['); $k++; # issue s198 if($ValClass[$k] eq 'f' && $ValPerl[$k] eq 'undef') { # issue 63 # issue s198 gen_chunk('_'); # issue 63 # issue s198 } elsif($ValClass[$k] eq 'G') { # issue 108 # issue s198 gen_chunk(&Perlscan::choose_glob($ValPerl[$k], $ValPy[$k])); # issue s198 } elsif($ValClass[$k] eq 's' && $ValClass[$k+1] eq '(') { # Some sort of array index or hash key # issue s198 my $l = end_of_variable($k); # issue s198 $TrStatus = expression($k, $l, 0); # issue s198 $k = $l; # issue s198 } else { # issue s198 gen_chunk($ValPy[$k]); # first in the cascading assignement # issue s198 } # issue s198 $number_of_elements++; # issue 56 # issue s198 $k++; while($k<$split ){ # this was we skip delimiters # issue 63 if( substr($TokenStr,$k,1)=~/^[sha]/ ){ if( substr($TokenStr,$k,1)=~/^[shafG]/ ){ # issue 63: handle multiple undef in lhs list, issue 108 gen_chunk(',') if defined $number_of_elements && !defined $left_extra_start; # issue s198: Remove duplicate code from above if($ValClass[$k] eq 'f' && $ValPerl[$k] eq 'undef') { # issue 63 # issue s198 gen_chunk(',_'); # issue 63 gen_chunk('_'); # issue 63, issue s198 } elsif($ValClass[$k] eq 'G') { # issue 108 # issue s198 gen_chunk(','.&Perlscan::choose_glob($ValPerl[$k], $ValPy[$k])); my ($typ, $py) = &Perlscan::choose_glob_and_get_type($ValPerl[$k], $ValPy[$k]); # issue s198 if($left_composite) { # issue s198: We can only use '*' once $left_extra_start = $k unless defined $left_extra_start; # issue s198 } elsif($typ eq 'a' || $typ eq 'h') { # issue s198 $left_composite = $typ; # issue s198 $viv_me = $py; # issue s198 gen_chunk('*'); # issue s198 } # issue s198 gen_chunk($py) unless defined $left_extra_start; # issue s198 } elsif($ValClass[$k] eq 's' && $ValClass[$k+1] eq '(') { # Some sort of array index or hash key my $l = end_of_variable($k); # issue s198 gen_chunk(','); $TrStatus = expression($k, $l, 0); $k = $l; } else { # issue s198 gen_chunk(','.$ValPy[$k]); if($left_composite) { # issue s198: We can only use '*' once $left_extra_start = $k unless defined $left_extra_start; # issue s198 } elsif($ValClass[$k] eq 'a' || $ValClass[$k] eq 'h') { # issue s198 $left_composite = $ValClass[$k]; # issue s198 $viv_me = $ValPy[$k]; # issue s198 gen_chunk('*'); # issue s198 } # issue s198 gen_chunk($ValPy[$k]) unless defined $left_extra_start; # issue s198 } $number_of_elements++ unless defined $left_extra_start; # issue 56, issue s198 } $k++; } gen_chunk(']'); $k++; } elsif($ValClass[$k] eq 'a' && $k+1 <= $#ValClass && $ValClass[$k+1] eq '(' && $ValPerl[$k+1] eq '{') { # @a{keys} = values => _assign_hash(a, [keys], [values]) $left_composite = 'h'; # issue s198 $Pyf{_assign_hash} = 1; my $l = matching_br($k+1); gen_chunk('_assign_hash', '(', $ValPy[$k], ','); $TrStatus = expression($k+2, $l-1, 0); gen_chunk(','); $add_right_paren++; $k = $l + 1; $skip_assign_op = 1; } elsif($ValClass[$k] eq 'G' && $split-$k == 1) { # issue s198 gen_chunk(&Perlscan::choose_glob($ValPerl[$k], $ValPy[$k])); # issue s198 }else{ # possibly array with complex subscripts or complex hash key expression if(substr($TokenStr,$k) =~ /^s\([si"]\)=\(\)$/ && $ValPerl[$k+1] eq '{' && $ValPy[$k+5] eq '(') { # issue 36 # Assigning an empty tuple to a hash value is never what you want if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; $ValPy[$k+5] = ($import_perllib ? "$PERLLIB.Hash(" : 'Hash('); $ValPy[$k+6] = ')'; } else { $ValPy[$k+5] = '{'; # issue 36 $ValPy[$k+6] = '}'; # issue 36 } } # SNOOPYJC: Assigning to $ARGV[n] produces code that doesn't work as # it assigns to the slice (sys.argv[1:]), not the real variable, so fix that up here. my $r; if($ValClass[$k] eq 's' && $ValPerl[$k] eq '$ARGV' && $ValClass[$k+1] eq '(') { # SNOOPYJC substr($ValPy[$k],-4) = ''; # Lose the '[1:]' if($ValClass[$k+2] eq 'd') { # Easy case $ValPy[$k+2] += 1; } else { insert($k+2, '+', '+', '+'); insert($k+2, 'd', '1', '1'); $split += 2; $limit += 2; } } elsif($ValClass[$k] eq 'a' && $ValPerl[$k] eq '@ARGV' && $ValClass[$k+1] eq '(' && ($r = next_same_level_token('r', $k+2, matching_br($k+1)))) { # SNOOPYJC: Handle range assignment too $left_composite = 'a'; # issue s198 substr($ValPy[$k],-4) = ''; # Lose the '[1:]' if($ValClass[$k+2] eq 'd') { # Easy case $ValPy[$k+2] += 1; } else { insert($k+2, '+', '+', '+'); insert($k+2, 'd', '1', '1'); $split += 2; $limit += 2; $r += 2; } if($ValClass[$r+1] eq 'd') { # Easy case $ValPy[$r+1] += 1; } else { insert($r+1, '+', '+', '+'); insert($r+1, 'd', '1', '1'); $split += 2; $limit += 2; } } $k=expression($k,$split-1,0); # on the left side it can be array index or something more complex return -255 if ($k<0); } # issue 14 gen_chunk($ValPy[$split]); # generate appropriate operation hidden under generic token '=' ( +=, -=, etc) gen_chunk($ValPy[$split]) unless $skip_assign_op == 1; # issue 14: generate appropriate operation hidden under generic token '=' ( +=, -=, etc) if(defined $number_of_elements && rhs_has_same_number_of_elements($number_of_elements, $split+1, $limit)) { # issue s59 undef $number_of_elements; } if(defined $number_of_elements) { # issue 56, SNOOPYJC: Handle goatse if($left_composite) { # issue s198 $Pyf{"_list_of_at_least_n"} = 1; # issue s198 gen_chunk('_list_of_at_least_n', '('); # issue s198 $number_of_elements--; # issue s198: We don't need a 'None' to fill the composite value } else { # issue s198 $Pyf{"_list_of_n"} = 1; # issue 56 gen_chunk('_list_of_n', '('); # issue 56 } # issue s232 if($ValClass[$split+1] eq '(') { # issue s130 if($ValPerl[$split+1] eq '(') { # issue s130, issue s232 my $adjust = flatten_lists($split+1, 0); # issue s130 $limit += $adjust; # issue s130 #gen_list($split+1, 0); # issue s308 #gen_chunk(", $number_of_elements)") if(defined $number_of_elements); # issue 56, SNOOPYJC #gen_chunk(')') if($add_right_paren); # issue 14 #if($extra >= 0) { #gen_extra($extra, $orig_limit); # issue 116 #} #return($#ValClass); # issue s308 } # issue s130 } # issue 56 if( $limit - $split == 1 ){ # only one token after '=' if($debug >= 3) { say STDERR "assign, ValClass[limit] = $ValClass[$limit], ValPy=$ValPy[$limit], ValPerl=$ValPerl[$limit]\n"; } if ($ValClass[$limit] eq 'x' ) { my $func = '_run'; # issue 118 my $context = list_or_scalar_context($start, $limit); # issue 118 if($context != 1) { $func = '_run_s'; } $Pyf{$func} = 1; # issue 118 if($autovivification && $func eq '_run') { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 } # issue s359 gen_chunk($func, '(', $ValPy[$split+1], ')'); # SNOOPYJC: handle AUTODIE, TRACEBACK, issue 118 if($autovivification && $func eq '_run') { gen_chunk(')'); } # issue 118 gen_chunk(qq{subprocess.run($ValPy[$split+1],capture_output=True,text=True,shell=True)}); # issue 118 gen_statement(); # issue 118 if($autodie || exists $SpecialVarsUsed{'$?'}) { # SNOOPYJC # issue 118 gen_statement(qq{$SUBPROCESS_RC=$ValPy[$split-1].returncode}); # issue 118 } # issue 118 gen_chunk($ValPy[$k]); # issue 118 gen_chunk($ValPy[$split]); # issue 118 gen_chunk($ValPy[$k].'.stdout'); # issue 118 if($autodie) { # SNOOPYJC # issue 118 gen_statement(); # issue 118 gen_statement("if $SUBPROCESS_RC:"); # issue 118 correct_nest(1,1); # issue 118 gen_statement("raise Die(f'run(${\(escape_string(unquote_string($ValPy[$split+1]), '\''))}): failed with {$SUBPROCESS_RC}')"); # issue 118 correct_nest(-1,-1); # issue 118 } }elsif($ValClass[$limit] eq 'f') { # Issue 8: this is a function like shift with no args function($limit,$limit); # Issue 8 # SNOOPYJC }elsif($ValClass[$limit] eq 'i' && $ValPy[$limit] eq $ValPerl[$limit]) { # issue 13 }elsif($ValClass[$limit] eq 'i') { # issue 13, SNOOPYJC if( $LocalSub{$ValPy[$limit]} ){ # issue 13: local sub call with no parens gen_chunk(escape_keywords($ValPy[$limit])); # issue 13, issue 41 if(inherited_wantarray($start)) { # issue s241 gen_chunk('(wantarray=wantarray)'); # issue s241 # issue s241 } elsif(exists $SubAttributes{$ValPy[$limit]}{wantarray} && list_or_scalar_context($start, $limit) == 1) { # issue s3 } elsif(defined get_sub_attribute($ValPy[$limit], 'wantarray') && list_or_scalar_context($start, $limit) == 1) { # issue s3 gen_chunk('(wantarray=True)'); # issue s3 # issue s241 } elsif(exists $SubAttributes{$ValPy[$limit]}{wantarray} && void_context($start)) { # issue s241 } elsif(defined get_sub_attribute($ValPy[$limit], 'wantarray') && void_context($start)) { # issue s241 gen_chunk('(wantarray=None)'); # issue s241 } else { gen_chunk('()'); # issue 13 } } elsif ($Constants{$ValPy[$limit]}) { # issue 13: constant or file handle gen_chunk($ValPy[$limit]); # issue 13 } else { # issue 13: bare word - treat as string gen_chunk("'".$ValPy[$limit]."'"); # issue 13 } }elsif((defined $number_of_elements || $left_composite eq 'a') && ($ValClass[$limit] eq 'h' || is_hash($limit))) { # SNOOPYJC: "($k, $v) = %h;" tested in issue 115, issue s173, issue s198 # issue s198 gen_chunk('list(*'); # Splat it if($autovivification) { # issue s198 $Pyf{Array} = 1; # issue s198 gen_chunk('Array', '(itertools.chain.from_iterable('); # issue s198 } else { # issue s198 gen_chunk('list(itertools.chain.from_iterable('); # issue s198 } gen_chunk($ValPy[$limit]); # that includes diamond operator <> and Aug 10,2020 # issue s198 gen_chunk('.items())'); gen_chunk('.items()))'); # issue s198 }elsif($ValClass[$limit] eq 'q' && index($ValPy[$limit], ':=') > 0) { # SNOOPYJC: Handle regex with default var and groups in assignment my $g_flag = 0; # SNOOPYJC $g_flag = 1 if($ValPy[$limit] =~ /\bre\.G/); if($g_flag) { $ValPy[$limit] =~ s/,re\.G\|/,/; $ValPy[$limit] =~ s/.re\.G//; $ValPy[$limit] =~ s/\($DEFAULT_MATCH:=re\.search/[$DEFAULT_MATCH\[0] for $DEFAULT_MATCH in (re.finditer/; } gen_chunk('('); gen_chunk($ValPy[$limit]); # issue 57: Generate proper code for when we're in list context or scalar context my $context = list_or_scalar_context($start, $limit); # issue 118 say STDERR "context of regex = $context" if($debug >= 5); if($autovivification && $context == 1) { # issue s359: Array $Pyf{Array} = 1; # issue s359 gen_chunk(',', 'Array', "(${DEFAULT_MATCH}.groups()) if $DEFAULT_MATCH else", 'Array', '())[1]'); # issue s359 } elsif($context == 1) { # list gen_chunk(",${DEFAULT_MATCH}.groups() if $DEFAULT_MATCH else [])[1]"); # issue 57, 32 } elsif($context == 0) { gen_chunk(",_pb($DEFAULT_MATCH))[1]"); # issue 57, 32, issue s124 } else { # issue 57 gen_chunk(')'); # close expression } gen_chunk(']') if($g_flag); } elsif($ValClass[$start] eq 'h' && $ValClass[$limit] eq 'a') { # issue s198: %hash = @arr if($autovivification) { # issue s198 $Pyf{Hash} = 1; # issue s198 gen_chunk('Hash', "({$ValPy[$limit]"."[$INDEX_TEMP]:".$ValPy[$limit]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$limit]."),2)})"); # issue s198 } else { # issue s198 gen_chunk("{$ValPy[$limit]"."[$INDEX_TEMP]:".$ValPy[$limit]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$limit]."),2)}"); # issue s198 } } elsif(($ValClass[$start] eq 'a') && $ValClass[$limit] eq 'a') { # issue s198: Array copy if($autovivification) { # issue s198 $Pyf{Array} = 1; # issue s198 gen_chunk('Array', '(', $ValPy[$limit], ')'); # issue s198 } elsif($ValPerl[$limit] eq '@_' && ($nested_sub_at_level > 0 || # issue s241 ($CurSub ne '__main__' && !exists $SubAttributes{$CurSub}{modifies_arglist}))) { # issue s198 ($CurSub ne '__main__' && !defined get_sub_attribute($CurSub, 'modifies_arglist')))) { # issue s198, issue s241 # In this case our args are still a tuple, which has no ".copy()" operation gen_chunk("list($ValPy[$limit])"); # issue s198 } else { gen_chunk("$ValPy[$limit].copy()"); # issue s198 } }else{ if($autovivification && $ValClass[$limit] eq 's' && $ValPerl[$limit] eq '$_' && $ValPy[$limit] =~ /^$PERL_ARG_ARRAY\[/) { # issue s359 $ValPy[$limit] =~ s/\[/.get(/; # issue s359 $ValPy[$limit] =~ s/\]/)/; # issue s359 } # issue s359 if($autovivification && !defined $number_of_elements && (($ValClass[$limit] eq 'j' && $ValPy[$limit] =~ /readlines/) || ($ValClass[$limit] eq 'q' && $ValPy[$limit] =~ /\.split\(\)$/))) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '(', $ValPy[$limit], ')'); # issue s359 } else { gen_chunk($ValPy[$limit]); # that includes diamond operator <> and Aug 10,2020 } #$is_numeric{$ValPerl[$k]}='d'; # capture the type of variable. } gen_chunk(", $number_of_elements)") if(defined $number_of_elements); # issue 56, SNOOPYJC gen_chunk(')') if($add_right_paren); # issue 14 # handle autoflush return($#ValClass); }elsif($limit - $split == 2 && $ValClass[$split+1] eq '(' && $ValClass[$split+2] eq ')') { # issue paren # We have some sort of empty parens on the RHS. Generate the correct type of code depending on # what type of parens the user entered. $k = $split+1; if($ValPerl[$k] eq '{' || $ValClass[$start] eq 'h') { # {} = Empty hashref, issue s95: local %h = (); if($autovivification) { # SNOOPYJC $Pyf{Hash} = 1; gen_chunk('Hash', '()'); } else { gen_chunk("dict()"); } } else { # [] = Empty arrayref, () = Empty array if($autovivification) { # SNOOPYJC $Pyf{Array} = 1; gen_chunk('Array', '()'); } else { gen_chunk("[]"); } } gen_chunk(", $number_of_elements)") if(defined $number_of_elements); # issue 56, SNOOPYJC gen_chunk(')') if($add_right_paren); # issue 14 if($extra >= 0) { gen_extra($extra, $orig_limit); # issue 116 } return($#ValClass); }else{ # we have some kind of expression on the right side # issue 52 if( (substr($TokenStr,$split,2) eq '=(')>-1 && (index($TokenStr,')?',$split))>-1 ){ if( index($TokenStr,'?',$split) >-1 ){ # issue 52 # this is C-style conditional assigment x=(v>0)?y:z; -or- x=v>0?y:z; # Step one analyse the expression in brackets my $bracketed = 0; # issue 52 if($ValClass[$split+1] eq '(') { # issue 52 $to=matching_br($split+1); ($to<0) && return -255; $bracketed = 1; # issue 52 } else { # issue 52 $to = index($TokenStr,'?',$split+1)-1; # issue 52 } # Fist we need to generate then part of ternary if expression $colon_pos=index($TokenStr,':',$to+2); #say "to=$to, colon_pos=$colon_pos, bracketed=$bracketed"; if( $colon_pos>-1 ){ $k=expression($to+2,$colon_pos-1,0); return -255 if( $k<0 ); }else{ $k=expression($to+2,$#ValClass,0); return -255 if( $k<0 ); } gen_chunk(' if '); $k=$split+1; if($bracketed) { # issue 52 if( $to==$k+2){ $k++; gen_chunk($ValPy[$k]); # expression consist of one token $k+=3; # the next symbol after ')?' }else{ $k=expression($k+1,$to-1,0); # generate conditon without brackets return -255 if ($k<0); } } else { $k=expression($k,$to,0); # generate conditon return -255 if ($k<0); } if ($colon_pos>-1){ gen_chunk(' else '); $k=expression($colon_pos+1,$#ValPerl,0); # up to the very end return -255 if( $k<0 ); } gen_chunk(", $number_of_elements)") if(defined $number_of_elements); # issue 56, SNOOPYJC gen_chunk(')') if($add_right_paren); # issue 14 gen_statement(); # output if line if($extra >= 0) { gen_chunk($ValPy[$extra]); $k = next_lower_or_equal_precedent_token('=', $extra+1, $orig_limit); if($k < 0 || $ValClass[$k] ne '=') { $TrStatus=expression($extra+1, $orig_limit, 0); } else { $TrStatus=assignment($extra+1, $orig_limit); } } return $#ValClass; }else{ if($autovivification && ($ValClass[$start] =~ /[ah]/ || ($ValClass[$start] eq 's' && defined $ValType[$start] && $ValType[$start] =~ /[%@]s/))) { # issue s333 # issue s333 my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$ValClass[$start]}; my $cls = $ValClass[$start]; # issue s333 $cls = 'h' if $ValClass[$start] eq 's' && $ValType[$start] eq '%s'; # issue s333 $cls = 'a' if $ValClass[$start] eq 's' && $ValType[$start] eq '@s'; # issue s333 my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$cls}; # issue s333 $Pyf{$converter} = 1; gen_chunk("$converter", '('); $add_right_paren++; # issue bootstrap } elsif($autovivification && $ValClass[$split+1] eq '(' && $ValPerl[$split+1] ne '(' && !defined $number_of_elements) { # issue bootstrap: hashref or arrayref my $typ = 'a'; $typ = 'h' if($ValPerl[$split+1] eq '{'); my $end_br = matching_br($split+1); my $skip_converter = 0; if($end_br != -1 && $end_br < $limit) { # issue s213 if($ValClass[$end_br+1] eq 'A' || ($ValClass[$end_br+1] eq '(' && $ValPerl[$end_br+1] ne '(')) { # issue s213: we're just grabbing an element so don't need to autovivify $skip_converter = 1 } $extra = $end_br+1; $orig_limit = $limit; $limit = $end_br; } unless($skip_converter) { # issue s213 my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$typ}; $Pyf{$converter} = 1; gen_chunk("$converter", '('); $add_right_paren++; } } # If LHS is hash and this is a list expr, do the appropriate conversion if($ValClass[$start] eq 'h' && &Pythonizer::expr_type($split+1, $limit, $CurSub) =~ /^a/) { $Pyf{_list_to_hash} = 1; gen_chunk('_list_to_hash', '('); $add_right_paren++; } #if(defined $number_of_elements || $ValClass[$start] eq 'a') { # issue s308 #$k=expression($split+1,$limit,2); # process expression without brackets -- last param is 0, issue s308 #} else { # issue s308 if(is_list($split+1, $limit) && $ValClass[$limit] ne 'y') { # issue s308 $k=expression($split+1,$limit,2); # process expression without brackets -- last param is 0, issue s308 } else { $k=expression($split+1,$limit,0); # process expression without brackets -- last param is 0 } return -255 if( $k<0 ); gen_chunk(", $number_of_elements)") if(defined $number_of_elements); # issue 56, SNOOPYJC gen_chunk(')') while($add_right_paren--); # issue 14 } } # issue s151 }elsif( ($split=index($TokenStr,'~',$k))>-1 && $ValPerl[$split] ne '~') { # SNOOPYJC: Handle ~ operator }elsif( ($split=index($TokenStr,'p',$k))>-1) { # SNOOPYJC: Handle ~ operator, issue s151 $k=regex_and_translate($start,$k,$split,$limit); # issue 106 return $k+1; }elsif(index($TokenStr,'D')>-1) { # SNOOPYJC: Some sort of OO construct such as $fh->autoflush(1); or $obj->method(args) $k = expression($start,$#ValClass,0); # SNOOPYJC return -255 if( $k<0 ); # SNOOPYJC return $k+1; # SNOOPYJC }elsif($CurSub ne '__main__') { # issue 45, issue 41 ; # issue 45: could be a return from a sub - just ignore it and don't give a warning }elsif(scalar(@ValClass) == 1) { # SNOOPYJC: Simple declaration ; }else{ if($debug >= 1) { say STDERR "assignment - returns -255"; } return -255; } if($ValClass[0] eq 's' && $ValPerl[0] eq '$|') { # SNOOPYJC: Handle autoflush gen_statement(); gen_statement("$Perlscan::keyword_tr{STDOUT}.autoflush($ValPy[0])"); gen_statement("$Perlscan::keyword_tr{STDERR}.autoflush($ValPy[0])"); } if($extra >= 0) { gen_chunk($ValPy[$extra]); # ',' or whatever it is $k = next_lower_or_equal_precedent_token('=', $extra+1, $orig_limit); if($k < 0 || $ValClass[$k] ne '=') { $TrStatus=expression($extra+1, $orig_limit, 0); } else { $TrStatus=assignment($extra+1, $orig_limit); } } if($viv_me && $left_composite && ($_[0] eq 0 || ($_[0] eq 1 && $ValClass[0] eq 't'))) { # issue s198 # If we have an array (or hash) at the end of a list of items, then we use [item1, item2, *arr] = RHS, but this makes # arr a list even if the RHS is an Array. For a hash, our variable now contains a flattened list of keys and values # so we need to transform it into a dict (and then possibly to a Hash). if($left_composite eq 'h') { gen_statement(); gen_chunk("$viv_me = {$viv_me"."[$INDEX_TEMP]:".$viv_me."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$viv_me."),2)}"); } if($autovivification) { gen_statement(); my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$left_composite}; $Pyf{$converter} = 1; gen_chunk($viv_me, '=', $converter, '(', $viv_me, ')'); } } if(defined $left_extra_start) { # issue s198: handle any extra composite elements past the first starred one for($k = $left_extra_start; $k < $split; $k++) { my $typ = $ValClass[$k]; my $py = $ValPy[$k]; if($typ eq 'a' || $typ eq 'h' || $typ eq 's') { ; } elsif($typ eq 'G') { ($typ, $py) = &Perlscan::choose_glob_and_get_type($ValPerl[$k], $ValPy[$k]); # issue s198 } else { next; } gen_statement(); my $eov = end_of_variable($k); if($eov == $k) { gen_chunk($py); } else { expression($py, $eov, 0); } if($typ eq 's') { if(exists $VarType{$py} && exists $VarType{$py}{$CurSub}) { gen_chunk('=', init_val($VarType{$py}{$CurSub})); } else { gen_chunk('=', 'None'); } } elsif($autovivification) { my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$typ}; $Pyf{$converter} = 1; gen_chunk('=', $converter, '(', ')'); } else { gen_chunk('=', ($typ eq 'a' ? '[' : '{'), ($typ eq 'a' ? ']' : '}')); } $k = $eov; } } return($#ValClass); } # assignment sub handle_assign_eval # issue 42 # # handle $var = eval {...} or $var = eval(...) # arg1 = pointer to the eval # returns 1 if we should not generate any code for the assignment # { my $exp = shift; # pointer to the eval or x $was_block = gen_eval($exp, 1); my $continue = 0; # issue s329 $continue = 1 if $exp == $#ValClass && !defined $saved_eval_tokens; # issue s329 my $suffix = $eval_stack[-1]->{suffix}; # issue s13 pop @eval_stack unless $was_block; # issue s13 $result = "$EVAL_RESULT$.$suffix"; # issue s13 replace($exp, 's', $result, $result); if($exp != $#ValClass) { destroy($exp+1, $#ValClass-$exp); } if($was_block) { $eval_stack[-1]->{assignment} = package_tokens(); if($continue) { # issue s329 $eval_stack[-1]->{continue} = 1; # issue s329: Flag to say we need to continue tokenizing } # issue s329 } return $was_block; } # handle_assign_eval sub gen_eval # issue 42 { my $ep = shift; # pointer to the eval start in @ValClass my $need_result = shift; my $suffix = ''; # issue s13 if(exists $eval_suffix{$.}) { # issue s13 $suffix = $eval_suffix{$.}; # issue s13 $suffix = chr(ord($suffix)+1); # issue s13 $eval_suffix{$.} = $suffix; # issue s13 } else { # issue s13 $suffix = ''; # issue s13 $eval_suffix{$.} = '`'; # issue s13: next char is 'a' } # issue s13 say STDERR "gen_eval($ep, $need_result): =|$TokenStr|= suffix=$suffix" if($debug); if($need_result) { gen_statement("$EVAL_RESULT$.$suffix = None"); } gen_statement('try:'); # issue 42 push @eval_stack,{eval_nest => $Pythonizer::CurNest, lno => $., suffix=>$suffix}; # issue 42, issue s3 if(($ep < $#ValClass && $ValClass[$ep+1] eq '(' && $ValPerl[$ep+1] eq '(') || # we have (...) ($ep == $#ValClass && defined $line && $line =~ /eval;/)) { # we have $val = eval; -or just- eval; correct_nest(1, 1); if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = 1"); # issue s282 } # issue s282 gen_statement("$EVAL_ERROR = ''") if(exists $SpecialVarsUsed{'$@'}); # issue 42, issue bootstrap if($need_result) { gen_chunk("$EVAL_RESULT$.$suffix = "); } gen_chunk("subprocess.run(['perl','-e',"); if($ep == $#ValClass) { gen_chunk(q{"print +" + }, $DEFAULT_VAR); } else { insert($ep+2, '.', '.', ' + '); insert($ep+2, '"', '', qq{'print +'}); my $end_pos = matching_br($ep+1); $k = expression($ep+2, $end_pos-1, 0); } gen_chunk('],capture_output=True,text=True,check=True).stdout'); gen_statement(); correct_nest(-1, -1); if(exists $SpecialVarsUsed{'$@'}) { gen_statement('except Exception as _e:'); # issue 42 } else { gen_statement('except Exception:'); # issue 42 } correct_nest(1,1); # issue 42 output_line('traceback.print_exc()') if($traceback); # SNOOPYJC if(exists $SpecialVarsUsed{'$@'}) { $Pyf{"_exc"} = 1; # issue 42 gen_chunk("$EVAL_ERROR = ", '_exc', '(_e)'); # issue 42 gen_statement(); } else { gen_statement('pass'); } correct_nest(-1,-1); # issue 42 # issue s13 pop @eval_stack; # issue 42 return 0; } elsif($ep < $#ValClass && $ValClass[$ep+1] eq '(' && $ValPerl[$ep+1] eq '{') { # we have {...} my $end_pos = matching_br($ep+1); if($end_pos < 0) { $TrStatus = -1; } else { correct_nest(1,1); if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = 1"); # issue s282 } # issue s282 my $semi = next_matching_token(';', $ep+2, $end_pos); $end_pos = $semi if($semi >= 0); if($need_result) { insert($ep+2, '=', '=', '='); insert($ep+2, 's', '$' . "$EVAL_RESULT$.$suffix", "$EVAL_RESULT$.$suffix"); $end_pos += 2; $TrStatus = assignment($ep+2, $end_pos-1); } else { $TrStatus = expression($ep+2, $end_pos-1, 0); } gen_statement(); correct_nest(-1,-1); } } elsif($ep < $#ValClass) { my $end_pos = $#ValClass; correct_nest(1,1); if(exists $SpecialVarsUsed{'$^S'}) { # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = 1"); # issue s282 } # issue s282 my $semi = next_matching_token(';', $ep+1, $end_pos); $end_pos = $semi-1 if($semi >= 0); if($need_result) { insert($ep+1, '=', '=', '='); insert($ep+1, 's', '$' . "$EVAL_RESULT$.$suffix", "$EVAL_RESULT$.$suffix"); $end_pos += 2; $TrStatus = assignment($ep+1, $end_pos); } else { $TrStatus = expression($ep+1, $end_pos, 0); } gen_statement(); correct_nest(-1,-1); } elsif(exists $SpecialVarsUsed{'$^S'}) { # issue s282 correct_nest(1,1); # issue s282 gen_statement("$EXCEPTIONS_BEING_CAUGHT = 1"); # issue s282 $Perlscan::PREV_HAD_COLON = 1; # issue s282: Fake it out correct_nest(-1,-1); # issue s282 } return 1; } sub package_tokens # issue 42 # Package up all the code in a cute little ref so we can generate it later { if($debug >= 3) { my (undef, $fn, $ln) = caller(0); say STDERR "package_tokens( =|$TokenStr|= ) ValPy = @ValPy (called from $fn:$ln)"; } my @_ValClass = @ValClass; my @_ValPerl = @ValPerl; my @_ValPy = @ValPy; my @_ValCom = @ValCom; my @_ValType = @ValType; return {class=>\@_ValClass, perl=>\@_ValPerl, py=>\@_ValPy, com=>\@_ValCom, type=>\@_ValType}; } sub unpackage_tokens # issue 42 # Restore the code from the cute little ref we created with package_tokens { my $coderef = shift; @ValClass = @{$coderef->{class}}; @ValPerl = @{$coderef->{perl}}; @ValPy = @{$coderef->{py}}; @ValCom = @{$coderef->{com}}; @ValType = @{$coderef->{type}}; $TokenStr=join('',@ValClass); if($debug >= 3) { my (undef, $fn, $ln) = caller(0); say STDERR "unpackage_tokens() = =|$TokenStr|= ValPy = @ValPy (called from $fn:$ln)" } } sub p_destroy # Like destroy but for packaged code { my ($package,$from,$howmany) = @_; splice(@{$package->{class}},$from,$howmany); splice(@{$package->{perl}},$from,$howmany); splice(@{$package->{py}},$from,$howmany); if(scalar(@{$package->{type}}) >= $from+$howmany) { splice(@{$package->{type}},$from,$howmany); } } sub p_replace # Like replace but for packaged code { my ($package,$pos,$class,$perl,$py) = @_; $package->{class}->[$pos] = $class; $package->{perl}->[$pos] = $perl; $package->{py}->[$pos] = $py; $package->{type}->[$pos] = ''; } sub p_insert # Like insert but for packaged code { my ($package,$pos,$class,$perl,$py) = @_; if($pos == scalar @{$package->{class}}) { p_append($package,$class,$perl,$py); return; } splice(@{$package->{class}},$pos,0,$class); splice(@{$package->{perl}},$pos,0,$perl); splice(@{$package->{py}},$pos,0,$py); if($pos <= $#{$package->{type}}) { splice(@{$package->{type}},$pos,0,''); } else { $package->{type}->[$pos] = ''; } } sub p_append # Like append but for packaged code { my ($package,$class,$perl,$py) = @_; $package->{class}->[scalar(@{$package->{class}})] = $class; $package->{perl}->[scalar(@{$package->{perl}})] = $perl; $package->{py}->[scalar(@{$package->{py}})] = $py; $package->{type}->[scalar(@{$package->{py}})] = ''; # We use the length of 'py' as not all elements have a type field } sub regex_and_translate # # process very tricky regex and tranlate function # { my($start,$k,$split,$limit)=@_; # issue 106 # $start and $k are the same and point to the start of the expression # $split points to the '=~' # $limit points to the end say STDERR "regex_and_translate($start,$k,$split,$limit)" if($debug >= 3); # SNOOPYJC # SNOOPYJC: And to make it even more tricky, we have 5 different cases to handle for each type: # 1. $var =~ s/a/b/ # 2. $cnt = $var =~ s/a/b/ -or- $cnt = ($var =~ s/a/b/) - here $start points to the $var # 3. $new = $var =~ s/a/b/r # 4. ($new = $old) =~ s/a/b/ Here only $new is changed, not $old # 5. _assign_global('pkg', 'var', $old) =~ s/a/b/ # my $eq; # SNOOPYJC my $eq_ok = ($start == 0 || ($start == 1 && $ValClass[0] eq 't')); # When it's ok to use '=' instead of ':=' my $cs = &Perlscan::cur_sub(); # issue s185 if( $split+1 <= $#ValClass && $ValClass[$split+1] eq 'f' && $ValPerl[$split+1] eq 'tr'){ # SNOOPYJC # tr is a special case -- this is not regular expression my $flags = ''; my $args = tr_flags_to_args($ValPy[$split+1]); if($ValPy[$split+1] =~ /,flags=([a-z]+)/) { $flags = $1; $ValPy[$split+1] =~ s/,flags=[a-z]+//; } if( $split-$k==1 && ($flags =~ /r/ || $eq_ok)){ # SNOOPYJC: Case 3 say STDERR "tr case 3" if($debug >= 5); # SNOOPYJC gen_chunk($ValPy[$split-1],'=',$ValPy[$split-1],'.translate(',$ValPy[$split-1],$ValPy[$split+1],')'); # a=a.trasnlate(a) if($flags eq 'r') { gen_chunk($ValPy[$split-1],'.translate(',$ValPy[$split+1],')'); # SNOOPYJC a.translate(str.maketrans(..,..)) } elsif($flags eq '' && $eq_ok) { gen_chunk($ValPy[$split-1],'=',$ValPy[$split-1],'.translate(',$ValPy[$split+1],')'); # SNOOPYJC a=a.translate(str.maketrans(..,..)) } elsif($flags =~ /r/) { # SNOOPYJC: r and other flags $Pyf{_translate} = 1; gen_chunk('_translate', '(', $args, ', var=', $ValPy[$split-1], ')'); } elsif($eq_ok) { # SNOOPYJC: other flags without r $Pyf{_translate} = 1; gen_chunk($ValPy[$split-1], '=', '_translate', '(', $args, ', var=', $ValPy[$split-1], ')'); } else { # SNOOPYJC: other flags without r $Pyf{_translate} = 1; gen_chunk('(', $ValPy[$split-1], ':=', '_translate', '(', $args, ', var=', $ValPy[$split-1], '))'); } }elsif(($start != 1 || $ValClass[0] ne '(') && ( # issue s299 ($eq = next_same_level_token('=', $start, $split-1)) != -1 || (!$eq_ok && end_of_variable($start)+1 == $split))) { # Case 2 say STDERR "tr case 2" if($debug >= 5); $Pyf{_translate_and_count} = 1; #gen_chunk('((', $DEFAULT_VAR, ':=', '(', $SUBSCRIPT_TEMP, '_translate_and_count(str', $py_name, ',', $DEFAULT_VAR, '))[0])', ',', $SUBSCRIPT_TEMP, ')[1][1]'); if($eq != -1) { if($eq_ok) { $k=expression($start, $eq-1, 8); # issue s299: Don't use get return -255 if( $k<0 ); gen_chunk('='); } else { gen_chunk('('); $k=expression($start, $eq-1, 8); # issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); } } else { gen_chunk('('); $eq = $start-1; } my $append = ''; # issue s184 if(tr_count_only($args)) { gen_chunk('_translate_and_count', '(', $args, ', var='); $k=expression($eq+1, $split-1, 0); gen_chunk(')[1]'); } else { gen_chunk('(('); my $eq2; # issue test coverage my ($s, $e); # issue s184 if($ValClass[$eq+1] eq 'f' && $ValPy[$eq+1] eq $CONVERTER_MAP{S}) { # issue s8 # We could have inserted a _str($v), so leave that out! # issue s184 $k=expression($eq+3, $split-2, 0); $s = $eq+3; $e = $split-2; # issue s184 } elsif($ValClass[$eq+1] eq '(' && ($eq2 = next_same_level_token('=', $eq+2, $split-2)) != -1) { # issue test coverage: Case 4 within Case 2 # issue s184 $k=expression($eq+2, $eq2-1, 0); # issue test coverage: new $s = $eq+2; $e = $eq2-1; # issue s184 } else { # issue s184 $k=expression($eq+1, $split-1, 0); $s = $eq+1; $e = $split-1; # issue s184 } # issue s359 if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(.*)\[(\d+)\]$/) { # issue s184: This is an argument to a sub which is an out parameter if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(\w+)(?:(?:\.get\()|\[)(\d+)/) { # issue s184: This is an argument to a sub which is an out parameter, issue s359 my $var = $1; # issue s184 my $subscript = $2; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 $append = ')'; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $append = ", shifts=$als)" if($als); # issue s184 # issue s241 } elsif($s == $e && $ValType[$s] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($s == $e && $ValType[$s] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub, issue s241 # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$s], ':='); # issue s185 $append = '))'; # issue s185 } else { $k = expression($s, $e, 0); # issue s184 return -255 if( $k<0 ); gen_chunk(':='); } gen_chunk('(', $SUBSCRIPT_TEMP, ':=', '_translate_and_count', '(', $args, ', var='); $k=expression($eq+1, $split-1, 0); gen_chunk('))[0])'.$append, ',', $SUBSCRIPT_TEMP, ')[1][1]'); } gen_chunk(')') if(!$eq_ok); }elsif($ValClass[$start] eq '(' && ($eq = next_same_level_token('=', $start+1, $split-2)) != -1) { # Case 4 say STDERR "tr case 4" if($debug >= 5); my $close = matching_br($start); if($flags =~ /r/) { gen_chunk('(('); $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); $k=expression($eq+1, $close-1, 0); # old return -255 if( $k<0 ); gen_chunk('), '); } else { if($eq_ok) { $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk('='); } else { gen_chunk('('); $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); } } if(!($flags eq '' || $flags eq 'r')) { # issue bootstrap $Pyf{_translate} = 1; gen_chunk('_translate', '(', $args, ', var='); } $k=expression($eq+1, $close-1, 0); # old return -255 if( $k<0 ); if($flags eq '' || $flags eq 'r') { gen_chunk('.translate('); gen_chunk($ValPy[$split+1]); } gen_chunk(')'); gen_chunk(')') if(!$eq_ok || $flags =~ /r/); }elsif($ValClass[$start] eq 'f' && ($ValPy[$start] eq '_assign_global' || ($ValPy[$start] eq $CONVERTER_MAP{S} && $ValPy[$start+2] eq '_assign_global'))) { # Case 5, issue s8 # 5. _assign_global('pkg', 'var', $old) =~ s/a/b/ #my $pkg = unquote_string($ValPy[$start+2]); #my $var = unquote_string($ValPy[$start+4]); say STDERR "tr case 5" if($debug >= 5); my $close = matching_br($start+1); my $old0 = $start+6; my $old1 = $close-1; if($flags !~ /r/) { if($ValPy[$start] eq $CONVERTER_MAP{S}) { # issue s8 for(my $i = $start+2; $i < $old0+2; $i++) { # Spit out "_assign_global('pack', 'var'," gen_chunk($ValPy[$i]); } gen_chunk($ValPy[$start], '('); $old0 += 2; $old1--; } else { for(my $i = $start; $i < $old0; $i++) { # Spit out "_assign_global('pack', 'var'," gen_chunk($ValPy[$i]); } } } if(!($flags eq '' || $flags eq 'r')) { # issue bootstrap $Pyf{_translate} = 1; gen_chunk('_translate', '(', $args, ', var='); } $k=expression($old0,$old1,0); return -255 if( $k<0 ); gen_chunk(')') if $ValPy[$start] eq $CONVERTER_MAP{S}; if($flags eq '' || $flags eq 'r') { gen_chunk('.translate('); gen_chunk($ValPy[$split+1]); } gen_chunk(')'); gen_chunk(')') if($flags !~ /r/); }else{ # Case 1 say STDERR "tr case 1" if($debug >= 5); my $append = ''; # issue s184 if($flags !~ /r/) { my ($s, $e); # issue s184 if($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S}) { # issue s8 # We could have inserted a _str($v), so leave that out! # issue s184 $k=expression($start+2,$split-2,0); # can be array index or something more problemtic ;-) $s = $start+2; $e = $split-2; # issue s184 } else { # issue s184 $k=expression($start,$split-1,0); # can be array index or something more problemtic ;-) $s = $start; $e = $split-1; # issue s184 } # issue s359 if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(.*)\[(\d+)\]$/) { # issue s184: This is an argument to a sub which is an out parameter if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(\w+)(?:(?:\.get\()|\[)(\d+)/) { # issue s184: This is an argument to a sub which is an out parameter, issue s359 my $var = $1; # issue s184 my $subscript = $2; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 $append = ')'; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $append = ", shifts=$als)" if($als); # issue s184 # issue s241} elsif($s == $e && $ValType[$s] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($s == $e && $ValType[$s] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$s], ':='); # issue s185 $append = '))'; # issue s185 } else { # issue s184 # issue s359 $k = expression($s, $e, 0); # issue s184 $k = expression($s, $e, 8); # issue s184, issue s359: don't use .get return -255 if( $k<0 ); gen_chunk('='); } } if(!($flags eq '' || $flags eq 'r')) { # issue bootstrap $Pyf{_translate} = 1; gen_chunk('_translate', '(', $args, ', var='); } $k=expression($start,$split-1,0); # replicate the left part of the assignment if($flags eq '' || $flags eq 'r') { gen_chunk('.translate('); # SNOOPYJC $k=expression($start,$split-1,0); # replicate the left part of the assignment gen_chunk($ValPy[$split+1]); } gen_chunk(')'); gen_chunk($append) if($append); } # next token $k=$split+1; # issue s151 }elsif( ($split=index($TokenStr,'~',$k))>-1 ){ }elsif( ($split=index($TokenStr,'p',$k))>-1 ){ # issue s151 #regular expression $string =~ /cat/ or $string =~m/cat/ # re.search(r'cat', string): ... return -255 if($split+1 > $#ValClass); # SNOOPYJC: Don't get stuck on ~ at end! if($ValClass[$split+1] eq 'q') { # match only; There is no variable to assign results gen_chunk('not') if($ValPerl[$split] eq '!~'); # issue 112 if( substr($ValPy[$split+1],0,1) eq '.' ){ # e.g. .find(...) -or- .replace(...) $k=expression($start,$split-1,0); # generate left side of the regular expression return -255 if( $k<0 ); gen_chunk($ValPy[$split+1],')'); # add dot part generated by scanner }else{ my $g_flag = 0; # SNOOPYJC $g_flag = 1 if($ValPy[$split+1] =~ /\bre\.G/); if($g_flag) { $ValPy[$split+1] =~ s/,re\.G\|/,/; $ValPy[$split+1] =~ s/.re\.G//; if($ValPy[$split+1] =~ /\($DEFAULT_MATCH:=re\.search/) { $ValPy[$split+1] =~ s/\($DEFAULT_MATCH:=re\.search/[$DEFAULT_MATCH\[0] for $DEFAULT_MATCH in (re.finditer/; } else { $ValPy[$split+1] =~ s/\(re\.search/(re.findall/; $g_flag = 0; } } $two_close_parens = 1; if($eq_ok && $ValPy[$split+1] =~ /^\($DEFAULT_MATCH:=/) { # SNOOPYJC $ValPy[$split+1] =~ s/^\($DEFAULT_MATCH:=/$DEFAULT_MATCH = /; $two_close_parens = 0; } if(substr($ValPy[$start], 0, 1) eq '*') { # issue s308: We splatted the lhs $ValPy[$start] = substr($ValPy[$start], 1); # issue s308 gen_chunk('*'); # issue s308: move the splat here } # issue s308 gen_chunk($ValPy[$split+1]); $k=expression($start,$split-1,0); # generate left side of the regular expression, it can be array index or something even more problemtic ;-) return -255 if( $k<0 ); if (index($ValPy[$split+1],':=')>-1){ # issue 57: Generate proper code for when we're in list context or scalar context my $context = list_or_scalar_context($start, $split+1); # issue 118 say STDERR "context of regex = $context" if($debug >= 5); if($autovivification && $context == 1) { # issue s359: Array $Pyf{Array} = 1; # issue s359 gen_chunk('),', 'Array', "(${DEFAULT_MATCH}.groups()) if $DEFAULT_MATCH else", 'Array', '())[1]'); # issue s359 } elsif($context == 1) { # list gen_chunk("),${DEFAULT_MATCH}.groups() if $DEFAULT_MATCH else [])[1]"); # issue 57, 32 } elsif($context == 0) { gen_chunk("),_pb($DEFAULT_MATCH))[1]"); # issue 57, 32, issue s124 } else { # issue 57 gen_chunk('))'); # close function bracket and expression } }else{ gen_chunk(')'); # close function bracket and expression gen_chunk(')') if($two_close_parens); } gen_chunk(']') if($g_flag); } $k=$split+1; }elsif( $ValClass[$split+1] eq 'f' && $ValPerl[$split+1] eq 're' ){ # s/.../.../FLAGS # this is case of substirution # issue 11: Handle the re.G flag which doesn't actually exist my $flags = process_re_flags($split+1); if( $split-$k==1 && ($flags =~ /replace/ || $eq_ok)){ # SNOOPYJC say STDERR "sub case 3" if($debug >= 5); if($flags =~ /replace/) { $flags =~ s/replace=False,//; } else { gen_chunk($ValPy[$split-1]); # a if($eq_ok) { # SNOOPYJC gen_chunk('='); # a= } else { gen_chunk(':='); # a= } } if( substr($ValPy[$split+1],0,1) eq '.' ){ if(is_string($split-1)) { # issue s116 gen_chunk($ValPy[$split-1].$ValPy[$split+1]); # a=a.replace(string1,string2,1) } else { # issue s116 gen_chunk('_str(', $ValPy[$split-1], ')', $ValPy[$split+1]); # a=a.replace(string1,string2,1) } }else{ # issue 11 gen_chunk("$ValPy[$split+1]$ValPy[$split-1])"); # a=re.sub(rexex,replacement,variable) if(is_string($split-1)) { # issue s116 gen_chunk("$ValPy[$split+1]$ValPy[$split-1],$flags)"); # a=re.sub(rexex,replacement,variable,count=N) # issue 11 } else { gen_chunk("$ValPy[$split+1]_str($ValPy[$split-1]),$flags)"); # a=re.sub(rexex,replacement,_str(variable),count=N) # issue 11 } } }elsif(($start != 1 || $ValClass[0] ne '(') && ( # issue s299: Don't need to use _substitute_and_count if we don't need the count ($eq = next_same_level_token('=', $start, $split-1)) != -1 || (!$eq_ok && end_of_variable($start)+1 == $split))) { # Case 2 # 2. $cnt = $var =~ s/a/b/ say STDERR "sub case 2" if($debug >= 5); $Pyf{_substitute_and_count} = 1; my $sac = '_substitute_and_count'; $sac = "$PERLLIB.substitute_and_count" if($import_perllib); if( substr($ValPy[$split+1],0,1) eq '.' ){ # issue s344: .replace(x,y,1) $ValPy[$split+1] =~ s/\.replace/re.sub/; # issue s344: Can't use the ez method in this case $ValPy[$split+1] =~ s/,1\)\Z/,/; # issue s344 } # issue s344 $ValPy[$split+1] =~ s/^re\.sub/$sac/; #gen_chunk('((', $DEFAULT_VAR, ':=', '(', $SUBSCRIPT_TEMP,':=', $py_name, ')[0])', ',', $SUBSCRIPT_TEMP, ')[1][1]'); if($eq != -1) { if($eq_ok) { $k=expression($start, $eq-1, 8); # issue s299: Don't use get return -255 if( $k<0 ); gen_chunk('='); } else { gen_chunk('('); $k=expression($start, $eq-1, 8); # issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); } } else { gen_chunk('('); $eq = $start-1; } gen_chunk('(('); my $append = ''; if($flags !~ /replace/) { my ($s, $e); # issue s184 if($ValClass[$eq+1] eq 'f' && $ValPy[$eq+1] eq $CONVERTER_MAP{S}) { # We could have inserted a _str($v), so leave that out! # issue s184 $k=expression($eq+3,$split-2,0); $s = $eq+3; $e = $split-2; # issue s184 } else { # issue s184 $k=expression($eq+1,$split-1,0); # can be array index or something more problemtic ;-) $s = $eq+1; $e = $split-1; # issue s184 } # issue s359 if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(.*)\[(\d+)\]$/) { # issue s184: This is an argument to a sub which is an out parameter if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(\w+)(?:(?:\.get\()|\[)(\d+)/) { # issue s184: This is an argument to a sub which is an out parameter, issue s359 my $var = $1; # issue s184 my $subscript = $2; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 $append = ')'; # issue s184 # issue s241$als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $append = ", shifts=$als)" if($als); # issue s184 # issue s241 } elsif($s == $e && $ValType[$s] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($s == $e && $ValType[$s] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub, issue s241 # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$s], ':='); # issue s185 $append = '))'; # issue s185 } else { $k = expression($s, $e, 0); return -255 if( $k<0 ); gen_chunk(':='); } } gen_chunk('(', $SUBSCRIPT_TEMP, ':=', $ValPy[$split+1], $flags, ',var='); $k=expression($eq+1, $split-1, 0); # issue s184 gen_chunk('))[0])', ',', $SUBSCRIPT_TEMP, ')[1][1]'); gen_chunk('))[0])'.$append, ',', $SUBSCRIPT_TEMP, ')[1][1]'); # issue s184 gen_chunk(')') if(!$eq_ok); }elsif($ValClass[$start] eq '(' && ($eq = next_same_level_token('=', $start+1, $split-2)) != -1) { # Case 4 # 4. ($new = $old) =~ s/a/b/ Here only $new is changed, not $old say STDERR "sub case 4" if($debug >= 5); my $close = matching_br($start); if($flags =~ /replace/) { $flags =~ s/replace=False,//; gen_chunk('(('); $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); $k=expression($eq+1, $close-1, 0); # old return -255 if( $k<0 ); gen_chunk('), '); $eq_ok = 0; # Always gen the ')' } else { if($eq_ok) { $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk('='); } else { gen_chunk('('); $k=expression($start+1, $eq-1, 8); # new, issue s299: Don't use get return -255 if( $k<0 ); gen_chunk(':='); } } if( substr($ValPy[$split+1],0,1) eq '.' ){ # issue s344: .replace(x,y,1) $k=expression($eq+1, $close-1, 0); # issue s344: old return -255 if( $k<0 ); # issue s344 gen_chunk($ValPy[$split+1]); # issue s344 } else { gen_chunk($ValPy[$split+1]); $k=expression($eq+1, $close-1, 0); # old return -255 if( $k<0 ); gen_chunk(',', $flags) if($flags); gen_chunk(')'); } gen_chunk(')') if(!$eq_ok); }elsif($ValClass[$start] eq 'f' && ($ValPy[$start] eq '_assign_global' || ($ValPy[$start] eq $CONVERTER_MAP{S} && $ValPy[$start+2] eq '_assign_global'))) { # Case 5 # 5. _assign_global('pkg', 'var', $old) =~ s/a/b/ say STDERR "sub case 5" if($debug >= 5); #my $pkg = unquote_string($ValPy[$start+2]); #my $var = unquote_string($ValPy[$start+4]); my $close = matching_br($start+1); my $old0 = $start+6; my $old1 = $close-1; my $replace = 1; if($flags =~ /replace/) { $flags =~ s/replace=False,//; $replace = 0; gen_chunk('('); # issue test coverage } if($ValPy[$start] eq $CONVERTER_MAP{S}) { # issue s8, issue test coverage for(my $i = $start+2; $i < $old0+2; $i++) { # Spit out the "_assign_global('pkg', 'var'", gen_chunk($ValPy[$i]); } $old0 += 2; $old1--; } else { for(my $i = $start; $i < $old0; $i++) { # Spit out the "_assign_global('pkg', 'var'", gen_chunk($ValPy[$i]); } } if($replace) { # issue test coverage gen_chunk($ValPy[$split+1]); } gen_chunk($ValPy[$start], '(') if $ValPy[$start] eq $CONVERTER_MAP{S}; $k=expression($old0,$old1,0); return -255 if( $k<0 ); gen_chunk(')') if $ValPy[$start] eq $CONVERTER_MAP{S}; if($replace) { gen_chunk(',', $flags) if($flags); } else { gen_chunk(')', ','); gen_chunk($ValPy[$split+1]); gen_chunk($ValPy[$start], '(') if $ValPy[$start] eq $CONVERTER_MAP{S}; expression($old0,$old1,0); gen_chunk(')') if $ValPy[$start] eq $CONVERTER_MAP{S}; gen_chunk(',', $flags) if($flags); } gen_chunk(')'); gen_chunk(')'); }else{ say STDERR "sub case 1" if($debug >= 5); my $append = ''; # issue s184 if($flags =~ /replace/) { $flags =~ s/replace=False,//; } else { my ($s, $e); # issue s184 if($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S}) { # SNOOPYJC # We could have inserted a _str($v), so leave that out! # issue s184 $k=expression($start+2,$split-2,0); $s = $start+2; $e = $split-2; # issue s184 } else { # issue s184 $k=expression($start,$split-1,0); # can be array index or something more problemtic ;-) $s = $start; $e = $split-1; # issue s184 } # issue s359 if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(.*)\[(\d+)\]$/) { # issue s184: This is an argument to a sub which is an out parameter if($s == $e && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^(\w+)(?:(?:\.get\()|\[)(\d+)/) { # issue s184: This is an argument to a sub which is an out parameter, issue s359 my $var = $1; # issue s184 my $subscript = $2; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 $append = ')'; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $append = ", shifts=$als)" if($als); # issue s184 # issue s241 } elsif($s == $e && $ValType[$s] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($s == $e && $ValType[$s] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}) { # issue s185: This is a copy of a reference argument to a sub, issue s241 # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$s]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$s]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$s], ':='); # issue s185 $append = '))'; # issue s185 } else { # issue s184 $k=expression($s, $e, 8); # issue s184, issue s299: 8 = Don't use get return -255 if( $k<0 ); if($eq_ok) { # SNOOPYJC gen_chunk('='); # a= } else { gen_chunk(':='); # a= } } } if( substr($ValPy[$split+1],0,1) eq '.' ){ $k=expression($start,$split-1,0); # replicate the left part of the assignment return -255 if( $k<0 ); gen_chunk($ValPy[$split+1]); }else{ gen_chunk($ValPy[$split+1]); # issue 11 $k=expression($start,$split-1,0); # replicate the left part of the assignment return -255 if( $k<0 ); # issue 11 gen_chunk(')'); gen_chunk(',', $flags) if($flags); # issue 11 gen_chunk(')'); } gen_chunk($append) if($append); # issue s184 } # next token $k=$split+1; }else{ # issue 106 # issue s151 my $end_pos = next_lower_or_equal_precedent_token('~', $split+2, $limit)-1; my $end_pos = next_lower_or_equal_precedent_token('p', $split+2, $limit)-1; # issue s151 my $need_parens = ($end_pos > 0); # issue s165: perl =~ is higher precedence than python 'in' so we may need parens here #say STDERR "end_pos=$end_pos"; $end_pos = $limit if($end_pos < 0); # issue bootstrap: for "$a =~ $b", $b could be a qr regex, so check for that, unless it's a string token # code we generate in that case: # bool(re.search(pat, str)) if isinstance(pat, re.Pattern) else pat in str if((exists $SpecialVarsUsed{qr} || !$implicit_global_my) && $ValClass[$split+1] ne '"') { # issue bootstrap my $pat_s = $split+1; my $pat_e = $end_pos; my $str_s = $start; my $str_e = $split-1; if($ValClass[$pat_s] eq 'f' && $ValPy[$pat_s] eq $CONVERTER_MAP{S}) { # _str(...) $pat_s += 2; $pat_e = matching_br($pat_s-1)-1; } $need_parens = 0 if($ValPerl[$split] eq '!~'); # issue s165 gen_chunk('not', '(') if($ValPerl[$split] eq '!~'); # issue 112 gen_chunk('(') if $need_parens; # issue s165 # issue s338 gen_chunk('bool', '(', 're.search', '('); gen_chunk('bool', '(', $DEFAULT_MATCH, ':=', 're.search', '('); # issue s338 $k=expression($pat_s,$pat_e,0); # pattern w/o any converter return -255 if( $k<0 ); gen_chunk(','); $k=expression($str_s,$str_e,0); return -255 if( $k<0 ); gen_chunk('))', 'if', 'isinstance', '('); $k=expression($pat_s,$pat_e,0); gen_chunk(',', 're.Pattern', ')', 'else'); $k=expression($split+1, $end_pos, 0); # pattern, including any converter return -255 if( $k<0 ); gen_chunk('in'); $k=expression($str_s,$str_e,0); gen_chunk(')') if $need_parens; # issue s165 gen_chunk(')') if($ValPerl[$split] eq '!~'); } else { gen_chunk('(') if $need_parens; # issue s165 $k=expression($split+1, $end_pos, 0); # pattern return -255 if( $k<0 ); gen_chunk('not') if($ValPerl[$split] eq '!~'); # issue 112 gen_chunk('in'); $k=expression($start,$split-1,0); # string return -255 if( $k<0 ); gen_chunk(')') if $need_parens; # issue s165 } $k = $end_pos; # issue 106 }else{ # issue 106 return -255; } } return $k+1; } $force_list_context = 0; # issue s249 sub list_or_scalar_context # For a regex, or qx / `...`, figure out if this is in list (1) or scalar (0) context or unknown (-1) # Arg1: start of expression # Arg2: position of the q or x { my $start = shift; my $pos = shift; return 1 if $force_list_context; # issue s249: See &Perlscan::handle_expr_in_string return 0 if $pos != 0 && $ValClass[$pos-1] eq ':' && $ValPy[$pos-1] eq 'if'; # issue s315: Scalar in 'if' portion of ? : my $at = arg_type_from_pos($start); if(defined $at) { return 1 if($at eq 'a'); # issue s118 return 0 if($at =~ /[sIFNmS]/); return 0 if($at =~ /[sIFNmS]/); # issue s118: add 'S' } return 1 if(in_sub_call($start)); # issue bootstrap: handle ($var =~ /pat/)[0] as being in list context - used in sub lcp if($pos+2 <= $#ValClass && $ValClass[$pos+1] eq ')' && $ValPerl[$pos+1] eq ')' && $ValClass[$pos+2] eq '(' && $ValPerl[$pos+2] eq '[') { return 1; } #my $eq = next_same_level_token('=', 0, $start); my $eq = index($TokenStr, '='); # Need to find the '=' even if it's inside an 'if' stmt if($eq < 0) { # issue 118 # foreach $var (...) - if the q or x is in the ..., then it's in list context - but here the ( ) are removed! if($ValClass[0] eq 'c' && $ValPy[0] eq 'for') { return 1; } } if($pos < $eq) { # issue s315 return 0 if($ValClass[0] eq 'c' && ($ValPerl[0] eq 'if' || $ValPerl[0] eq 'unless')); # issue s315 return 0 if($ValClass[0] eq 'C' && $ValPerl[0] eq 'elsif'); # issue s315 } # issue s315 return -1 if($eq <= 0); return 1 if($ValClass[$eq-1] =~ /[ah]/ || ($ValClass[$eq-1] eq ')' && $ValPerl[$eq-1] eq ')')); # Array, Hash or list my $sv = start_of_var($eq-1); return 0 if($ValClass[$sv] eq 's'); return -1; } sub void_context # issue s241 # See if this sub call is in void context. This usually means that it's first on the line, # but it can also be in one set of parens if it has out parameters, but there can't be anything # before the parens. { my $sub_pos = shift; return 1 if $sub_pos == 0; return 1 if $sub_pos == 1 && $ValClass[0] eq '('; return 0; } sub inherited_wantarray # issue s241 # See if this sub call has it's wantarray inherited from it's parent sub # Also return 1 if this sub call is in a 'return' statement from a sub that also has wantarray { my $sub_pos = shift; my $cs = &Perlscan::cur_sub(); # issue s185 # issue s241 return 1 if(exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{wantarray_inherited_from} && # issue s241 $SubAttributes{$cs}{wantarray_inherited_from} eq $ValPy[$sub_pos]); return 1 if(defined get_sub_attribute($cs, 'wantarray_inherited_from') && get_sub_attribute($cs, 'wantarray_inherited_from') eq $ValPy[$sub_pos]); # issue s241 return 1 if(defined get_sub_attribute($cs, 'wantarray') && $sub_pos != 0 && $ValClass[$sub_pos-1] eq 'k' && $ValPerl[$sub_pos-1] eq 'return' && defined get_sub_attribute_at($sub_pos, 'wantarray')); if($sub_pos != 0 && $ValClass[$sub_pos-1] eq 'D') { $cs = '->' . $cs; # issue s241 return 1 if(exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{wantarray_inherited_from} && # issue s241 $SubAttributes{$cs}{wantarray_inherited_from} eq $ValPy[$sub_pos]); return 1 if(defined get_sub_attribute($cs, 'wantarray_inherited_from') && get_sub_attribute($cs, 'wantarray_inherited_from') eq $ValPy[$sub_pos]); # issue s241 my $sov = start_of_var($sub_pos-2); # issue s241 return 1 if(defined get_sub_attribute($cs, 'wantarray') && $sov-1 >= 0 && $ValClass[$sov-1] eq 'k' && $ValPerl[$sov-1] eq 'return' && defined get_sub_attribute_at($sub_pos, 'wantarray')); # issue s241 } return 0; } # # Extration of assignment statement from conditions and other places where Python prohibits them # Added Nov 11, 2019 # # SNOOPYJC: allow 2nd arg which means to leave lists intact sub pre_assign { my $begin = $_[0]; # issue s148 my $assign_start=$_[1]; my $leave_lists=(scalar(@_) >= 3 ? 1 : 0); # issue ddts my $assign_end=matching_br($assign_start); $assign_end=(scalar(@_) >= 4 ? $_[3] : $assign_end); # issue s148 if($debug >= 3) { no warnings 'uninitialized'; # issue s148 say STDERR "pre_assign($begin, $assign_start, $_[1], $_[2]), assign_end=$assign_end, =|$TokenStr|= @ValPerl\n" } my $adjust = 0; # issue s148 # issue s148 $begin = $assign_start-1; #($assign_end<0) && return -255; ($assign_end<0) && return $adjust; # issue s148 if($ValClass[$assign_start+1] =~ /[n!]/) { # issue 58 - skip any "not" clause, issue 93 $assign_start++; # issue s41 # issue s41 if($ValClass[$assign_start+2] eq '(') { # issue s41 $assign_start += 2; # issue s41 $assign_end = matching_br($assign_start); # issue s41: sample: c(n(s,s)=((fs)y(d,d))) # ^ ^ # issue s41 } if($ValClass[$assign_start+1] eq '(' && matching_br($assign_start+1) == $assign_end-1) { # Handle this case only: c(n(t(s,s,s)=((fs)y(d,d,d)))) # Before: ^assign_start ^assign_end # After: ^assign_start ^assign_end $assign_start++; $assign_end--; } } #say STDERR "ValPerl[$begin] = $ValPerl[$begin]"; if(($ValPerl[$begin] eq 'chop' || $ValPerl[$begin] eq 'chomp') && $begin == 2) { # issue ddts $begin = 0; } if($ValPerl[$begin] =~ /^(?:for|foreach|while|until)$/) { # Issue 103: Looping construct # We don't want to pull the expression out of the loop in case it needs to run multiple times # e.g. in issue 103, it called the "each" iterator. return 0 if(fixup_complex_assignment_in_control(2, $#ValClass-1, $leave_lists) != -1); # issue 103, issue ddts, issue s148 } my $from=index($TokenStr,'=',$assign_start+2); # issue 58 if($ValPy[$from] eq ':=') { # issue 58: generate a regular '=', not a walrus operator $ValPy[$from] = '='; # issue 58 } # issue 58 assignment($assign_start+1,$assign_end-1); gen_statement(); # # remove everytnogh but variable name. we need to shink arrrays # # issue 58 my $from=index($TokenStr,'=',$assign_start+2); # "=" now is next to identifier; should be #issue 58 my $howmany=$assign_end-$from+1; # closed interval my $use_default_match = 0; for(my $i = $from+1; $i <= $#ValClass; $i++) { if($ValClass[$i] eq 'q' && ($ValPy[$i] =~ /$DEFAULT_MATCH:=/)) { $use_default_match = 1; last; } } my $howmany=$assign_end-$from; # issue 58 - keep the ')' #say STDERR $TokenStr; if( $howmany>0 ){ destroy($from,$howmany); $adjust -= $howmany; # issue s148 } #say STDERR $TokenStr; # issue 58 # Remove opening bracket -- it is no longer needed # issue 58 destroy($assign_start,1); # # issue 58: Replace ($this, $that) with $this, and ($this) with $this return $adjust if(scalar(@_) >=3); # SNOOPYJC, issue s148 if($ValClass[$assign_start+1] eq 't') { # issue s34: handle my (..., ...) = destroy($assign_start+1, 1); # issue s34: delete the 'my' $adjust--; # issue s148 } if($ValClass[$assign_start+1] eq '(') { my $end = matching_br($assign_start+1); my $comma = index($TokenStr,',',$assign_start+2); if($end > 0) { if($comma > $assign_start && $comma < $end) { destroy($comma,$end-$comma+1); # remove from ',' to ')' $adjust--; # issue s148 #say STDERR $TokenStr; } else { destroy($end,1); $adjust--; # issue s148 #say STDERR $TokenStr; } destroy($assign_start+1,1); $adjust--; # issue s148 if($use_default_match) { replace($assign_start+1, 's', '$'.$DEFAULT_MATCH, $DEFAULT_MATCH); } else { if($ValClass[$assign_start+1] eq 'f' && $ValPerl[$assign_start+1] eq 'undef') { # SNOOPYJC: Unfortunate to have (undef,...) at start of list replace($assign_start+1, 's', 'undef', '_'); } insert($assign_start+1, 'f', 'defined', 'defined'); $adjust++; } #say STDERR $TokenStr; } } return $adjust; # issue s148 } # # Process all control statements # sub control { my $begin=$_[0]; if($debug >= 3) { say STDERR "control($begin) =|$TokenStr|= @ValPerl\n" } if( $begin<0 || $TrStatus<0 ){ return -255; } my $limit; my ($hashpos,$end_pos,$end_br_pos,$k,$increment,$tempvar); $start=$begin+1; # issue paren if( $ValPerl[$start] eq '(' ){ # issue paren $start++; # issue paren } # issue paren if($ValClass[-1] eq ')' ){ if(index(substr($TokenStr,$start),')=') >= 0) { # issue 58: complicated assignment in expression pre_assign($begin, $start); # issue 58, issue s148: add '$begin' parameter } # issue 58 $limit = $#ValClass; # issue paren my $hadparens = 0; # issue paren # issue s290 if( $ValPerl[$start] eq '(' && $ValClass[-1] eq ')' && ($ValPerl[$begin] eq 'for' || $ValPerl[$begin] eq 'foreach' || $TokenStr !~ /=/)) { # issue paren, issue 32 (walrus op has to be in parens - but skip the '=' in a 'for' loop) if( $ValPerl[$start] eq '(' && $ValClass[-1] eq ')' && ($ValPerl[$begin] eq 'for' || $ValPerl[$begin] eq 'foreach' || ($ValPerl[$begin] eq 'assert' && is_list($start+1)) || $TokenStr !~ /=/)) { # issue paren, issue 32 (walrus op has to be in parens - but skip the '=' in a 'for' loop), issue s290: don't paren an assert stmt with a list $hadparens = 1; # issue paren Perlscan::destroy(-1); # eliminate last bracket -- Perl does not enclose controlstatements in bralckts. Perlscan::destroy($start,1); # issue paren $limit=$#ValClass; # exclude it from count if($debug >= 3) { say STDERR "control-parens removed, begin=$begin start=$start =|$TokenStr|= @ValPerl\n" } } $limit = $_[1] if (scalar(@_) >= 2); # issue 81 if( $ValPerl[$begin] eq 'if' || $ValPerl[$begin] eq 'unless' ){ # issue 18 if( $TokenStr eq 'c(i)') { # SNOOPYJC if( $TokenStr eq 'ci' && !$LocalSub{$ValPy[$start]}) { # issue 18, issue paren: at this point the '()' are gone if( $TokenStr eq 'cj') { # issue 18, issue paren: at this point the '()' are gone, SNOOPYJC # while() # issue test coverage gen_chunk("$ValPy[$start] $DEFAULT_VAR = $ValPy[$start+1]:"); # gen initial keyword # issue 32 gen_chunk("$ValPy[$begin] ($DEFAULT_VAR := $ValPy[$start]):"); # gen initial keyword # issue 32, issue test coverage return($#ValClass); # issue s307 } elsif($TokenStr eq 'cqrq' || $TokenStr eq 'cdrq') { # SNOOPYJC: issue range # issue s363: Handle either pattern being a simple string pattern with token " # issue s363 } elsif($TokenStr =~ /^c[dsq]r[dsq]$/) { # issue s307 } elsif($TokenStr =~ /^c[dsq"]r[dsq"]$/) { # issue s307, issue s363 $Pyf{'_range'} = 1; my $key = substr($Pythonizer::fname,0,length($Pythonizer::fname)-3).':'.$.; # filename and line # as key - each range gets it's own storage my $pat1; my $flags1 = 0; if($ValClass[1] eq 'd' || $ValClass[1] eq 's') { # issue s307 $pat1 = $ValPy[1]; } elsif($ValClass[1] eq '"') { # issue s363 $ValPy[1] =~ /^(.*) in $CONVERTER_MAP{S}\($DEFAULT_VAR\)$/; $pat1 = $1; return -255 if(!$pat1) } else { $ValPy[1] =~ /^re\.search\((.*),.*(?:,\s?flags=(.*))?\)/; $pat1 = $1; return -255 if(!$pat1); $flags1 = $2 if($2); } my ($pat2, $var, $flags2); # issue s307 $flags2 = 0; if($ValClass[3] eq 'q') { # issue s307 $ValPy[3] =~ /re\.search\((.*),(.*)(?:,\s?flags=(.*))?\)/; $pat2 = $1; return -255 if(!$pat2); $var = $2; return -255 if(!$var); $flags2 = $3 if($3); } elsif($ValClass[3] eq '"') { # issue s363 $ValPy[3] =~ /^(.*) in $CONVERTER_MAP{S}\($DEFAULT_VAR\)$/; $pat2 = $1; return -255 if(!$pat1) } else { $pat2 = $ValPy[3]; $var = 'None'; } gen_chunk("$ValPy[$begin] ", '_range', "($var, $pat1, $flags1, $pat2, $flags2, '$key'):"); return($#ValClass); } gen_chunk($ValPy[$begin]); # gen initial keyword if( $ValPerl[$begin] eq 'unless' ) { gen_chunk('('); } # issue 20 if(next_same_level_token('A', $start, $limit) != -1) { # issue s156 logme('W', '=> operator is probably not what the programmer intended here'); # issue s156 gen_chunk('{'); # issue s156 } # issue s156 $k=expression($start,$limit,0); # last bracket was erased. return -255 if ($k<0); gen_chunk('}') if(next_same_level_token('A', $start, $limit) != -1); # issue s156 if( $ValPerl[$begin] eq 'unless' ) { gen_chunk(')'); } # issue 20 gen_chunk(':'); return($#ValClass); }elsif( $ValPerl[$begin] eq 'while' || $ValPerl[$begin] eq 'until' ){ # SNOOPYJC: Implement 'do': my $in_do = 0; if(defined $Perlscan::nesting_last && $Perlscan::nesting_last->{type} eq 'do') { my $lno = $Perlscan::nesting_last->{lno}; # issue s147 $ValPy[$begin] =~ s/^while\s*/$DO_CONTROL$lno = (/; no warnings 'uninitialized'; # issue s147: $1 can be uninitialized if there is no 'not' $ValPy[$begin] =~ s/^while( not)?\s*/$DO_CONTROL$lno =$1 (/; # issue s147 $in_do = 1; correct_nest(1,1); $Perlscan::nesting_last = undef; } # issue 18 if( $TokenStr eq 'c(s=i)' && substr($ValPerl[4],0,1) eq '<' ) { # SNOOPYJC if( $TokenStr eq 'cs=i' && substr($ValPerl[4],0,1) eq '<' ) { # issue 18, issue paren if( $TokenStr eq 'cs=j' ) { # issue 18, issue paren, SNOOPYJC gen_chunk("$ValPy[0] $ValPy[2] in $ValPy[4]" ); # issue 18}elsif( substr($TokenStr,$start) eq 'c(d)' && $ValPy[$start+2]==1 ){ }elsif( substr($TokenStr,$start) eq 'd' && $ValPy[$start] eq '1' ){ # issue 18 gen_chunk("$ValPy[0] True" ); # while(1) Perl idiom # issue 18}elsif( substr($TokenStr,$start) eq 'c(i)' ){ # SNOOPYJC }elsif( substr($TokenStr,$start) eq 'i' ){ # issue 18 }elsif( substr($TokenStr,$start) eq 'j' ){ # issue 18, SNOOPYJC # issue 18 gen_chunk("$ValPy[0] default_var in $ValPy[2]" ); # while() gen_chunk("$ValPy[0] ($DEFAULT_VAR:=$ValPy[1])" ); # while() # issue 18, issue paren, issue 32 }elsif( substr($TokenStr,$start) eq 'g' ){ # issue 66 - glob save_code(); # issue 66 gen_statement("$GLOB_LIST = $ValPy[$start]"); # issue 66 restore_code(); # issue 66 gen_chunk("for $DEFAULT_VAR in $GLOB_LIST" ); # issue 66 }else{ gen_chunk($ValPy[$begin]); #while if ($ValClass[$start] eq '('){ $TrStatus=expression($start,$limit,1); # gen expression }else{ $TrStatus=expression($start,$limit,0); # gen expression } } if($in_do) { # SNOOPYJC gen_chunk(')'); gen_statement(); correct_nest(-1,-1); } else { gen_chunk(':'); } return($#ValClass); # issue paren }elsif( $ValPerl[$begin] eq 'for' && $ValPerl[$begin+1] eq '(' && $ValClass[$begin+2] !~ /[ahf]/ ){ }elsif( ($ValPerl[$begin] eq 'for' || $ValPerl[$begin] eq 'foreach') && $hadparens == 1 && $ValClass[$begin+1] !~ /[ahf]/ ){ # issue paren, issue foreach # regular for loop but can be foreach loop too my $gen_while = 0; # issue for if( $ValPerl[-1] eq '++' && $ValClass[-2] eq 's' && $ValClass[-3] eq ';'){ $increment=''; }elsif( $ValPerl[-1] eq '--' && $ValClass[-2] eq 's' && $ValClass[-3] eq ';'){ $increment='-1'; }elsif( $ValPerl[-2] eq '++' && $ValClass[-1] eq 's' && $ValClass[-3] eq ';'){ # issue s136 $increment=''; # issue s136 }elsif( $ValPerl[-2] eq '--' && $ValClass[-1] eq 's' && $ValClass[-3] eq ';'){ # issue s136 $increment='-1'; # issue s136 } elsif(($k=index($TokenStr, ';((s=s+d)-d)')) > 0 && $k+11 == $#ValClass) { # issue 74 - replacement code for ++ $increment=''; # issue 74 } elsif(($k=index($TokenStr, ';((s=s-d)+d)')) > 0 && $k+11 == $#ValClass) { # issue 74 - replacement code for -- $increment='-1'; # issue 74 } elsif(($k=index($TokenStr, ';((s=f(s)+d)-d)')) > 0 && $k+14 == $#ValClass) { # SNOOPYJC: Handle us putting a _num conversion in $increment=''; } elsif(($k=index($TokenStr, ';((s=f(s)-d)+d)')) > 0 && $k+14 == $#ValClass) { # SNOOPYJC: Handle us putting a _num conversion in $increment='-1'; } elsif(($k=index($TokenStr, ';s=d')) > 0 && $ValPerl[$k+2] eq '+=' && $k+3 == $#ValClass) { $increment=$ValPy[$k+3]; } elsif(($k=index($TokenStr, ';s=d')) > 0 && $ValPerl[$k+2] eq '-=' && $k+3 == $#ValClass) { $increment= - $ValPy[$k+3]; } elsif(($k=index($TokenStr, ';s=f(s)+d')) > 0 && $ValPerl[$k+1] eq $ValPerl[$k+5] && $ValPy[$k+3] eq $CONVERTER_MAP{N} && $k+8 == $#ValClass) { $increment=$ValPy[$k+8]; } elsif(($k=index($TokenStr, ';s=f(s)-d')) > 0 && $ValPerl[$k+1] eq $ValPerl[$k+5] && $ValPy[$k+3] eq $CONVERTER_MAP{N} && $k+8 == $#ValClass) { $increment= - $ValPy[$k+8]; } elsif(($k=index($TokenStr, ';^f(s)')) > 0 && $ValPy[$k+2] eq $CONVERTER_MAP{N} && $k+5 == $#ValClass) { # issue s362 $increment=''; # issue s362 $increment='-1' if $ValPerl[$k+1] eq '--'; # issue s362 } elsif(($k=index($TokenStr, ';f(s)^')) > 0 && $ValPy[$k+1] eq $CONVERTER_MAP{N} && $k+5 == $#ValClass) { # issue s362 $increment=''; # issue s362 $increment='-1' if $ValPerl[$k+5] eq '--'; # issue s362 }elsif( index($TokenStr,';',$begin+1) < 0 ) { # issue foreach: Expression returning an iterable # $gen_enumerate = exists $Perlscan::line_contains_for_loop_with_modified_counter{$.}; # issue s252 # NOTE: We cannot handle this case which is like: for ($i, $j, $k) {...} # and $_ is modified in the loop, which then changes either $i, $j, or $k, so here we punt and # generate a warning $gen_enumerate = ''; # issue s252 if(exists $Perlscan::line_contains_for_loop_with_modified_counter{$.}) { # issue s252 # issue s310: handle for (@$slice) if($begin+1 == $limit && $ValClass[$limit] eq 's' && defined $ValType[$limit] && $ValType[$limit] =~ /[@%]s/) { # issue s310 $gen_enumerate = 1; # issue s310 } else { # issue s310 my $lno = $.; for (keys %Perlscan::line_modifies_foreach_counter) { if($Perlscan::line_modifies_foreach_counter{$_} == $.) { $. = $_; logme('W', 'Update to $_ alias of foreach items will not modify list items') } } $. = $lno; } } # issue s252 gen_chunk($ValPy[$begin]); # issue foreach if($gen_enumerate) { # issue s252 gen_chunk("$INDEX_TEMP$., $DEFAULT_VAR in enumerate("); # issue foreach, issue 32 if($begin+1 != $limit || ($ValClass[$limit] ne 'a' && $ValClass[$limit] ne 's')) { # issue s310 gen_chunk("$SUBSCRIPT_TEMP$.:="); $foreach_modified_counter_assignment_map{$.} = "$SUBSCRIPT_TEMP$.\[$INDEX_TEMP$.] = $DEFAULT_VAR"; } else { $foreach_modified_counter_assignment_map{$.} = "$ValPy[$limit]\[$INDEX_TEMP$.] = $DEFAULT_VAR"; } add_outer_loops_to_assignment_map_if_need_be(); # issue s252 say STDERR "foreach_modified_counter_assignment_map{$.} = $foreach_modified_counter_assignment_map{$.}" if $debug; } else { gen_chunk("$DEFAULT_VAR in "); # issue foreach, issue 32 } # issue range if( ($range=index($TokenStr,'r',$begin+1)) != -1) { # issue range if( ($range=next_same_level_token('r',$begin+2,$limit-1)) != -1 && !is_list($begin+2)) { # issue range, issue s174 gen_chunk('range('); # issue range $k=expression($begin+1,$range-1,0); # issue range return -255 if ($k<0); # issue range gen_chunk(','); # issue range $k=expression($range+1,$limit,0); # issue range return -255 if ($k<0); # issue range gen_chunk('+1)'); # issue range } else { # issue range gen_chunk('('); # issue foreach $k=expression($begin+1,$limit,0); # issue foreach return -255 if ($k<0); # issue foreach gen_chunk(')'); # issue foreach } # issue range gen_chunk(')') if $gen_enumerate; # issue s252 gen_chunk(':'); # issue foreach return $#ValClass; # issue foreach }elsif($TokenStr eq "c;;") { # issue for: handle for(;;) gen_chunk('while True', ':'); return $#ValClass; }else{ $gen_while = 1; #logme('S', "In the current version more complex increment than ++ or -- requires manual translation"); #$TrStatus=-1; #return -255; } $gen_while = 1 if($Perlscan::line_contains_for_loop_with_modified_counter{$.}); $start=$begin; if($gen_while) { # issue for # Generate a 'while' loop instead to handle this case of a 'for' loop that # can't be handled using a range, or mod's the loop counter. my $semi1 = next_same_level_token(';', $start, $#ValClass); my $semi2 = next_same_level_token(';', $semi1+1, $#ValClass); if($semi1 < 0 || $semi2 < 0) { $TrStatus=-1; return -255; } if($semi1-$start != 1) { # We need to initialize the loop counter just above the while loop: # Temporarily save the tokens so we can pretend this is a stand-alone statement for fix_expression_issues my $tmp_code = package_tokens(); destroy($semi1, (scalar(@ValClass)-$semi1)); destroy(0, $start+1); fix_expression_issues(); # Run again here because we don't do much on "for" loops if(next_same_level_token(',', 0, $#ValClass) == -1) { my $eq = next_same_level_token('=', 0, $#ValClass); $ValPy[$eq] = '=' if($eq != -1 && $ValPy[$eq] eq ':='); $TrStatus=assignment(0, $#ValClass); } else { $TrStatus=expression(0, $#ValClass, 1); } gen_statement(); unpackage_tokens($tmp_code); } gen_chunk('while'); if($semi1+1 <= $semi2-1) { $TrStatus = expression($semi1+1, $semi2-1, 0) } else { gen_chunk('True'); } gen_chunk(':'); gen_statement(); my $my_code = package_tokens(); p_destroy($my_code, 0, $semi2+1); &Perlscan::set_needs_implicit_continue($my_code); return($#ValClass); } gen_chunk($ValPy[$start]); # issue parens if ($ValClass[$start+2] eq ';'){ # issue parens gen_chunk($ValPy[$start+3],' in range(',$ValPy[$start+3]); # issue parens $end_pos=$start+2; my $loop_ctr; # issue s111 if ($ValClass[$start+1] eq ';'){ # issue parens # issue s111 my $loop_ctr = $ValPy[$start+2]; # issue for: Handle converter $loop_ctr = $ValPy[$start+2]; # issue for: Handle converter, issue s111 if($ValClass[$start+2] eq 'f' && ($loop_ctr eq $CONVERTER_MAP{N} || $loop_ctr eq $CONVERTER_MAP{I})) { $ValPy[$start+2] = $CONVERTER_MAP{I}; # Switch it to an integer converter for loop counter $loop_ctr = $ValPy[$start+4]; } # issue for gen_chunk($ValPy[$start+2],' in range(',$ValPy[$start+2]); # issue parens gen_chunk($loop_ctr,' in range('); my $condition = next_same_level_token('>', $start+2, $limit); $TrStatus=expression($start+2, $condition-1, 0); # issue for $end_pos=$start+1; # issue parens $end_pos=$condition; # issue for, issue parens }else{ # issue parens gen_chunk($ValPy[$start+2]); # index var $loop_ctr = $ValPy[$start+1]; # issue s111 gen_chunk($ValPy[$start+1]); # index var gen_chunk('in range('); $start=index($TokenStr,'=',$start); # find initialization. BTW it can be expression if( $start == -1 ){$TrStatus=-1; return -255;} $start++; # find end of initialization $end_pos=next_same_level_token(';',$start,$limit); # end of expression # issue foreach: could be function call with no args! if( $end_pos-$start==1 ){ # issue foreach: could be function call with no args! gen_chunk($ValPy[$start]); # issue foreach: could be function call with no args! }else{ $TrStatus=expression($start,$end_pos-1,0); # gen expression if( $TrStatus < -1 ){return -255;} # issue foreach: could be function call with no args! } } gen_chunk(','); # # Analize loop exit condition # $start=index($TokenStr,'>',$end_pos); # fron last ; # issue s111 if( $start == -1 ){$TrStatus=-1; return -255; } $inc = ''; # issue foreach if($start == -1 && $ValClass[$end_pos+1] eq 's' && $ValPy[$end_pos+1] eq $loop_ctr) { # issue s111 # This is the case of for($loop_ctr=...; $loop_ctr; ...) $start = $end_pos; # issue s111 replace($start+1,'d','0','0'); # issue s111 } else { if($ValPerl[$start] eq '<=') { # issue foreach $inc = '+1'; # issue foreach }elsif($ValPerl[$start] eq '>=') { # issue foreach $inc = '-1'; # issue foreach } # issue foreach } $start++; # find end of loopexit condition $end_pos=next_same_level_token(';',$start,$limit); if( $end_pos == -1 ){$TrStatus=-1; return -255; } # issue foreach: could be function call with no args! if( $end_pos-$start==1 ){ # issue foreach: could be function call with no args! if($ValClass[$start] eq 'a'){ # issue foreach: could be function call with no args! gen_chunk($ValPy[$start]); # array as limit of the range # issue foreach: could be function call with no args! }else{ # issue foreach: could be function call with no args! gen_chunk($ValPy[$start]); # all other cases of single limit of the range # issue foreach: could be function call with no args! } # issue foreach: could be function call with no args! }else{ $TrStatus=expression($start,$end_pos-1); # gen expression for the limit of the range return -255 if ($TrStatus<0); # issue foreach: could be function call with no args! } if( $inc ) { # issue foreach gen_chunk($inc); # issue foreach } # issue foreach # we already got increamnt at the begining if( $increment) { gen_chunk(", $increment):"); }else{ gen_chunk('):'); } return($#ValClass); }elsif( $ValPerl[$begin] eq 'for' || $ValPerl[$begin] eq 'foreach' ){ if(&Perlscan::needs_try_block(-1)) { # issue s101 gen_statement('try:'); correct_nest(1,1); &Perlscan::stack_foreach_var(); } gen_chunk($ValPy[$begin]); $gen_enumerate = exists $Perlscan::line_contains_for_loop_with_modified_counter{$.}; # issue s252 my $st = $start; # issue s252 my $var; # issue s252 if($ValClass[$start] eq 's' && !for_loop_uses_default_var(0)){ # issue s252 $st++; # issue s252 $var = $ValPerl[$start]; # issue s252 } else { # issue s252 $var = '$_'; # issue s252 } # issue s252 if(is_list($st)) { # issue s252: We can't handle a list of items $gen_enumerate = ''; # issue s252 my $lno = $.; for (keys %Perlscan::line_modifies_foreach_counter) { if($Perlscan::line_modifies_foreach_counter{$_} == $.) { $. = $_; logme('W', "Update to $var alias of foreach items will not modify list items") } } $. = $lno; } # issue s252 my $array; # issue s252 my $loop_ctr; # issue s252 if($gen_enumerate) { # issue s252 #gen_chunk("$INDEX_TEMP$., $DEFAULT_VAR in enumerate("); # issue foreach, issue 32 gen_chunk("$INDEX_TEMP$., "); # issue s252 } if ($ValClass[$start] eq 's' && !for_loop_uses_default_var(0)){ # issue s235 gen_chunk($ValPy[$start].' in '); $loop_ctr = $ValPy[$start]; # issue s252 }else{ gen_chunk("$DEFAULT_VAR in "); # issue 32 $start--; # issue foreach $loop_ctr = $DEFAULT_VAR; # issue s252 } if($gen_enumerate) { # issue s252 gen_chunk('enumerate('); # issue s252 } # issue s252 if( $hadparens == 1 ) { # issue parens, foreach - we removed the parens, but in this case we need them! insert($start+1,'(','(','('); # issue parens append(')',')',')'); # issue parens } elsif($start+1 > $#ValClass) { # issue parens: e.g. this($_) foreach @arr; insert($start,'(','(','('); # issue parens append(')',')',')'); # issue parens } elsif($ValClass[$start+1] ne '(') { # issue parens - could be STMT for LIST; insert($start+1,'(','(','('); # issue parens append(')',')',')'); # issue parens } $start=index($TokenStr,'(',$start); if( substr($TokenStr,$start) eq '(a)' || substr($TokenStr,$start) eq '(s)') { # issue bootstrap - loop over @$arrayref - the @ has been removed # loop over an array gen_chunk($ValPy[$start+1]); $array = $ValPy[$start+1]; }elsif( substr($TokenStr,$start) eq '(h)') { # SNOOPYJC: Looping over a hash in perl gives the keys and the values # loop over a hash # SNOOPYJC gen_chunk('functools.reduce(lambda x,y:x+y,'.$ValPy[$start+1].'.items())'); if($gen_enumerate) { # issue s252 gen_chunk("$SUBSCRIPT_TEMP$.:="); # issue s252 $array = "$SUBSCRIPT_TEMP$."; # issue s252 } # issue s252 gen_chunk('list(itertools.chain.from_iterable('.$ValPy[$start+1].'.items()))'); # SNOOPYJC: add "list(..)" in case they modify it in the loop }elsif( substr($TokenStr,$start)=~/^\(f\(?h\)/ ){ # foreach loop over a hash $start++; # skip '(' if($gen_enumerate) { # issue s252 gen_chunk("$SUBSCRIPT_TEMP$.:="); # issue s252 $array = "$SUBSCRIPT_TEMP$."; # issue s252 } # issue s252 if( $ValPerl[$start] eq 'keys' || $ValPerl[$start] eq 'values' ){ $hashpos=index($TokenStr,'h',$start); # issue foreach gen_chunk("$ValPy[$hashpos]q$ValPy[$start]()"); # translate keys function into postfix notation # issue modify keys in loop: # "The returned values are copies of the original keys in the hash, so modifying them will not affect the original hash" gen_chunk('list(') if($ValPerl[$start] eq 'keys'); gen_chunk("$ValPy[$hashpos]$ValPy[$start]"); # translate keys function into postfix notation # issue foreach gen_chunk(')') if($ValPerl[$start] eq 'keys'); } elsif($ValPerl[$start] eq 'sort') { # SNOOPYJC: Sort the keys and values $hashpos=index($TokenStr,'h',$start); # SNOOPYJC # SNOOPYJC gen_chunk('sorted(list(functools.reduce(lambda x,y:x+y,'.$ValPy[$hashpos].'.items())))'); # SNOOPYJC gen_chunk('sorted(list(itertools.chain.from_iterable('.$ValPy[$hashpos].'.items())))'); # SNOOPYJC }else{ say STDERR "FIXME: Can't handle 'for' with $ValPerl[$start]\n"; # SNOOPYJC $TrStatus=-1; return -255; } }elsif( substr($TokenStr,$start) eq '(q)' && ($ValPy[$start+1] =~ /\.split\(\)$/ || $ValPy[$start+1] =~ /re\.finditer/)) { # SNOOPYJC: qw/.../ gen_chunk($ValPy[$start+1]); }elsif( substr($TokenStr,$start) eq '((q))' && ($ValPy[$start+2] =~ /\.split\(\)$/ || $ValPy[$start+2] =~ /re\.finditer/)) { # SNOOPYJC: (qw/.../) gen_chunk($ValPy[$start+2]); }elsif( substr($TokenStr,$start)=~/^\((['"qds](,['"qds])*)\)/ ){ # loop over explisit list $tempvar='['; for(my $i=$start+1;$i<$#ValClass;$i++){ $tempvar.=$ValPy[$i]; } gen_chunk($tempvar,']'); # issue range }elsif( ($range=index($TokenStr,'r',$start)) != -1) { # issue range }elsif( substr($TokenStr,$start) =~ /^\(f\(?.*r/ && $ValPerl[$start+1] eq 'reverse') { # issue range my $s = ($ValClass[$start+2] eq '(') ? $start+3 : $start+2; my $e = ($ValClass[$start+2] eq '(') ? matching_br($start+2)-1 : $#ValClass-1; $range=next_same_level_token('r',$s,$e); return -255 if ($range<0); # issue range gen_chunk('range('); $k=expression($range+1,$e,0); return -255 if ($k<0); # issue range gen_chunk(','); $k=expression($s,$range-1,0); return -255 if ($k<0); # issue range gen_chunk('-1, -1)'); # issue range }elsif( ($range=next_same_level_token('r',$start+1,$#ValClass-1)) != -1 && !is_list($start+1)) { # issue range, issue s174 gen_chunk('range('); # issue range $k=expression($start+1,$range-1,0); # issue range return -255 if ($k<0); # issue range gen_chunk(','); # issue range $k=expression($range+1,$#ValClass-1,0); # issue range return -255 if ($k<0); # issue range gen_chunk('+1)'); # issue range }else{ #$end_pos = matching_br($start); # issue foreach # issue s75 if( $ValPerl[$start] ne '(' || $ValPerl[-1] ne ')' || index(substr($TokenStr,$start), ',') >= 0) { # issue foreach: This is a list - keep the parens if($gen_enumerate) { # issue s252 gen_chunk("$SUBSCRIPT_TEMP$.:="); # issue s252 $array = "$SUBSCRIPT_TEMP$."; # issue s252 } # issue s252 if(is_list($start)) { # issue s75 # issue s75 $k=expression($start,$#ValClass,0); # issue foreach $k=expression($start,$#ValClass,2); # issue foreach, issue s75: do splats } elsif( $ValPerl[$start] ne '(' || $ValPerl[-1] ne ')') { # issue foreach: This is a list - keep the parens $k=expression($start,$#ValClass,0); # issue foreach } elsif(next_same_level_token('=', $start+1, $#ValClass-1) != -1) { # issue s217: We have a := in there: keep the parens $k=expression($start,$#ValClass,0); # issue s217 } else { # issue foreach destroy($#ValClass, 1); # issue foreach - eat the right paren $k=expression($start+1,$#ValClass,0); # issue foreach: No list - no parens } # issue foreach return -255 if ($k<0); # issue foreach $TrStatus=-1; return -255; } if($gen_enumerate and defined $array) { # issue s252 $foreach_modified_counter_assignment_map{$.} = "$array\[$INDEX_TEMP$.] = $loop_ctr"; add_outer_loops_to_assignment_map_if_need_be(); # issue s252 say STDERR "foreach_modified_counter_assignment_map{$.} = $foreach_modified_counter_assignment_map{$.}" if $debug; } gen_chunk(')') if $gen_enumerate; # issue s252 gen_chunk(':'); return $#ValClass; }elsif( $ValPerl[$begin] eq 'assert' ) { # SNOOPYJC gen_chunk('assert'); $k=expression($start,$#ValClass,0); return -255 if ($k<0); return $#ValClass; }elsif( $ValPerl[$begin] eq 'package' && $start <= $#ValClass) { # SNOOPYJC gen_chunk("builtins.__PACKAGE__ = '$ValPy[$start]'"); $CurPackage = $ValPy[$start]; $set_initial_package = 1; # issue s18: Generate the '_init_package(...)' lines we deferred waiting for the 'package' definition line to be generated # We do this to prevent the _init_global calls from occuring before the parent variable is defined if(exists $deferred_init_packages{$ValPy[$start]}) { gen_statement(); foreach my $defer (@{$deferred_init_packages{$ValPy[$start]}}) { gen_statement($defer); } delete $deferred_init_packages{$ValPy[$start]}; # Only generate them once even if this package is defined again } return $#ValClass; }elsif($ValPy[$begin] eq 'given') { # issue s129 my $top = $Perlscan::nesting_stack[-1]; my $lno = $top->{lno}; my $switch_var = $SWITCH_VAR . $lno; $Pyf{_switch} = 1; gen_chunk($switch_var, '=', '_switch', '('); gen_chunk($DEFAULT_VAR, ':=') if($ValPerl[$begin] eq 'given'); # set _d for given, not switch stmt $k=expression($start,$#ValClass,0); gen_chunk(')'); return -255 if ($k<0); gen_statement(); #gen_statement('while 1:'); gen_statement('for _ in range(1):'); return $#ValClass; }elsif($ValPy[$begin] eq 'when') { # issue s129 my $top = $Perlscan::nesting_stack[-1]; if($top->{type} ne 'given') { return -255 if(scalar(@Perlscan::nesting_stack) < 2); $top = $Perlscan::nesting_stack[-2]; return -255 if($top->{type} ne 'given'); } my $lno = $top->{lno}; my $switch_var = $SWITCH_VAR . $lno; gen_chunk('if', $switch_var, '('); $k=expression($start,$#ValClass,0); gen_chunk(')', ':'); return -255 if ($k<0); return $#ValClass; } elsif($ValPerl[$begin] eq 'aliased_foreach') { # issue s252 # aliased_foreach $var (list_of_vars) my $subname = $ValPy[$begin]; # We can't handle 'last' because the exception would cause one of the values not to be updated! #gen_statement('for _ in range(1):'); # Use a loop so you can 'last' it #correct_nest(1,1); #gen_statement('try:'); #correct_nest(1,1); my $sub_arg = $nested_subs{$subname}; if($sub_arg eq '') { gen_statement('try:'); correct_nest(1,1); $subname =~ /^$ANONYMOUS_SUB(\d+)/; $Perlscan::statement_starting_lno = $1; &Perlscan::stack_foreach_var(); } for(my $i = 3; $i < $#ValClass; $i++) { $e = end_of_variable($i); if($ValClass[$i] eq 's' && (!$ValType[$i] || $ValType[$i] !~ /^[@%]s$/)) { # Simple scalar if($sub_arg eq '') { # e.g. the loop counter is global gen_chunk($ValPy[$start], '='); $TrStatus = expression($i, $e); gen_statement(); # issue s359 $TrStatus = expression($i, $e); $TrStatus = expression($i, $e, 8); # issue s359: Don't use .get(...) gen_chunk('=', $subname, '(', ')'); } else { # issue s359 $TrStatus = expression($i, $e); $TrStatus = expression($i, $e, 8); # issue s359: Don't use .get(...) gen_chunk('=', $subname, '('); $TrStatus = expression($i, $e); gen_chunk(')'); } gen_statement(); } elsif($ValClass[$i] eq 'a' || (defined $ValType[$i] && $ValType[$i] eq '@s')) { # array gen_chunk('for', $INDEX_TEMP, 'in', 'range(len('); $TrStatus = expression($i, $e); gen_chunk(')):'); gen_statement(); correct_nest(1,1); if($sub_arg eq '') { gen_chunk($ValPy[$start], '='); $TrStatus = expression($i, $e); gen_chunk("[$INDEX_TEMP]"); gen_statement(); $TrStatus = expression($i, $e); gen_chunk("[$INDEX_TEMP]", '=', $subname, '(', ')'); } else { $TrStatus = expression($i, $e); gen_chunk("[$INDEX_TEMP]", '=', $subname, '('); $TrStatus = expression($i, $e); gen_chunk("[$INDEX_TEMP]", ')'); } gen_statement(); correct_nest(-1,-1); } elsif($ValClass[$i] eq 'f' && $ValPy[$i] eq '_fetch_perl_global') { # issue s299 # Handle =|f(".")|=, @ValPerl=_fetch_perl_global ( $pkg\::EXPORT_OK . _a ) my $e = matching_br($i+1); if($ValClass[$e-1] eq '"' && $ValPerl[$e-1] eq '_v') { # Scalar if($sub_arg eq '') { gen_chunk($ValPy[$start], '='); $TrStatus = expression($i, $e); gen_statement(); $Pyf{_store_perl_global} = 1; gen_chunk('_store_perl_global', '('); $TrStatus = expression($i+2, $e-1); gen_chunk(',', $subname, '(', ')', ')'); } else { $Pyf{_store_perl_global} = 1; gen_chunk('_store_perl_global', '('); $TrStatus = expression($i+2, $e-1); gen_chunk(',', $subname, '('); $TrStatus = expression($i, $e); gen_chunk(')', ')'); } gen_statement(); } elsif($ValClass[$e-1] eq '"' && $ValPerl[$e-1] eq '_a') { # Array gen_chunk($SUBSCRIPT_TEMP, '='); $TrStatus = expression($i, $e); gen_statement(); gen_chunk('for', $INDEX_TEMP, 'in', 'range(len('); gen_chunk($SUBSCRIPT_TEMP); gen_chunk(')):'); gen_statement(); correct_nest(1,1); if($sub_arg eq '') { gen_chunk($ValPy[$start], '='); gen_chunk($SUBSCRIPT_TEMP); gen_chunk("[$INDEX_TEMP]"); gen_statement(); gen_chunk($SUBSCRIPT_TEMP); gen_chunk("[$INDEX_TEMP]", '=', $subname, '(', ')'); } else { gen_chunk($SUBSCRIPT_TEMP); gen_chunk("[$INDEX_TEMP]", '=', $subname, '('); gen_chunk($SUBSCRIPT_TEMP); gen_chunk("[$INDEX_TEMP]", ')'); } gen_statement(); correct_nest(-1,-1); } else { # Assume it's a hash logme('W', "Aliased foreach is not supported here"); gen_chunk('for', $INDEX_TEMP, 'in', 'itertools.chain.from_iterable('); $TrStatus = expression($i, $e); gen_chunk('.items())', ':'); gen_statement(); correct_nest(1,1); if($sub_arg eq '') { gen_chunk($ValPy[$start], '=', $INDEX_TEMP); gen_statement(); gen_chunk($subname, '(', ')'); } else { gen_chunk($subname, '(', $INDEX_TEMP, ')'); } gen_statement(); correct_nest(-1,-1); } } elsif($ValClass[$i] eq 'h' || (defined $ValType[$i] && $ValType[$i] eq '%s')) { # hash logme('W', "Aliased foreach is not supported on hashes"); gen_chunk('for', $INDEX_TEMP, 'in', 'itertools.chain.from_iterable('); $TrStatus = expression($i, $e); gen_chunk('.items())', ':'); gen_statement(); correct_nest(1,1); if($sub_arg eq '') { gen_chunk($ValPy[$start], '=', $INDEX_TEMP); gen_statement(); gen_chunk($subname, '(', ')'); } else { gen_chunk($subname, '(', $INDEX_TEMP, ')'); } gen_statement(); correct_nest(-1,-1); } elsif($ValClass[$i] eq 'd' || $ValClass[$i] eq '"') { if($sub_arg eq '') { gen_chunk($ValPy[$start], '=', $ValPy[$i]); gen_statement(); gen_chunk($subname, '(', ')'); } else { gen_chunk($subname, '(', $ValPy[$i], ')'); } gen_statement(); } elsif(is_multi($i)) { # issue s299 # (f(a -or- s,s)y(d,d...)) # [ _get_element ( array, index ) multi [ sub1, sub2, ... ] ] $e = matching_br($i); my $get_element_start = $i+1; my $get_element_end = matching_br($get_element_start+1); my $array_start = $get_element_start+2; my $array_end = is_list($array_start)-1; my $subscripts_start = $get_element_end+2; my $subscripts_end = $e-1; gen_chunk('for', $INDEX_TEMP, 'in'); $TrStatus = expression($subscripts_start, $subscripts_end); gen_chunk(':'); gen_statement(); correct_nest(1,1); if($sub_arg eq '') { gen_chunk($ValPy[$start], '='); $TrStatus = expression($array_start, $array_end); gen_chunk("[$INDEX_TEMP]"); gen_statement(); $TrStatus = expression($array_start, $array_end); gen_chunk("[$INDEX_TEMP]", '=', $subname, '(', ')'); } else { $TrStatus = expression($array_start, $array_end); gen_chunk("[$INDEX_TEMP]", '=', $subname, '('); $TrStatus = expression($array_start, $array_end); gen_chunk("[$INDEX_TEMP]", ')'); } gen_statement(); correct_nest(-1,-1); } $i = $e; } if($sub_arg eq '') { correct_nest(-1,-1); gen_statement('finally:'); correct_nest(1,1); &Perlscan::unstack_foreach_var(); correct_nest(-1,-1); } &Perlscan::unmap_loop_var($ValPerl[1]); # issue s252 # We can't handle 'last'!! #correct_nest(-1,-1); #my $ex_name; #my $top = $Perlscan::nesting_last; #if(!exists $top->{label} || !defined $top->{label}) { #$ex_name = label_exception_name('') #} else { #$ex_name = label_exception_name($top->{label}); #} #gen_chunk('except', $ex_name, ':'); #gen_statement(); #correct_nest(1,1); #gen_statement('pass'); #correct_nest(-2,-2); }else{ $TrStatus=-1; return -255; } } # control sub _function # Built-in functions processing { my $begin=$_[0]; my ($limit,$start ); # $limit is the position of closing bracket, if any # start is the position of the first symbol after the opening bracket $start=$begin+1; # default start for parentheiss less function; my $end_pos=$limit=$#ValClass; # SNOOPYJC if( scalar(@_)>1 ){ $end_pos=$limit=$_[1]; } if($debug >= 3) { say STDERR "function($begin, $limit) =|$TokenStr|= @ValPerl" } my $k; my $bracketed=0; # nessesary for the proper call of expression. if(substr($TokenStr, $begin, $limit+1-$begin) eq 'f(C(kis>d,",";ki";s&"))' && $ValPerl[$begin] eq 'length' && $ValPerl[$limit-2] eq '') { # SNOOPYJC # This big line represents an idiom to check if a value is a number or not: # length( do { no if $] >= 5.022, "feature", "bitwise"; no warnings "numeric"; $_[0] & "" } ) ) # We replace it with an isinstance check gen_chunk('isinstance(', $ValPy[$limit-4], ',', '(int, float))'); return $limit+1; } elsif(substr($TokenStr, $begin, $limit+1-$begin) eq 'f(s)&d' && $ValPy[$limit] eq '0') { # SNOOPYJC: Same idiom after issue s74 fix gen_chunk('0 if isinstance(', $ValPy[$begin+2], ',', '(int, float))', 'else', '""'); return $limit+1; } if($ValPerl[$begin] eq '%SIG' && $ValClass[$begin+1] eq '(') { # issue s3: Fixup %SIG{...} to %SIG(...) function $limit=matching_br($begin+1); $ValPy[$begin+1] = '('; $ValPy[$limit] = ')'; } if( $begin==$#ValClass || (scalar(@_)>1 && $begin==$limit) ){ $bracketed=-1; # serves as zero arg flag; }elsif( $begin<$#ValClass && $ValClass[$begin+1] eq '(' && $ValPy[$begin+1] eq '('){ # issue s3 $bracketed=1; $limit=matching_br($begin+1); if($limit < 0) { # issue s308 $TrStatus = 255; # issue s308 return $begin+1; # issue s308 } # issue s308 $start=$begin+2; # function call with normal pathethis if( $ValClass[$limit] eq ')' ){ $end_pos=$limit-1; } say STDERR "function($begin) for =|$TokenStr|= $ValPy[$begin], bracketed=1, start=$start, end_pos=$end_pos, limit=$limit" if($debug >= 5); # issue 16 }elsif( ($k=index($TokenStr,'0'))>=1 ){ # issue s3 }elsif( ($k=index($TokenStr,'0',$begin+1))>=1 ){ # issue 16 # }elsif( ($k=next_matching_tokens('0o>?:',$begin+1,$limit))>=1 ){ # issue 16, issue 93, issue 59, issue s3 #}elsif( ($k=next_matching_tokens('0o>',$begin+1,$limit))>=1 ){ # issue 16, issue 93, issue 59, issue s3 } else { # issue s3 $k = end_of_function($begin); # issue s3 #say STDERR "end_of_function($begin) for =|$TokenStr|= $ValPy[$begin] is $k" if($debug >= 3); $end_pos=$limit=$k if($k < $end_pos); # issue s3 # issue s3 $end_pos=$limit=$k-1 if($k-1 < $end_pos); # if we have any of ||, &&, <,==,<=,>,>=, ?, : that function should end before it $bracketed=-1 if($end_pos < $start); # issue 59 } if(0) { # issue s3 # issue s3 }elsif( ($k=index($TokenStr,'o',$begin+1))>=1 ){ # issue 16, issue 93 # issue s3 $end_pos=$limit=$k-1 if($k-1 < $end_pos); # if we have && that function should end before it # issue s3 $bracketed=-1 if($end_pos < $start); # issue 59 # issue s3 }elsif( ($k=index($TokenStr,'>',$begin+1))>=1 ){ # issue 16 # issue s3 $end_pos=$limit=$k-1 if($k-1 < $end_pos); # if we have <,==,<=,>,>= that function should end before it # issue s3 $bracketed=-1 if($end_pos < $start); # issue 59 # issue s3 }elsif( ($k=index($TokenStr,'?',$begin+1))>=1 ){ # issue 16 # issue s3 $end_pos=$limit=$k-1 if($k-1 < $end_pos); # if we have ? that function should end before it # issue s3 $bracketed=-1 if($end_pos < $start); # issue 59 # issue s3 }elsif( ($k=index($TokenStr,':',$begin+1))>=1 ){ # issue 16 # issue s3 $end_pos=$limit=$k-1 if($k-1 < $end_pos); # if we have : that function should end before it # issue s3 $bracketed=-1 if($end_pos < $start); # issue 59 }elsif($bracketed != 1 && scalar(@_)<2 && $begin != 0 && $ValClass[$begin-1] eq '(') { # issue paren, issue 81, issue test coverage # if the entire function call w/parameters is parenthesized, then the function ends # at the next right paren $end_pos=$limit=matching_br($begin-1)-1; # issue paren if ($end_pos < $begin) { # issue paren $end_pos=$limit=$#ValClass; # issue paren } # issue paren }elsif($bracketed != 1 && scalar(@_)<2) { # issue 81, issue test coverage $end_pos=$limit=$#ValClass; # issue paren: if we have (...f",") - then the ending paren isn't ours! if(defined $k && $k < $end_pos) { # issue s207: Defined above as end_of_function $end_pos=$limit=$k; # issue s207 } # issue s207 if($ValClass[$end_pos] eq ')') { # issue paren $mb = reverse_matching_br($end_pos); # issue paren if($mb < $begin) { # issue paren $end_pos=$limit-1; # issue paren } # issue paren } # issue paren } if($debug >= 3) { #say STDERR "function start=$start, end_pos=$end_pos, bracketed=$bracketed"; debug_start_end("function =|%|= start=$start, end_pos=$end_pos, bracketed=$bracketed", $start, $end_pos); } my ($split, $split2, $delta, $dict, $incr, $arg1, $arg2, $perl_name, $py_name); if( $begin<0 || $TrStatus<0 ){ $TrStatus=-255; return -255; } $perl_name=$ValPerl[$begin]; $py_name=$ValPy[$begin]; if(substr($py_name,0,1) eq '*') { # issue s75: Splat gen_chunk('*'); # issue s75 $py_name = substr($py_name,1); # issue s75 } # issue s75 my $orig_py_name = $py_name; # SNOOPYJC # issue s292 if($perl_name eq 'die' && $py_name =~ /^raise / && $begin != 0) { # SNOOPYJC if($perl_name eq 'die') { # issue s292: Always call _die $py_name = '_die'; # Can't use "raise" in the middle of an expression } elsif($py_name eq 'min_s' || $py_name eq 'max_s') { # test list util $py_name = substr($py_name, 0, 3); # test list util } #SNOOPYJC: See if this function has a special code module we need to include at the end if( !exists $Pyf{$py_name} ) { if( -e "$Pyf_dir/$py_name.py" ) { $Pyf{$py_name} = 1; #Include the module if($import_perllib) { $py_name = substr($py_name, 1) if(substr($py_name, 0, 1) eq '_'); # Eat initial '_', if any $py_name = escape_keywords($py_name, 2); # issue s200 $py_name = "$PERLLIB.$py_name"; } elsif(exists $PYF_CALLS{$py_name}) { # If this module calls another one, include that too my @fcns = split(/,/, $PYF_CALLS{$py_name}); for my $f (@fcns) { $Pyf{$f} = 1; } } } else { $Pyf{$py_name} = 0; #No module to include } } # # At this point # $start is the first token after prath (if presnet) # $end_pos is the sybol befor closing paren, if present # $limit -- the last symbol that belongs to this function, Scanning will start from $limit+1 if( $perl_name eq 'substr' ){ # substr($line,$from, To ) # 0 1 2 3 4 5 my $comma1 = next_same_level_tokens(',A', $start, $end_pos); # issue 114, issue s271 my $comma2 = next_same_level_tokens(',A', $comma1+1, $end_pos); # issue 114, issue s271 my $comma3 = next_same_level_tokens(',A', $comma2+1, $end_pos); # issue 114, issue s271 if( substr($TokenStr,$start,$end_pos-$start+1) =~ /^s,([-]?d),([-]?d)$/ ){ # issue 114 # the simplest case when start and length of the substring are constants: substr($test,-1,1); $arg1=$ValPy[index($TokenStr,'d',$start)]; # start $arg2=$ValPy[$end_pos]; # length if( length($1) >= 2 && substr($1,0,1) eq '-' ){ $arg1=-$arg1; } if( length($2) >= 2 && substr($2,0,1) eq '-' ){ $arg2=-$arg2; } # issue 76 if( length($arg2)==1){ if(0 && $arg2==1){ # issue 76; issue 130 gen_chunk("$ValPy[$start]\[$arg1\]"); # single symbol # issue s234 }elsif( $arg1<0 && -$arg1>=$arg2 ){ }elsif( $arg1<0 && $arg2 > 0 && ($arg1+$arg2) >= 0) { # issue s234 gen_chunk("$ValPy[$start]\[$arg1:\]"); # last symbol }elsif( $arg2>=0 ){ # issue 76 $arg2+=$arg1; gen_chunk("$ValPy[$start]\[$arg1:$arg2\]"); # positive length added to the first index }elsif($arg2<0) { gen_chunk("$ValPy[$start]\[$arg1:$arg2\]"); # negative value is not length but the position from the last }else{ $TrStatus=-1; return -255; } return $limit+1; # $limit is the position of closing bracket, if any } elsif($comma3 != -1 && $comma2 != -1 && $comma1 != -1) { # issue 114 # issue 114: substr(this, start, length, replacement) #my $comma = next_same_level_token(',', $start, $end_pos); my $comma = $comma1; if($comma < 0) { $TrStatus=-1; return -255; } my $this_p = $start; # _substr returns a tuple with (new_this, result) # (this:=(_s:=_substr(this, start, length, replacement))[0], _s)[1][1] # Code only works if "this" is a scalar and not a global if($this_p + 1 != $comma) { logme('S',"substr with replacement is not implemented on complex variable"); $TrStatus=-1; return -255; } elsif(index($ValPy[$this_p], '.') >= 0) { logme('S',"substr with replacement is not implemented on package global variables"); $TrStatus=-1; return -255; } $Pyf{_substr} = 1; gen_chunk('(', $ValPy[$this_p], ':=', '(', $SUBSCRIPT_TEMP, ':=', '_substr', '('); $TrStatus = expression($start, $end_pos, 0); gen_chunk(')', ')', '[0]', ',', $SUBSCRIPT_TEMP, ')', '[1]', '[1]'); return $limit+1; } # more complex case with varibles or expression in iether second or the third arguments #step1 -- generate varible from which substing is extracted (can be an expression) # issue s271 if( substr($TokenStr,$start+1,1) eq ',' ){ if( substr($TokenStr,$start+1,1) =~ /[,A]/) { # issue s271 # Simplest case -- scalar varaible or constant is used gen_chunk($ValPy[$start]); # a simple first arg -- the name of the variable or a string $split=$start+1; }else{ # issue s271 $split=next_same_level_token(',',$start,$end_pos); $split=next_same_level_tokens(',A',$start,$end_pos); # issue s271 if( $split==-1 ){ $TrStatus=-1; return -255 } $k=expression($start,$split-1,0); return -255 if ($k<0); } # # Processing of thesecond arg -- starting position. Can beconstant or expression # gen_chunk('['); # opening bracket if( substr($TokenStr,$split,4) =~ /^,(\-?)d[),]/){ # issue bootstrap $arg1=( length($1)==1) ? -$ValPy[$split+2] : $ValPy[$split+1]; # issue 130: $arg1=$ValPy[$split+1]; } #determine if there are two or three argument # issue s271 $split2=next_same_level_token(',',$split+1,$end_pos); $split2=next_same_level_tokens(',A',$split+1,$end_pos); # issue s271 if( $split2>-1 ){ # substr($line,$start,$lenth) -- the third argumant is present my $temp = capture_expression_value_if_needed($split+1,$split2-1); # issue substr/incr/decr $k=expression($split+1,$split2-1,0); # generate the secong arg return -255 if ($k<0); gen_chunk(')') if($temp); # issue substr/incr/decr if( $end_pos-$split2==1 && $ValClass[$end_pos] eq 'd'){ #positive length $arg2=$ValPy[$end_pos]; if (0 && $ValPy[$split2+1] == 1 ){ # issue 130 - we can never use subscript because at end it gives IndexError gen_chunk(']'); # substr($line,$a,1) -- the third arg is 1 return $limit+1; } gen_chunk(':'); if( defined($arg1) ){ # rescn first arg and add the second if ($arg1==0){ gen_chunk($arg2); }else{ $arg2=$arg1+$arg2; gen_chunk($arg2) if $arg2 != 0 && ($arg1 >= 0 || $arg2 < 0); # issue bootstrap } }else{ $k=regenerate_expression($split+1,$split2-1,0,$temp); # issue substr/incr/decr, issue 130: generate the second arg # issue 130: $k=expression($split2+1,$end_pos,0); gen_chunk("+$arg2"); } gen_chunk("]"); }elsif( $end_pos-$split2==2 && substr($TokenStr,$split2,3) eq ',-d' ){ # third arg is negative constant. Can be used directly. gen_chunk(':'); $arg2=-$ValPy[$end_pos]; gen_chunk("$arg2]"); }else{ # general case of the third argument -- need to rescan the first and add the second gen_chunk(':'); if (defined($arg1)){ gen_chunk("$arg1+"); $k=expression($split2+1,$end_pos,0); gen_chunk(']'); }else{ $k=regenerate_expression($split+1,$split2-1,0,$temp); # issue substr/incr/decr: generate second argument again return -255 if ($k<0); gen_chunk("+"); $k=expression($split2+1,$end_pos,0); return -255 if ($k<0); gen_chunk(']'); } } }else{ # substr($line,$start) $k=expression($split+1,$end_pos,0); return -255 if ($k<0); gen_chunk(':]'); } }elsif( $perl_name eq 'index' || $perl_name eq 'rindex' ){ # index(text,'search',from) # 0 1 2 3 4 # string.find(text, substr, start) # issue s271 if( $ValClass[$start+1] eq ',' ){ if( $ValClass[$start+1] =~ /[,A]/) { # issue s271 # Simplest case -- scalar varaible is used gen_chunk("$ValPy[$start]$py_name("); # line.find -- .find is now in scannet table Nov 15, 2019 --NNB # issue 104 $split=$start+2; $split=$start+1; # issue 104 }else{ # issue s271 $split=next_same_level_token(',',$start,$end_pos); # next comma on the same nesting level $split=next_same_level_tokens(',A',$start,$end_pos); # next comma on the same nesting level, issue s271 # issue 104 $k=expression($start+2,$split-1,0); $k=expression($start,$split-1,0); # issue 104 return -255 if ($k<0); # issue 104 gen_chunk("$ValPy[$start]("); # .find and opening bracket gen_chunk("$py_name("); # .find and opening bracket # issue 104 } # issue s271 $split2=next_same_level_token(',',$split+1,$end_pos); $split2=next_same_level_tokens(',A',$split+1,$end_pos); # issue s271 # processing string to find if( $split2>-1 ){ # index($line,$string,$start) if( $split+2==$split2 ){ gen_chunk($ValPy[$split+1]); }else{ $k=expression($split+1,$split2-1,0); return -255 if ($k<0); } gen_chunk(','); $k=expression($split2+1,$end_pos,0); return -255 if ($k<0); gen_chunk(')'); }else{ # index($line,'xxx') -> line.find('xxx') # issue 104 $k=expression($split,$end_pos,0); $k=expression($split+1,$end_pos,0); # issue 104 return -255 if ($k<0); gen_chunk(')'); } }elsif( $perl_name eq 'join' ){ # issue 40 $args=join(' ',@ARGS) => args=ARGS.join(' '); # $args=join(' ',@ARGS) => args=' '.join(ARGS) # issue 40 # issue s271 $split=next_same_level_token(',',$start,$end_pos); $split=next_same_level_tokens(',A',$start,$end_pos); # issue s271 # issue 40 if($end_pos-$split==1 ){ if($split < 0) { # issue 40 - no ",list" is present # the second argument is not expression or function # issue 40 gen_chunk($ValPy[$end_pos],$py_name); # gen array.join(''); gen_chunk("''"); # issue 40 - join with no expr is an empty string }else{ # issue 40 # issue 40 $TrStatus=expression($split+1,$end_pos); # issue 40 return $TrStatus if ($TrStatus<0); # issue 40 gen_chunk($py_name); # gen .join # issue 40 } if( $split-$start==1 ){ # issue 40 gen_chunk($ValPy[$start].')'); # gen delimiter gen_chunk($ValPy[$start]); # issue 40: gen delimiter }else{ # issue s255 $TrStatus=expression($start,$split-1); $TrStatus=expression($start,$split-1, 1); # issue s255: Put parens around it! return $TrStatus if ($TrStatus<0); } gen_chunk($py_name); # issue 40: gen .join( my $mapped = 1; if(&Pythonizer::expr_type($split+1, $end_pos, $CurSub) eq 'a of S') { $mapped = 0; } gen_chunk('map(_str, ') if($mapped); # SNOOPYJC if($end_pos-$split==1) { # issue 40: one thing (a list) gen_chunk($ValPy[$end_pos]); # issue 40: arr } else { # issue 40: Multiple things: make them into a tuple by adding an extra set of parens gen_chunk('('); # issue 40 # issue s252 $TrStatus=expression($split+1,$end_pos); # issue 40 if(is_list($split+1, $end_pos)) { # issue s252: We have multiple items $TrStatus=expression($split+1,$end_pos,2); # issue 40, issue s252: Gen splats if need be } else { $TrStatus=expression($split+1,$end_pos,0); # issue 40 } return $TrStatus if ($TrStatus<0); # issue 40 gen_chunk(')'); # issue 40 } gen_chunk(')') if($mapped); # SNOOPYC: End of map gen_chunk(')'); # issue 40 } # issue 40 }elsif( $perl_name eq 'open' ){ $TrStatus=open_fun($begin,$end_pos,'f'); # open like function, for example in if return -255 if( $TrStatus < 0 ); }elsif( $perl_name eq 'opendir' ){ # SNOOPYJC: $TrStatus=open_dir($begin,$end_pos,'f'); # open like function, for example in if return -255 if( $TrStatus < 0 ); }elsif( $perl_name eq 'exists' ){ # applicable to the elemnt of hash only $k=$start; if( $ValClass[$k] eq 's') { # issue 91 $dict=$ValPy[$k]; # issue 91 $k+=2; return -255 if($ValClass[$end_pos] ne ')'); my $key_start = reverse_matching_br($end_pos); if ( $debug > 4 ) { say STDERR "exists k=$k, key_start=$key_start, length(ValPerl)=$#ValPerl, end_pos=$end_pos, limit=$limit\n"; } # issue 91 if( $k+1<=$#ValPerl && $k+1==$end_pos ) { # issue 91 #single token between {} # issue 91 if( $ValClass[$k] eq 's' || $ValClass[$k] eq '"' || $ValClass[$k] eq "'"){ # issue 91 gen_chunk("$ValPy[$k] in $dict"); # issue 91 # issue parens return $k+3; # you need to skip two closing brackets: }) # issue 91 return (($bracketed == 1) ? $k+3 : $k+2); # you need to skip one or two closing brackets: }) # issue parens # issue 91 } # issue 91 return -255; # issue 91 }else{ # issue 91 $k=expression($k-1,$limit,1); #preserve brackets $k=expression($key_start+1,$end_pos-1,0); # issue 91 return -255 if ($k<0); if($ValPerl[$key_start] eq '[') { # array exists gen_chunk('<', 'len', '('); $k=expression($start,$key_start-1,0); return -255 if ($k<0); gen_chunk(')'); } else { gen_chunk('in'); # issue 91 $ValPy[$start] = "$DEFAULT_MATCH.groupdict()" if $ValPy[$start] eq "$DEFAULT_MATCH.group"; # issue s342: %+ $k=expression($start,$key_start-1,0); # issue 91 return -255 if ($k<0); } # issue 91} }else{ return -255 } }elsif(substr($perl_name,0,1) eq '-') { #file predicate, always one agument gen_chunk($py_name, '('.$ValPy[$start].')'); return $start+2 if $bracketed == 1; # issue s162 return $start+1; # issue 19 }elsif( $perl_name eq 'split' ){ $k=$start; # pos of the first arg if ($bracketed==-1 || # issue s52 $k > $#ValClass || ($bracketed==1 && $ValPerl[$k] eq ')')){ # SNOOPYJC: handle ... = split; # special case of splitting default varible on white space # issue split gen_chunk("default_var.split(' ')"); if($py_name =~ /_s$/) { # issue s52: Scalar version gen_chunk("len(${DEFAULT_VAR}.split())"); # issue s52 } elsif($autovivification) { # issue s359 $Pyf{Array} = 1; gen_chunk('Array', '(', "${DEFAULT_VAR}.split()", ')'); # issue s359 } else { gen_chunk("${DEFAULT_VAR}.split()"); # issue split - split on white space, issue 32 } # SNOOPYJC return $end_pos+1; return $limit+1; # SNOOPYJC } $arg1=$ValPy[$k]; # first argument is present $arg1type=$ValClass[$k]; if($arg1type eq 'f' && $arg1 eq $CONVERTER_MAP{S} && $ValClass[$k+2] eq 'q') { # issue s52: _str(qr/.../) # issue s52: Just ignore the converter in this case $arg1 = $ValPy[$k+2]; $arg1type = $ValClass[$k+2]; $k += 3; } $flags = ''; # issue 21 if($arg1type ne '"' && $k+1 <= $#ValClass && $ValClass[$k+1] eq 'i') { # issue 21: we have FLAGS! $k++; foreach my $flag (split(//,$ValPerl[$k])) { next if($flag eq 'g'); # 'g' flag is meaningless here $flags .= '|re.'.uc($flag); } $flags =~ s/^\|/, flags=/; } # issue s207 if(($k+1) > $#ValClass || $ValPerl[$k+1] ne ','){ # SNOOPYJC # issue s271 my $comma = next_same_level_token(',', $k, $end_pos); # issue s207 my $comma = next_same_level_tokens(',A', $k, $end_pos); # issue s207, issue s271 if(($k+1) > $end_pos || $comma < 0){ # issue s207 # special case of splitting degaqult varible on white space # issue 21 if( $arg1 eq ' ' || $arg1type eq '"' ){ if( $arg1type eq '"' ){ # issue 21: string $arg1 ='' if($arg1 eq "' '"); # issue 21: string of ' ' is a special case if($py_name =~ /_s$/) { # issue s52: Scalar version gen_chunk("len(${DEFAULT_VAR}.split($arg1))"); # issue 32, issue s52 } elsif($autovivification) { # issue s359 $Pyf{Array} = 1; gen_chunk('Array', '(', "${DEFAULT_VAR}.split($arg1)", ')'); # issue s359 } else { gen_chunk("${DEFAULT_VAR}.split($arg1)"); # issue 32 } } elsif($autovivification) { $Pyf{Array} = 1; gen_chunk('Array', '(', $py_name,"($arg1, $DEFAULT_VAR$flags))"); # this is a regex function # issue s359 }else{ # issue 21 gen_chunk($py_name,"($arg1,default_var"); # this is a regex function gen_chunk($py_name,"($arg1, $DEFAULT_VAR$flags)"); # this is a regex function # issue 21, issue 32 } # SNOOPYJC return $end_pos+1; return $limit+1; # SNOOPYJC } if($comma != $k+1) { # issue s207: Have a complex expression as the split pattern $arg1 = $k; # issue s207 $arg1type = 'expr'; # issue s207 $k = $comma+1; # issue s207 } else { $k+=2; # $k now points to the start of the second argument } my $add_paren = 0; if( $k==$end_pos ){ $arg2=$ValPy[$k]; $k+=1; # issue 21 if( $arg1 eq ' ' || $arg1type eq '"' ){ # issue 21 gen_chunk("$arg2.lstrip($arg1"); if( $arg1type eq '"' ){ # issue 21 $arg1 ='' if($arg1 eq "' '"); # issue 21: string of ' ' is a special case if($py_name =~ /_s$/) { # issue s52: Scalar version $add_paren = 1; # issue s52 gen_chunk("len($arg2.split($arg1"); # issue s52 } elsif($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 expression($end_pos,$end_pos,0); # issue s359 gen_chunk(".split($arg1"); # issue s359 } else { # issue s118: Split of the result of a command execution never runs the command expression($end_pos,$end_pos,0); # issue s118 gen_chunk(".split($arg1"); # issue 21, issue s118 # issue s118 gen_chunk("$arg2.split($arg1"); # issue 21 } }elsif($arg1type eq 'expr') { # issue s207 if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name, '('); # issue s207 $TrStatus = expression($arg1, $comma-1, 0); # issue s207 gen_chunk(',', "$arg2$flags"); # issue s207 }else{ if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name,"($arg1,$arg2$flags"); # issue 21: this is a regex function } # issue s271 }elsif( ($split=next_same_level_token(',',$k+1,$end_pos))>-1 ){ }elsif( ($split=next_same_level_tokens(',A',$k+1,$end_pos))>-1 ){ # issue s271 #we have third argument to split if($arg1type eq '"') { # issue 21 if($py_name =~ /_s$/) { # issue s52: Scalar version $add_paren = 1; # issue s52 gen_chunk('len('); } elsif($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } $k=expression($k,$split-1); # issue 21 if($arg1 eq "' '") { # issue 21: string of ' ' is a special case gen_chunk(".split(maxsplit="); # issue 21 } else { gen_chunk(".split($arg1,"); # issue 21 } } elsif($arg1type eq 'expr') { # issue s207 if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name, '('); # issue s207 $TrStatus = expression($arg1, $comma-1, 0); # issue s207 gen_chunk(','); # issue s207 $k=expression($k,$split-1); return -255 if($k<0); gen_chunk(','); } else { if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name,"($arg1,"); $k=expression($k,$split-1); return -255 if($k<0); gen_chunk(','); } $k=expression($split+1,$end_pos,0); return -255 if($k<0); gen_chunk("-1"); # issue 21: # of times to split is different in python gen_chunk($flags) if($flags); # issue 21 }elsif($arg1type eq '"') { # issue 21: Expression with string pattern and 2 args if($py_name =~ /_s$/) { # issue s52: Scalar version $add_paren = 1; # issue s52 gen_chunk('len('); } elsif($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } $k=expression($k,$end_pos); # issue 21 $arg1 ='' if($arg1 eq "' '"); # issue 21: string of ' ' is a special case gen_chunk(".split($arg1"); # issue 21 } elsif($arg1type eq 'expr') { # issue s207 if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name, '('); # issue s207 $TrStatus = expression($arg1, $comma-1, 0); # issue s207 gen_chunk(','); # issue s207 $k=expression($k,$end_pos); # issue s207 gen_chunk($flags) if($flags); # issue s207 }else{ # issue 21: Expression with regex pattern and 2 args if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $add_paren = 1; # issue s359 } gen_chunk($py_name,"($arg1,"); # issue 21 $k=expression($k,$end_pos); # issue 21 gen_chunk($flags) if($flags); # issue 21 } gen_chunk(')') if($add_paren); # issue s52 gen_chunk(')'); }elsif($perl_name eq 'print' || $perl_name eq 'printf' || $perl_name eq 'say') { # issue s152 $TrStatus=print3($begin, $limit); # in Python3 this is a function # issue s278: Add $limit if ($TrStatus<0) { return -255; } }elsif($perl_name eq 'warn') { # issue s152 # issue s288 $TrStatus=print3($begin, $limit, 'sys.stderr'); # in Python3 this is a function, issue s152 $Pyf{_warn} = 1; # issue s288 gen_chunk('_warn', '('); # issue s288 $TrStatus = expression($start, $end_pos, 2) if $start <= $end_pos; # issue s288 gen_chunk(')'); # issue s288 }elsif($perl_name eq 'die') { # issue s292 $Pyf{_die} = 1; # issue s292 gen_chunk('_die', '('); # issue s292 $TrStatus = expression($start, $end_pos, 2) if $start <= $end_pos; # issue s292 gen_chunk(')'); # issue s292 }elsif(($perl_name eq 'unlink' || $perl_name eq 'readlink') && $bracketed == -1) { # issue s94, issue s128 gen_chunk($py_name, '(', $DEFAULT_VAR, ')'); # issue s94 }elsif($perl_name eq 'defined' ) { # open used without parantethisi. always has one argument $k=$start; # issue 25 gen_chunk("$ValPy[$k] != none"); if($k+1 <= $#ValClass && $ValClass[$k+1] eq '(' && $ValPerl[$k+1] ne '(') { # issue 25 - array element or hash value $e = end_of_variable($start); # issue 25 addl fix, SNOOPYJC if($ValClass[$e] eq ')' && $ValPerl[$e] eq ']') { # issue s3 # issue s3: Array index - don't do a hard reference - use our .get() instead so we don't make the element appear # out of nowhere if autovivification is enabled. my $s = reverse_matching_br($e); if($ValClass[$s-1] eq 's' && $ValPerl[$s-1] eq '$_') { # handle varargs as a special case - it has no '.get()' #gen_chunk("($2 < len($1) and $ValPy[$k] is not None)"); # issue s3 - constant case is handled below gen_chunk('('); expression($s+1, $e-1, 0); # gen the subscript gen_chunk('<', 'len(', $ValPy[$s-1], ')', 'and'); $k = expression($k, $e, 0); gen_chunk('is', 'not', 'None', ')'); } elsif($autovivification) { $k = expression($k, $s-1, 0); # gen the prefix gen_chunk('.get('); $is_const = 0; if($ValClass[$s+1] eq '-' && $ValClass[$e-1] eq 'd' && ($e-1)-($s+1) == 1) { # negative constant gen_chunk('len('); expression($start, $s-1, 0); # gen the variable minus the last subscript gen_chunk(')'); $is_const = 1; } elsif($ValClass[$s+1] eq 'd' && ($e-1)-($s+1) == 0) { $is_const = 1; } $k = expression($s+1, $e-1, 0); # gen the subscript $k++; if(!$is_const) { gen_chunk('if'); expression($s+1, $e-1, 0); # gen the subscript again gen_chunk('>=', '0', 'else'); gen_chunk('len('); expression($start, $s-1, 0); # gen the variable minus the last subscript gen_chunk(')', '+'); expression($s+1, $e-1, 0); # gen the subscript again } gen_chunk(')'); gen_chunk('is', 'not', 'None'); } else { $k = expression($k, $e, 0); gen_chunk('is', 'not', 'None'); } } else { $k = expression($k, $e, 0); # issue 25 gen_chunk('is', 'not', 'None'); # issue 25 again } } elsif( $bracketed==-1 ){ # SNOOPYJC gen_chunk("$DEFAULT_VAR is not None"); return $start; } elsif($ValClass[$k] =~ /[ah]/) { # SNOOPYJC: Old perl allowed this logme('W',"'defined $ValPerl[$k]' is no longer allowed in perl - translated to bool($ValPy[$k])"); # SNOOPYJC gen_chunk("bool($ValPy[$k])"); # SNOOPYJC } elsif($ValClass[$k] eq 'i' && ($k+1 > $#ValClass || $ValClass[$k+1] ne '(')) { # SNOOPYJC: sub or FH if(substr($ValPy[$k],0,4) eq 'sys.') { gen_chunk("True"); # We know it's defined if it's like sys.stdin or something } elsif($k+2 <= $#ValClass && $ValClass[$k+1] eq 'D' && $ValClass[$k+2] eq 'i') { # defined fh->autoflush or something like that gen_chunk("hasattr($ValPy[$k], '$ValPy[$k+2]')"); $Pyf{_autoflush} = 1 if($ValPerl[$k+2] eq 'autoflush'); return $k+3; } elsif($ValPy[$k] =~ /^$PERLLIB\.get_subref\(/ || $ValPy[$k] =~ /^_get_subref\(/) { # issue s229 gen_chunk($ValPy[$k], 'is not None'); # issue s229 } elsif(index($ValPy[$k], '.') >= 0) { # Package.func my @pieces = split /[.]/, $ValPy[$k]; gen_chunk('(hasattr(builtins', ',', "'$pieces[0]'", ')'); for(my $i = 1; $i < scalar(@pieces); $i++) { gen_chunk('and', 'hasattr('); for(my $j = 0; $j < $i; $j++) { gen_chunk('.') if($j != 0); gen_chunk($pieces[$j]); } gen_chunk(',', "'$pieces[$i]'", ')'); } gen_chunk(')'); } elsif(&Perlscan::in_sub()) { gen_chunk("('$ValPy[$k]' in globals() or '$ValPy[$k]' in locals())"); } else { gen_chunk("'$ValPy[$k]' in globals()"); } return ($bracketed == 1 ? $k+2 : $k+1); } elsif($ValClass[$k] eq 'f' && ($k+1 > $end_pos || $ValClass[$k+1] ne '(')) { #gen_chunk("(hasattr(builtins, '$ValPy[$k]') and callable($ValPy[$k]))"); # # SNOOPYJC: If this is a function with no arguments, then call it and # see if the result is defined: e.g. __SUB__ # my $ft = undef; if(exists $PyFuncType{$ValPy[$k]}) { $ft = $PyFuncType{$ValPy[$k]}; } elsif(exists $FuncType{$ValPerl[$k]}) { $ft = $FuncType{$ValPerl[$k]}; } if(defined $ft) { my $arg0_type = substr($ft,0,1); if($arg0_type eq ':' || $arg0_type eq '') { if( !exists $Pyf{$ValPy[$k]} ) { if( -e "$Pyf_dir/$ValPy[$k].py" ) { $Pyf{$ValPy[$k]} = 1; #Include the module } } gen_chunk($ValPy[$k],'()', 'is', 'not', 'None'); } elsif($ValPerl[$k] eq 'undef') { # issue s254 gen_chunk("False"); # issue s254 } else { gen_chunk("True"); } } else { gen_chunk("True"); # We know it's an existing function if we classify it as such } } elsif($ValClass[$k] eq 's' && substr($ValPy[$k],0,length($DEFAULT_MATCH)+1) eq "$DEFAULT_MATCH.") { # issue bootstrap: defined $1 if($ValPy[$k] eq "$DEFAULT_MATCH.group(0)" || $ValPy[$k] =~ /$DEFAULT_MATCH\.string/) { # $&, $` or $' gen_chunk($DEFAULT_MATCH, ' is not None'); } elsif($ValPy[$k] =~ /$DEFAULT_MATCH\.(?:group|start|end)\((\d)\)/) { gen_chunk("($DEFAULT_MATCH is not None and $1 <= len($DEFAULT_MATCH.groups()))"); } return ($bracketed == 1 ? $k+2 : $k+1); # issue s359 } elsif($ValClass[$k] eq 's' && $ValPerl[$k] eq '$_' && $ValPy[$k] =~ /^(\w+)\[(\d+)\]$/) { # issue s3: defined $_[1] } elsif($ValClass[$k] eq 's' && $ValPerl[$k] eq '$_' && $ValPy[$k] =~ /^(\w+)(?:(?:\.get\()|\[)(\d+)/) { # issue s3: defined $_[1], issue s359 # issue s3: In this case, we also need to see if this arglist element exists (perl does that automatically) gen_chunk("($2 < len($1) and $ValPy[$k] is not None)"); # issue s3 } else { # issue 25 # Special case for read if($bracketed == 1 && $end_pos+2 <= $#ValClass && $ValClass[$end_pos+2] eq 'y') { $k=expression($k-1,$end_pos+2,0); # issue 25 return $k+1; } elsif(end_of_variable($k) == $end_pos) { # if there is only one variable, skip the parens $k=expression($k,$end_pos,0); } else { $k=expression($k,$end_pos,1); # issue 25, SNOOPYJC: Keep it in parens since we don't know the precidence of the operators vs "is" } gen_chunk(' is not None'); # issue 25 #gen_chunk("$ValPy[$k] is not None"); # issue 25 } # issue 25 $k=($k+1<=$#ValPerl && $ValPerl[$k+1] eq ')') ? $k+2 : $k+1; }elsif($perl_name eq 'unshift' ){ # unshift ARRAY,LIST # arrayOrList.insert(0 , element) $k=$start; # issue 38 gen_chunk($ValPy[$k],$py_name,$ValPy[$k+2],')'); # issue 38 $k=($k+3<=$#ValPerl && $ValPerl[$k+3] eq ')') ? $k+4 : $k+3; # issue s271 my $comma = next_same_level_token(',',$start,$end_pos); # issue 38 my $comma = next_same_level_tokens(',A',$start,$end_pos); # issue 38, issue s271 return -255 if $comma<0; # issue 38 if ($debug > 4) { say STDERR "unshift $ValClass[$comma+1]\n"; } $slice = '[0:0]'; # issue 66 # issue 66: fix unshift into @ARGV for the test if($k == $comma-1 && substr($ValPy[$k],-4,4) eq '[1:]') { # issue 66 like sys.argv[1:] substr($ValPy[$k],-2,2) = ':0]'; # issue 66 $slice = ''; # issue 66 } # issue 66 my $t=expression($k,$comma-1,0); # issue 38 Gen the LHS return -255 if $t<0; # issue 38 if( $ValClass[$comma+1] eq 'a' ){ # issue 38 gen_chunk("$slice = ",$ValPy[$comma+1]); # unshift(@x,@y) }elsif($ValClass[$comma+1] eq '(' ){ gen_chunk("$slice = ["); my $close = ''; if($autovivification && $ValPerl[$comma+1] eq '[') { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $close = ')'; # issue s359 } elsif($autovivification && $ValPerl[$comma+1] eq '{') { # issue s359 $Pyf{Hash} = 1; # issue s359 gen_chunk('Hash', '('); # issue s359 $close = ')'; # issue s359 } gen_chunk($ValPy[$comma+1]) unless $ValPy[$comma+1] eq '('; # issue s359 $k=expression($comma+2,$end_pos-1,0); # issue 38 gen_chunk($ValPy[$end_pos]) unless $ValPy[$end_pos] eq ')'; # issue 38, issue s359 gen_chunk($close) if $close; # issue s359 gen_chunk(']'); # issue 38 }elsif(index("sd-\"", $ValClass[$comma+1]) >= 0 || ($ValClass[$comma+1] eq 'i' && $comma+1 == $#ValClass) || $ValClass[$comma+1] eq "\\") { # issue 38: scalar, or address of gen_chunk("$slice = ["); # issue 38 $k=expression($comma+1,$end_pos,0); # issue 38 gen_chunk(']'); # issue 38 }else{ gen_chunk("$slice = "); # issue 38 $Pyf{"_make_list"} = 1; # issue 38 gen_chunk('_make_list', '('); # issue 38 $k=expression($comma+1,$end_pos,0); # issue 38 gen_chunk(')'); # issue 38 } # issue 28 }elsif($perl_name eq 'shift' ){ }elsif($perl_name eq 'shift' || $perl_name eq 'pop'){ # issue 28 # assent only a single arg -- array; if no argument then it uses @_ array # $bracketed=-1 if($bracketed!=-1 && index('>0o+-*/',$ValClass[$start]) >= 0); # issue 28: pop has no arg if the next thing is an operator $bracketed=-1 if($bracketed!=-1 && index('>0o+-*/D',$ValClass[$start]) >= 0); # issue 28: pop has no arg if the next thing is an operator, issue s268: add 'D' if($bracketed == 0 && $ValClass[$begin+1] eq '(' && $ValPerl[$begin+1] ne '(') { # issue s212 $bracketed = -1; # issue s212 $start = $begin+1; # issue s212 $limit = $begin; # issue s212 } # issue s212 if($bracketed == 0 && $ValClass[$start] eq 'a' && $end_pos > $start && ($ValClass[$start+1] eq ',' || $ValClass[$start+1] eq 'A')) { # issue s208, issue s271 $end_pos=$limit=$start; # issue s208: end_of_function is not correct as it doesn't know the difference between an array and a list } # issue s208 if( $bracketed==-1 || ($bracketed == 1 && $start > $end_pos)){ # issue s193 # issue 28 gen_chunk("perl_arg_array$py_name"); # issue s155 if($CurSub eq '__main__' || substr($CurSub, 0, 7) eq '__END__') { # issue 24 if($CurSub eq '__main__' || special_code_block_name($CurSub)) { # issue 24, issue s155 if($perl_name eq 'shift') { gen_chunk("(sys.argv.pop(1) if len(sys.argv)>1 else None)"); # issue 24 } else { gen_chunk("(sys.argv.pop() if len(sys.argv)>1 else None)"); # issue 24 } } else { gen_chunk("($PERL_ARG_ARRAY$py_name if $PERL_ARG_ARRAY else None)"); # issue 28, issue 32 } return $limit+1 if($bracketed == 1); # issue s193 return $start; # issue 28 # issue 28 }elsif( $end_pos==$start ){ } elsif($ValPerl[$start] eq '@ARGV') { # issue 24/bootstrapping - handle "shift @ARGV" if($perl_name eq 'shift') { # issue s291 gen_chunk("(sys.argv.pop(1) if len(sys.argv)>1 else None)"); # issue s291 } else { gen_chunk("(sys.argv.pop() if len(sys.argv)>1 else None)"); # issue s291 } return $limit+1 if($bracketed == 1); # issue parens return $start+1; # issue 28 } else { # issue 28 # issue 28 gen_chunk($ValPy[$start],$py_name); # issue s154 gen_chunk('(',$ValPy[$start],$py_name,"if",$ValPy[$start],"else", "None)"); # issue 28 gen_chunk('('); # issue s154: Handle expression in pop/shift operation $k = expression($start, $end_pos, 0); # issue s154 gen_chunk($py_name, 'if'); # issue s154 expression($start, $end_pos, 0); # issue s154 gen_chunk('else', 'None', ')'); # issue s154 return $limit+1 if($bracketed == 1); # issue parens # issue s154 return $start+1; # issue 28 # return $k+1; # issue 28, issue s154 return $k; # issue 28, issue s154, issue s208 # issue 28 }else{ # issue 28 return -255; } }elsif($perl_name eq 'mkdir' && $bracketed==-1) { # SNOOPYJC gen_chunk("$py_name", "($DEFAULT_VAR)"); return $start; }elsif($perl_name eq 'ord' || $perl_name eq 'chr' || $perl_name eq 'quotemeta') { # issue 59, SNOOPYJC my $prefix = '('; # issue s70 my $suffix = ')'; # issue s70 if($Pythonizer::f_encoding && $Pythonizer::f_encoding ne 'utf8') { # issue s70 if($perl_name eq 'ord') { # issue s70 $py_name = 'bytes'; # issue s70 $suffix = ", encoding='$Pythonizer::f_encoding', errors='ignore')[0]"; # issue s70 } elsif($perl_name eq 'chr') { # issue s70 $py_name = 'str(bytes(['; # issue s70 $prefix = ''; $suffix = "]), '$Pythonizer::f_encoding', errors='ignore')"; # issue s70 } # issue s70 } # issue s70 if( $bracketed==-1 ){ gen_chunk("$py_name", "($DEFAULT_VAR)"); return $start; # issue 28 } # issue s70 gen_chunk("$py_name", '('); gen_chunk("$py_name"); # issue s70 gen_chunk($prefix) if $prefix; # issue s70 $k=expression($start,$end_pos,0); return -255 if $k<0; # issue s70 gen_chunk(')'); gen_chunk($suffix); # issue s70 return $limit+1; }elsif($perl_name eq 'oct' || $perl_name eq 'hex') { # issue 59, SNOOPYJC my $base = (($perl_name eq 'oct') ? 8 : 16); if( $bracketed==-1 ){ gen_chunk("$py_name", "($DEFAULT_VAR, $base)"); return $start; # issue 28 } gen_chunk("$py_name", '('); $k=expression($start,$end_pos,0); return -255 if $k<0; gen_chunk(',', $base); gen_chunk(')'); return $limit+1; }elsif(($perl_name eq 'stat' || $perl_name eq 'lstat') && !$uses_file_stat) { # SNOOPYJC: old stat/lstat $Constants{_} = 1; if( $bracketed==-1 ){ if($begin == 0) { gen_chunk('_ = ', "$py_name", "($DEFAULT_VAR)"); } else { gen_chunk('(_:=', "$py_name", "($DEFAULT_VAR))"); } return $start; # issue 28 } if($begin == 0) { gen_chunk("_ = ", "$py_name", '('); } else { gen_chunk('(_:=', "$py_name", '('); } $k=expression($start,$end_pos,0); return -255 if $k<0; gen_chunk(')'); gen_chunk(')') if($begin != 0); return $limit+1; }elsif($perl_name eq 'pos') { # SNOOPYJC # pos($scalar) # pos $scalar # We assume the scalar is matched by the last match object gen_chunk("$DEFAULT_MATCH.end()"); return $limit+1; }elsif($perl_name eq 'select') { # SNOOPYJC # select FILEHANDLE # select # # Returns the currently selected filehandle. If FILEHANDLE is supplied, sets the new current default filehandle for output. if( $bracketed==-1 ){ if($begin == 0) { if($Pythonizer::CurNest) { output_line('pass',' #SKIPPED: '.$line); } else { output_line('','#SKIPPED: '.$line); } } else { gen_chunk('sys.stdout') } } else { if($ValPy[$start] eq 'sys.stdout') { replace($start, 'd', $ValPerl[$start], 'sys.__stdout__'); # issue test coverage } if($begin == 0) { gen_chunk('sys.stdout', '='); $k=expression($start,$end_pos,0); return -255 if $k<0; } else { $Pyf{_select} = 1; # issue test coverage gen_chunk('_select', '('); $k=expression($start,$end_pos,0); return -255 if $k<0; gen_chunk(')'); } } }elsif($perl_name eq 'grep' || $perl_name eq 'map') { # issue 60 # grep expr, @arr # grep /pat/, @arr # grep !/pat/, @arr # issue s153 # grep(expr, @arr) # grep(expr, list, ...) # grep(/pat/, @arr) # map f, @arr # map(f, @arr) # map(f, list, ...) # map{block} @arr (or list) # grep{block} @arr (or list) if($bracketed == 0 && $ValClass[$begin+1] eq '(') { # issue s3: We use the old definition of bracketed $bracketed=1; $limit=matching_br($begin+1); $start=$begin+2; # function call with normal pathethis if( $ValClass[$limit] eq ')' ){ $end_pos=$limit-1; } } $k=$start; my $add_close_paren = 0; # issue 37 my $context = -1; if($py_name =~ /_s$/) { # issue 37: filter_s or map_s is just a flag to tell us we're in scalar context $context = 0; # scalar substr($py_name,-2,2) = ''; } else { $context = list_or_scalar_context($begin, $start); # issue 37 } if($context == 0) { # issue 37: scalar context # If this is used in an if statement and we don't use the value, then we don't need the len function if((($ValClass[0] eq 'c' && ($ValPerl[0] eq 'if' || $ValPerl[0] eq 'unless')) || ($ValClass[0] eq 'C' && $ValPerl[0] eq 'elsif')) && ($begin == 0 || $ValClass[$begin-1] ne '=')) { ; } else { if(scalar(@Perlscan::PythonCode) && $Perlscan::PythonCode[-1] eq '*') { # issue 37: if we just generated a splat, eat it, issue s129 $#Perlscan::PythonCode--; } gen_chunk('len('); # issue 37 $add_close_paren = 1; # issue 37 } } my $need_bracket = 0; # issue s205: if($perl_name eq 'map' && index(substr($TokenStr, $start, $end_pos+1-$start), 'A') >= 0) { if($perl_name eq 'map' && $ValPerl[$start] ne '[') { # issue s205: Usually flatten (doesn't hurt unless we have an [arrayref]) # Check for the hash production idiom "%hash = map { $_ => 1 } @arr;", then we need to flatten # the result and put brackets on the RHS of the lambda. In the assignment it will be converted to a hash. # issue s346: Also handle map { $_, 1 } @arr; my $pA; if(($pA = next_same_level_token('A', $start, $end_pos)) != -1) { $need_bracket = 1; $ValPy[$pA] = ','; # Change it to an array } elsif($ValClass[$start] eq 's' && $ValPerl[$start] eq '$_' && $end_pos-$start == 2 && $ValClass[$start+1] eq ',' && $ValClass[$start+2] eq 'd') { # issue s346: map { $_ , 1 } @arr $need_bracket = 1; replace($start+1, 'A', '=>', ','); # issue s346 } $Pyf{_flatten} = 1; gen_chunk('_flatten', '('); } else { gen_chunk('list('); # filter or map, convert to list so we can use len and subscript } # issue s135: If this is grep { s/this/that/ } @arr -or- grep { tr/this/that/ }, @arr # then we need to map and filter at the same time, so we switch to using a perllib function for that. The # code that handles the substitute (which is a function 're') or translate (a function 'tr') checks # for this case too and doesn't split out the result of _substitute_and_count() or _translate_and_count(), # but passes it directly to our perllib function. if($ValClass[$start] eq 'f' && $ValPerl[$start] =~ /^(?:re|tr)$/ && $perl_name eq 'grep') { # issue s135 $Pyf{_filter_map} = 1; # issue s135 $py_name = '_filter_map'; # issue s135 } gen_chunk($py_name); $need_lambda = 1; if($perl_name eq 'map') { # See if we have an equiv python function that's like "chr", and not like ".lower()". if(($bracketed == 0 || $ValPerl[$begin+1] eq '(') && $ValClass[$start] eq 'f' && substr($ValPy[$start],0,1) ne '.') { $Pyf{$ValPy[$start]} = 1 if(substr($ValPy[$start],0,1) eq '_'); gen_chunk('(', $ValPy[$start]); $need_lambda = 0; } } $comma = $end_pos+1; if($need_lambda) { if($ValClass[$start] eq '"' && $ValPy[$start] =~ /^$ANONYMOUS_SUB\d+[a-z]?$/) { # issue s39: we pulled the code out into a sub gen_chunk('('); # issue s39 } else { gen_chunk("(lambda $DEFAULT_VAR:"); } if($ValClass[$start] eq 'f') { # issue s205: If this is a function, it could be unparenthesized, and then the comma belongs to him and not us $comma = next_same_level_token(',', end_of_function($start)+1, $end_pos); # issue s205 } else { # issue s205 $comma = next_same_level_token(',', $start, $end_pos); } $comma = $end_pos+1 if $comma<0; gen_chunk('[') if $need_bracket; if($ValClass[$start] eq '!' && $perl_name eq 'grep') { # issue s153 gen_chunk('not'); # issue s153 $start++; # issue s153 } # issue s153 if($start == $comma-1 && $perl_name eq 'grep') { # singleton if(index('sd"', $ValClass[$start]) >= 0) { # scalar, digits, or string if($ValClass[$start] eq '"' && $ValPy[$start] =~ /^$ANONYMOUS_SUB\d+[a-z]?$/) { # issue s262 gen_chunk($ValPy[$start]); # issue s262 } elsif($ValClass[$start] eq '"' && $ValPy[$start] =~ / in $CONVERTER_MAP{S}\($DEFAULT_VAR\)$/) { # issue s344 gen_chunk($ValPy[$start]); # issue s344 } else { # issue s262 gen_chunk($DEFAULT_VAR,'==', $ValPy[$start]); } } elsif($ValClass[$start] eq 'q') { # pattern if(substr($ValPy[$start],0,3) eq 're.' || substr($ValPy[$start],0,6+length($DEFAULT_MATCH)) eq "($DEFAULT_MATCH:=re.") { # SNOOPYJC gen_chunk($ValPy[$start]); # it's ready to go! } else { gen_chunk('re.search(', $ValPy[$start], ',', $DEFAULT_VAR, ')'); } } else { $k = expression($start, $comma-1, 0); # issue s135: This doesn't work for a substitute, but it's handled above return -255 if $k<0; # issue s135 # issue s135 return -255; } } elsif($start == $comma-1 && $ValClass[$start] eq 'f' && substr($ValPy[$start],0,1) eq '.') { # function like ".lower()" gen_chunk($DEFAULT_VAR, $ValPy[$start]); } elsif($start == $comma-1 && $ValClass[$start] eq 'i' && $LocalSub{$ValPy[$start]} && $perl_name eq 'map') { $Pyf{"__mapf"} = 1; # Need extra function because perl uses global $_ instead of passing an arg gen_chunk('__mapf('.escape_keywords($ValPy[$k]).", $DEFAULT_VAR)"); } else { $k = expression($start, $comma-1, 0); return -255 if $k<0; } gen_chunk(']') if $need_bracket; } elsif($bracketed == 1 && $ValPerl[$begin+1] eq '(') { $comma = next_same_level_token(',', $start, $end_pos); } gen_chunk(','); if($bracketed == 1 && $ValPerl[$begin+1] eq '{') { # We chopped our limit to the matching '}', so put it back! # issue s256 $limit = $#ValClass; # issue s256 $limit = $_[1] if(scalar(@_)>1); $limit = end_of_function($begin); # issue s256 $mode = 0; $mode = 2 if $ValClass[$end_pos+2] eq '(' && $ValPerl[$end_pos+2] eq '(' && next_same_level_token(',', $end_pos+3, $limit-1) != -1; # issue s47 $mode = 2 if is_list($end_pos+2, $limit); # issue s315 my $extra = ''; if($mode == 2 || # issue s315 $ValClass[$end_pos+2] ne 'a' || next_same_level_token(':', $end_pos+2, $limit) != -1) { # issue s194 $Pyf{"_make_list"} = 1; # issue s194 gen_chunk('_make_list', '('); # issue s194 $extra = ')'; # issue s194 } $k = expression($end_pos+2, $limit, $mode); gen_chunk(')'); gen_chunk($extra) if $extra; # issue s194 } else { $mode = 0; $mode = 2 if $ValClass[$comma+1] eq '(' && $ValPerl[$comma+1] eq '(' && # issue s311 happens here! next_same_level_token(',', $end_pos+3, $limit-1) != -1; # issue s47 # issue s153 $k = expression($comma+1, $limit, $mode); # issue s153 gen_chunk(')') if($ValPerl[$limit] ne ')'); my $extra = ''; if($ValClass[$comma+1] ne 'a' || next_same_level_token(':', $comma+1, $end_pos) != -1) { # issue s194 # issue s311 happens here! $Pyf{"_make_list"} = 1; # issue s194 gen_chunk('_make_list', '('); # issue s194 $extra = ')'; # issue s194 } elsif(is_list($comma+1, $end_pos) && $mode == 0) { # issue s279 $Pyf{"_flatten"} = 1; # issue s279 gen_chunk('_flatten', '(['); # issue s279 $extra = '])'; # issue s279 } $k = expression($comma+1, $end_pos, $mode); # issue s153 gen_chunk($extra) if $extra; # issue s194 gen_chunk(')'); # issue s153 } gen_chunk(')'); # close list(...) gen_chunk(')') if $add_close_paren; # issue 37: close len(...) }elsif($perl_name eq 'sort') { # SNOOPYJC # sort @arr (or list) # sort f @arr # sort{block} @arr (or list) # # Gen call to sorted(list, key=..., reverse=...) - this returns a list # if($bracketed == 0 && $ValClass[$begin+1] eq '(') { # issue s3: We use the old definition of bracketed $bracketed=1; $limit=matching_br($begin+1); $start=$begin+2; # function call with normal pathethis if( $ValClass[$limit] eq ')' ){ $end_pos=$limit-1; } } $k=$start; my $close = ''; # issue s359 if($autovivification) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $close = ')'; # issue s359 } gen_chunk($py_name); if(!($bracketed == 1 && $ValPerl[$begin+1] eq '{') && (($ValPerl[$begin+1] eq '(' && $ValPerl[$begin+2] ne ')') || # issue s351 ($ValClass[$k] ne '"' && # issue s78: not with a generated sub # issue s351 ($ValClass[$k] ne 'i' || ($k+1 < $#ValClass && $ValClass[$k+1] eq '('))) { # sub but not sub() ($ValClass[$k] ne 'i' || (defined $ValType[$k] && $ValType[$k] ne ''))))) { # issue s351: sub but not &sub or @{sub()} # Simple case of sort @arr -or- sort (list) # -or- sort &func(...) -or- sort func() -or- sort @{func(...)} gen_chunk('('); $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk(')'); gen_chunk($close) if $close; # issue s359 return $limit+1; } gen_chunk('('); # Generate the list as the first argument to python's sorted() if($bracketed == 1 && $ValPerl[$begin+1] eq '{') { # We chopped our limit to the matching '}', so put it back! $limit = $#ValClass; $limit = $_[1] if(scalar(@_)>1); # If bracketed == 1, then end_pos points just before the '}' if($end_pos+2 == $limit && $ValClass[$limit] eq 'h') { # sort a hash sorts the keys and values in perl # SNOOPYJC gen_chunk('functools.reduce(lambda x,y:x+y,'.$ValPy[$limit].'.items())') gen_chunk('itertools.chain.from_iterable('.$ValPy[$limit].'.items())') # SNOOPYJC } else { $k = expression($end_pos+2, $limit, 0); } } elsif($start+1 == $limit && $ValClass[$limit] eq 'h') { # sort a hash sorts the keys and values in perl # SNOOPYJC gen_chunk('functools.reduce(lambda x,y:x+y,'.$ValPy[$limit].'.items())') gen_chunk('itertools.chain.from_iterable('.$ValPy[$limit].'.items())') } elsif($ValClass[$start] eq '"' && ($ValClass[$start+1] eq ',' || $ValClass[$start+1] eq 'A')) { # issue s78, issue s271 $k = expression($start+2, $limit, 0); # issue s78 $end_pos = $start; # issue s78 } else { $k = expression($start+1, $limit, 0); } gen_chunk(', key=functools.cmp_to_key(lambda a,b:'); if($bracketed == 0 && ($ValClass[$start] eq 'i' && $LocalSub{$ValPy[$start]}) || $ValClass[$start] eq '"') { # issue s78: a generated sub $Pyf{"__sortf"} = 1; # Need extra function because perl uses global $_ instead of passing an arg gen_chunk('__sortf('.escape_keywords($ValPy[$start]).", a, b)"); } else { $k = expression($start, $end_pos, 0); return -255 if $k<0; } gen_chunk(')'); # Close the functools.cmp_to_key(... # issue s163 gen_chunk(')') if($ValPerl[$limit] ne ')' || $ValClass[$start] eq '"'); # issue s78 gen_chunk(')'); # issue s163 gen_chunk($close) if $close; # issue s359 } elsif($perl_name eq 'exec') { # issue s247 my $end_pos = ($bracketed == 1 ? $limit-1 : $limit); my $list; if($ValPerl[$begin+1] eq '{') { $Pyf{_execp} = 1; gen_chunk('_execp', '('); # exec with a PROGRAM my $end_br = matching_br($begin+1); $TrStatus = expression($begin+2, $end_br-1, 0); if($end_br+1 <= $#ValClass && $ValClass[$end_br+1] eq 'a') { gen_chunk(','); if($autovivification) { gen_chunk('list(', $ValPy[$end_br+1], ')'); } else { gen_chunk($ValPy[$end_br+1]); } } else { gen_chunk(','); $list = $end_br+1; } } else { my $eov; if($start == $end_pos && $ValClass[$start] eq 'a') { gen_chunk($py_name, '('); # exec LIST gen_chunk($ValPy[$start]); # We don't need this code now because we use perllib, not os.execvp # if($autovivification) { # gen_chunk($ValPy[$start], '[0]', ',', 'list(', $ValPy[$start], ')'); # } else { # gen_chunk($ValPy[$start], '[0]', ',', $ValPy[$start]); # } } elsif(($eov = end_of_variable($start)) == $end_pos) { gen_chunk($py_name, '('); # exec LIST $TrStatus = expression($start, $eov, 0); # We don't need this code now because we use perllib, not os.execvp # if(is_expression_simple($start, $eov)) { # $TrStatus = expression($start, $eov, 0); # gen_chunk(','); # gen_chunk('['); # $TrStatus = expression($start, $eov, 0); # gen_chunk(']'); # } else { # gen_chunk("($SUBSCRIPT_TEMP:="); # $TrStatus = expression($start, $eov, 0); # gen_chunk(')', ',', '[', $SUBSCRIPT_TEMP, ']'); # } } elsif($eov+1 <= $#ValClass && $ValClass[$eov+1] ne ',' && $ValClass[$eov+1] ne 'A') { # issue s271 $Pyf{_execp} = 1; gen_chunk('_execp', '('); # exec with a PROGRAM $TrStatus = expression($start, $eov, 0); gen_chunk(','); $list = $eov+1; } else { gen_chunk($py_name, '('); # exec LIST $list = $start; } if(defined $list) { my $need_flatten = 0; for(my $p = $list; $p <= $end_pos; $p++) { if(need_splat($p)) { $need_flatten = 1; last; } } if($need_flatten) { $Pyf{_flatten} = 1; gen_chunk('_flatten', '('); } gen_chunk('['); $TrStatus = expression($list, $end_pos, 0); gen_chunk(']'); gen_chunk(')') if $need_flatten; } } gen_chunk(')'); }elsif($perl_name eq '..') { # issue s307: Range Operator gen_chunk('range('); my $comma = next_same_level_token(',', $start, $end_pos); if($comma < 0) { $TrStatus = 255; } else { $TrStatus = expression($start, $comma-1, 0); gen_chunk(','); if($comma+1 == $end_pos && $ValClass[$end_pos] eq 'd') { gen_chunk($ValPy[$end_pos]+1); } else { gen_chunk('1', '+'); $TrStatus = expression($comma+1, $end_pos, 0); } } gen_chunk(')'); }elsif( $perl_name eq 'push' ){ # push LHS, RSH => LSH.append(RSH) -or- LHS.extend(RHS) $k=$start; # issue 9 if( $ValClass[$k+2] =~ /[a"]/ ){ # issue 9 }elsif( $ValClass[$k+2] eq 'a' ){ # issue s271 my $comma = next_same_level_token(',',$start,$end_pos); # issue 9 my $comma = next_same_level_tokens(',A',$start,$end_pos); # issue 9, issue s271 return -255 if $comma<0; # issue 9 if ($debug > 4) { say STDERR "push $ValClass[$comma+1]\n"; } if($k == $comma-1 && substr($ValPy[$k],-4,4) eq '[1:]') { # issue s291 like sys.argv[1:] substr($ValPy[$k],-4,4) = ''; # issue s291: Remove the slice } my $t=expression($k,$comma-1,0); # issue 9: Gen the LHS return -255 if $t<0; # issue 9 return -255 if($comma+1 > $#ValClass); if( $ValClass[$comma+1] eq 'a' || ($ValClass[$comma+1] eq 's' && defined $ValType[$comma+1] && $ValType[$comma+1] eq '@s')) { # issue s315 gen_chunk($py_name,$ValPy[$comma+1],')'); # issue 9: push(@x,@y) }elsif($ValClass[$comma+1] eq '(' ){ # issue 9 my $type = &Pythonizer::expr_type($comma+1, matching_br($comma+1), $CurSub); # SNOOPYJC $py_name = '.append(' if(substr($type,0,1) !~ /[ah]/); # SNOOPYJC: Use append if it's a scalar $py_name = '.append(' if(($ValPerl[$comma+1] eq '[' || $ValPerl[$comma+1] eq '{') && # issue bootstrap: hashref or arrayref constant next_same_level_token('y', $comma+2, matching_br($comma+1)-1) == -1); # issue s154: use 'extend' for [... y ...] # issue s359 gen_chunk($py_name, $ValPy[$comma+1]); # issue 9 gen_chunk($py_name); # issue s359 my $close = ''; if($autovivification && $py_name eq '.append(' && $ValPerl[$comma+1] eq '[') { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $close = ')'; # issue s359 } elsif($autovivification && $py_name eq '.append(' && $ValPerl[$comma+1] eq '{') { # issue s359 $Pyf{Hash} = 1; # issue s359 gen_chunk('Hash', '('); # issue s359 $close = ')'; # issue s359 } gen_chunk($ValPy[$comma+1]); # issue 9, issue s359 $k=expression($comma+2,$end_pos-1,0); # issue 9 gen_chunk($ValPy[$end_pos], ')'); # issue 9 gen_chunk($close) if $close; # issue s359 }elsif((index("isd-\"", $ValClass[$comma+1]) >= 0 && $comma+1 == $end_pos) || # issue 9: scalar $ValClass[$comma+1] eq "\\") { # issue bootstrap - address of something is a scalar $py_name = '.append('; # issue 9 gen_chunk($py_name); # issue 9 $k=expression($comma+1,$end_pos,0); # issue 9 gen_chunk(')'); # issue 9 }else{ gen_chunk($py_name); # issue 9: .extend( # issue 9 $k=expression($k+3,$end_pos,0); $Pyf{"_make_list"} = 1; # issue 9 gen_chunk('_make_list', '('); # issue 9 $k=expression($comma+1,$end_pos,0); # issue 9 gen_chunk('))'); # issue 9 } }elsif($perl_name eq 'delete' ){ # open used without parantethisi. always has one argument # issue delete $k=($ValPerl[$start+1] eq '(') ? $start+2 : $start+1; $k=$start; # issue delete if($ValClass[$k] eq 't' && $ValPerl[$k] eq 'local') { # issue 108 logme('W',"The 'delete local' statement is not implemented"); # issue 108 } elsif($ValClass[$k] eq 'a') { # issue delete - handle delete @options{list of keys} gen_chunk("for $KEY_TEMP in "); return -255 if($k+1 > $#ValClass); my $kk; if($ValClass[$k+1] eq 'q') { # Flattened qw// inside eliminated [] $kk=expression($k+1, $k+1, 0); } else { $e = matching_br($k+1); # special case for delete @options{keys %options);, as the default code will give an error # about modifying the dict in the loop. $gen_close = 0; if($k+3 <= $#ValClass && $ValClass[$k+2] eq 'f' && $ValPerl[$k+2] eq 'keys' && $ValClass[$k+3] eq 'h' && $ValPerl[$k]) { gen_chunk("list("); $gen_close = 1; } my $kk=expression($k+2, $e-1, 0); return -255 if $kk<0; gen_chunk(')') if($gen_close); } gen_chunk(':'); gen_statement(); correct_nest(1,1); gen_chunk($ValPy[$k],$py_name,"$KEY_TEMP,None)"); # delete($hash{$key}) => hash.pop($key, None) gen_statement(); correct_nest(-1,-1); } else { # issue delete gen_chunk($ValPy[$k],$py_name,$ValPy[$k+2],',None)'); # delete($hash{$key}) => hash.pop($key,None) $k = end_of_variable($start); # issue bootstrap: Generate proper code for delete $NeedsInitializing{$subname}{$varname}; if($ValClass[$k] eq ')') { # issue bootstrap my $s = reverse_matching_br($k); return -255 if $s<0; my $kk=expression($start, $s-1, 0); # Generate the prefix return -255 if $kk<0; # issue delete gen_chunk($py_name); # .pop( $kk=expression($s+1, $k-1, 0); # the last key return -255 if $kk<0; # issue delete gen_chunk(',None)'); # issue delete } else { return -255; } # issue bootstrap gen_chunk($ValPy[$k],$py_name); # issue delete: hash.pop( # issue bootstrap $e = matching_br($k+1); # issue delete # issue bootstrap my $kk=expression($k+2, $e-1, 0); # issue delete # issue bootstrap return -255 if $kk<0; # issue delete # issue bootstrap gen_chunk(',None)'); # issue delete } }elsif($perl_name eq 'sprintf' ){ #$ValPy[$start] -- format string # SNOOPYJC gen_chunk($ValPy[$start],' % ( '); # format string # SNOOPYJC $k=expression($start+2,$end_pos,0); # skip initial',' and scan all variables # issue s271 my $comma=next_same_level_token(',',$start,$end_pos); # issue s74 my $comma=next_same_level_tokens(',A',$start,$end_pos); # issue s74, issue s271 if($comma != -1) { $k = $comma-1; } else { $k = end_of_variable($start); # SNOOPYJC } $Pyf{_format} = 1; # SNOOPYJC gen_chunk('_format', '('); # SNOOPYJC $k=expression($start, $k, 0); # SNOOPYJC # SNOOPYJC gen_chunk(' % ( '); # SNOOPYJC if($k+1 <= $end_pos) { gen_chunk(','); # SNOOPYJC my $e = end_of_variable($k+1); if($e == $end_pos) { # SNOOPYJC: Don't output '(' if there is only 1 variable $k=expression($k+1,$end_pos,0); # SNOOPYJC: skip initial ',' and scan all variables return -255 if $k<0; } else { gen_chunk('('); # SNOOPYJC $k=expression($k+1,$end_pos,0); # SNOOPYJC: skip initial ',' and scan all variables return -255 if $k<0; gen_chunk(')'); # } } gen_chunk(')'); #SNOOPYJC }elsif($perl_name eq 'undef' ){ # undef in Perl accepts list of arguments if( $bracketed==-1){ if($begin != 0) { # SNOOPYJC: don't gen code for "undef;", since it may be turned into a "return undef;" gen_chunk('None'); return $start; # issue s316 } }else{ if(index('?:,)', $ValClass[$start]) >= 0) { # SNOOPYJC - undef by itself, followed by a ? : , or ) gen_chunk('None'); return $start; } elsif($ValClass[$start] eq 'a' && $start != $end_pos) { # issue s171 - handle undef @options{list of keys} logme('W', "Hash slice undef doesn't work properly in most perl versions - did you mean 'delete'? - see https://github.com/Perl/perl5/issues/20537"); my $k = $start; gen_chunk("for $KEY_TEMP in "); return -255 if($k+1 > $#ValClass); my $kk; if($ValClass[$k+1] eq 'q') { # Flattened qw// inside eliminated [] $kk=expression($k+1, $k+1, 0); } else { $e = matching_br($k+1); # special case for undef @options{keys %options);, as the default code will give an error # about modifying the dict in the loop. $gen_close = 0; if($k+3 <= $#ValClass && $ValClass[$k+2] eq 'f' && $ValPerl[$k+2] eq 'keys' && $ValClass[$k+3] eq 'h' && $ValPerl[$k]) { gen_chunk("list("); $gen_close = 1; } my $kk=expression($k+2, $e-1, 0); return -255 if $kk<0; gen_chunk(')') if($gen_close); } gen_chunk(':'); gen_statement(); correct_nest(1,1); gen_chunk($ValPy[$k],"[$KEY_TEMP]", '=' ,'None'); # undef($hash{$key}) => hash[$key] = None gen_statement(); correct_nest(-1,-1); return $#ValClass+1 if(!defined $limit); return $limit+1; } # SNOOPYJC: If we know the type of the var, then init it to that value instead # If the var is used in a "defined" function, then the type is set to 'm' for mixed so # we init it to None. my @undefs = ($ValPy[$start]); # SNOOPYJC: new code for(my $i=$start+1; $i<$end_pos; $i+=2 ){ last if ($ValClass[$i] ne ',' && $ValClass[$i] ne 'A'); # check if the list endeded, issue s271 push @undefs, $ValPy[$i+1]; } my $val = undef; foreach my $u (@undefs) { my $sval = 'None'; if(exists $VarType{$u} && exists $VarType{$u}{$CurSub}) { $sval = init_val($VarType{$u}{$CurSub}); } if(defined $val && $sval ne $val) { $val = undef; last; } $val = $sval; } if(defined $val) { # they are all the same gen_chunk(join(' = ', @undefs)); gen_chunk(" = $val"); # final assignment } else { # do it one by one foreach my $u (@undefs) { gen_chunk("$u = "); my $val = 'None'; if(exists $VarType{$u} && exists $VarType{$u}{$CurSub}) { $val = init_val($VarType{$u}{$CurSub}); } gen_chunk($val); gen_statement(); } } } }elsif($perl_name eq 'chomp' || $perl_name eq 'chop' ){ # SNOOPYJC if($py_name =~ /_s$/) { # issue s48: '_s' is just a flag to tell us we're in scalar context substr($py_name,-2,2) = ''; # just lose it } # issue s148 if(index($TokenStr,'=') > 0) { # SNOOPYJC chomp(my @a = ); # issue s148: Better handle a list of things my $s = $start; my $e = $end_pos; while(1) { # issue s271 my $comma = next_same_level_token(',', $s, $e); my $comma = next_same_level_tokens(',A', $s, $e); # issue s271 say STDERR "$perl_name: s=$s, e=$e, comma=$comma" if($debug >= 5); $comma = $e+1 if($comma < 0); $start = $s; $end_pos = $comma - 1; $s = $comma+1; if(next_same_level_token('=', $start, $end_pos) > 0) { # SNOOPYJC chomp(my @a = );, issue s148 $adjust = 0; if($comma != $e+1) { # issue s148 insert($end_pos+1, ')', ')', ')'); # issue s148 insert($start, '(', '(', '('); # issue s148 $adjust = 2; # issue s148 $adjust += pre_assign($begin, $start,1); # issue s148 } else { # issue s148 $adjust += pre_assign($begin, $begin+1,1); # issue s148 } # issue s148 pre_assign($begin+1,1); # issue s148 $end_pos = $#ValClass-1; $end_pos += $adjust; $e += $adjust; $s += $adjust; if($ValClass[$start] eq '(' && matching_br($start) == $end_pos) { $start++; $end_pos--; } if($debug >= 3) { say STDERR "after pre_assign: adjust=$adjust, begin=$begin, start=$start, end_pos=$end_pos, s=$s, e=$e, =|$TokenStr|= @ValPerl\n" } return $begin-1 if($ValClass[$begin] ne 'f'); # e.g. the function got replaced with _e := ... } if ($bracketed==-1){ gen_chunk($ValPy[1].' = '.$DEFAULT_VAR.$py_name); # issue 32: Be careful because $py_name contains '\n' last; # issue s148 }elsif ($start==$end_pos){ if($ValClass[$start] eq 'a' || $ValClass[$start] eq 'h') { # SNOOPYJC: Handle array or hash chomp my $temp; if($ValClass[$start] eq 'a') { $temp = $INDEX_TEMP; gen_statement("for $INDEX_TEMP in range(len($ValPy[$start])):"); # SNOOPYJC } else { $temp = $KEY_TEMP; gen_statement("for $KEY_TEMP in $ValPy[$start]:"); # SNOOPYJC } correct_nest(1,1); # SNOOPYJC # issue s148 gen_chunk($ValPy[$start]."[$temp] = ".$ValPy[$start]."[$temp]".$py_name); # SNOOPYJC if($ValPy[$start] eq $PERL_ARG_ARRAY) { # issue s184: This is an argument list of a sub my $var = $PERL_ARG_ARRAY; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $temp, ','); # issue s184 my $als = 0; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $extra = ')'; $extra = ", shifts=$als)" if($als); # issue s184 gen_chunk($CONVERTER_MAP{S}.'('.$ValPy[$start]."[$temp])".$py_name.$extra); # SNOOPYJC, issue s148, issue s184 } else { gen_chunk($ValPy[$start]."[$temp] = ".$CONVERTER_MAP{S}.'('.$ValPy[$start]."[$temp])".$py_name); # SNOOPYJC, issue s148 } gen_statement(); correct_nest(-1,-1); # SNOOPYJC } else { # SNOOPYJC gen_chunk($ValPy[$start].' = '.$ValPy[$start].$py_name); } # issue s148 } elsif($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S} && matching_br($start+1) == $end_pos) { # SNOOPYJC: Handle converter } elsif($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S} && matching_br($start+1) == $end_pos && $ValClass[$start+2] eq 'f' && ($ValPy[$start+2] eq '_assign_global' || $ValPy[$start+2] eq '_set_element')) { # issue s148 my %map = ('_assign_globalchop'=>'_chop_global', '_assign_globalchomp'=>'_chomp_global', '_set_elementchop'=>'_chop_element', '_set_elementchomp'=>'_chomp_element'); $ValPy[$start+2] = $map{$ValPy[$start+2].$perl_name}; $TrStatus = expression($start+2, $end_pos-1,1); # issue s148 } else { # issue s148 gen_chunk($ValPy[$start+2], ' = ', $ValPy[$start], '(', $ValPy[$start+2], ')', $ValPy[$begin]); # issue s148 gen_statement(); # issue s148 } # issue s148 }elsif(index($TokenStr,',') > 0) { # SNOOPYJC # issue s148 for(my $i=$start; $i<=$end_pos; $i+=2 ){ # SNOOPYJC # issue s148 # SNOOPYJC last if ($ValClass[$i] ne ','); # check if the list endeded # issue s148 # SNOOPYJC gen_chunk($ValPy[$i],'=',$ValPy[$i],$ValPy[0],';'); # issue s148 # SNOOPYJC: After fix_type_issues runs, we could have _str(a) instead of just a, so handle that: # issue s148 if($ValClass[$i] eq 'f' && $ValPy[$i] eq $CONVERTER_MAP{S}) { # SNOOPYJC # issue s148 gen_chunk($ValPy[$i+2],' = ',$ValPy[$i],'(',$ValPy[$i+2],')',$ValPy[0]); # SNOOPYJC # issue s148 $i += 3; # issue s148 } else { # issue s148 gen_chunk($ValPy[$i],' = ',$ValPy[$i],$ValPy[0]); # SNOOPYJC # issue s148 } # issue s148 gen_statement(); # SNOOPYJC # issue s148 } } else { # issue s148 $TrStatus = -1; # issue s148: Handle chomp($hash{key}), etc gen_complex_chop_chomp($start, $end_pos, $perl_name eq 'chomp'); # issue s148 } } continue { last if $s > $e; last if $bracketed != 1; # Only parenthesized list is obeyed gen_statement(); } }elsif($perl_name eq 'chomp_' || $perl_name eq 'chop_' ){ # issue s148 # This is just a simple tail function that chomp/chops off the character if($py_name =~ /__$/) { # issue s148: '__' is just to hide the function from PyFuncType substr($py_name,-2,2) = ''; # just lose it } gen_chunk($py_name); # issue s148 gen_statement(); # issue s148 }elsif($perl_name eq 'splice') { # splice ARRAY,OFFSET,LENGTH,LIST # splice ARRAY,OFFSET,LENGTH # splice ARRAY,OFFSET # splice ARRAY # issue s271 my $comma = next_same_level_token(',', $start, $end_pos); my $comma = next_same_level_tokens(',A', $start, $end_pos); # issue s271 my $ar0 = $start; my $ar1 = $end_pos; $ar1 = $comma-1 if($comma != -1); gen_chunk($py_name, '('); $TrStatus = expression($ar0, $ar1, 0); # Gen array if($comma != -1) { # issue s271 $comma = next_same_level_token(',', $comma+1, $end_pos); $comma = next_same_level_tokens(',A', $comma+1, $end_pos); # issue s271 my $of0 = $ar1+2; my $of1 = $end_pos; $of1 = $comma-1 if($comma != -1); gen_chunk(','); # issue s246 if($of0 == $of1 && $ValClass[$of0] eq 'a' && $ValPerl[$of0] !~ /^len\(/) { if($of0 == $of1 && $ValClass[$of0] eq 'a' && $ValPy[$of0] !~ /^len\(/) { # issue s246 gen_chunk('len', '(', $ValPy[$of0], ')'); } else { $TrStatus = expression($of0, $of1, 0); # Gen offset } if($comma != -1) { # issue s271 $comma = next_same_level_token(',', $comma+1, $end_pos); $comma = next_same_level_tokens(',A', $comma+1, $end_pos); # issue s271 my $ln0 = $of1+2; my $ln1 = $end_pos; $ln1 = $comma-1 if($comma != -1); gen_chunk(','); $TrStatus = expression($ln0, $ln1, 0); # Gen length if($comma != -1) { my $ls0 = $ln1+2; my $ls1 = $end_pos; gen_chunk(','); if($ls0 == $ls1 && $ValClass[$ls0] eq 'a') { gen_chunk('*', $ValPy[$ls0]); } else { $TrStatus = expression($ls0, $ls1, 0); } } } } gen_chunk(')'); }elsif($perl_name eq 'reverse') { # issue 65 - implement 'reverse' if(substr($py_name,0,1) eq '_' || $py_name eq "$PERLLIB.reverse_scalar") { # _reverse_scalar - scalar context # Optimize some special cases if($bracketed==-1) { if(default_var_string()) { # issue s104 gen_chunk($DEFAULT_VAR.'[::-1]'); } else { gen_chunk("$CONVERTER_MAP{S}($DEFAULT_VAR)".'[::-1]'); # issue s104 } } elsif($start == $end_pos && $ValClass[$start] =~ /([as])/) { # a single thing if($1 eq 'a') { # a (array) gen_chunk("''.join($ValPy[$start])[::-1]"); } elsif($1 eq 's') { # s (scalar) gen_chunk("$ValPy[$start]".'[::-1]'); } else { # h (hash) gen_chunk("{_str(_v): _k for _k, _v in $ValPy[$start].items()}"); # test reverse } } else { $Pyf{$py_name} = 1; gen_chunk($py_name); gen_chunk('('); $make_tuple = 0; # issue s271 if($ValClass[$start] ne '(' && next_same_level_token(',',$start,$end_pos) >= 0) { if($ValClass[$start] ne '(' && next_same_level_tokens(',A',$start,$end_pos) >= 0) { # issue s271 gen_chunk('('); $make_tuple = 1; } $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk(')') if($make_tuple); gen_chunk(')'); } } else { if($bracketed==-1) { gen_chunk($DEFAULT_VAR); # reversing a list of 1 element = identity } elsif($start == $end_pos && $ValClass[$start] eq 'h') { # a single hash gen_chunk("{_str(_v): _k for _k, _v in $ValPy[$start].items()}"); # test reverse } else { gen_chunk('('); $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk(')'); gen_chunk($py_name); } } # SNOOPYJC }elsif($perl_name eq 'chop'){ # SNOOPYJC gen_chunk("$ValPy[$start]=$ValPy[$start]".'[0,-1]'); }elsif($perl_name eq 'getopt' || $perl_name eq 'getopts') { getopts_fun($perl_name, $start, $end_pos); }elsif($perl_name eq 'GetOptions' && $bracketed==1 && (my $type = GetOptionsHandled($start, $end_pos))) { # issue 48 GetOptions_fun($type, $start, $end_pos); # issue 48 }elsif($perl_name eq 'binmode') { # SNOOPYJC # binmode FH -or- binmode FH, "LAYER" my $fh = $start; my $ly = (($fh+2 <= $#ValClass) ? $fh+2 : undef); if(!defined $ly || $ValClass[$ly] ne '"') { $layer = ':raw'; } else { $layer = $ValPerl[$ly]; } my $mode = 'None'; $mode = "'b'" if($layer eq ':raw' || $layer eq ':bytes'); my $encoding = 'None'; my $errors = 'None'; $encoding = "'$1'" if($layer =~ /:encoding\((.*)\)/); if($layer eq ':utf8') { $encoding = "'UTF-8'"; $errors = "'ignore'"; } $Pyf{'_binmode'} = 1; my $cs = &Perlscan::cur_sub(); # issue s185 if($begin == 0) { gen_chunk("$ValPy[$fh] = ", '_binmode', "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors)"); # issue s183: keep the code active for finish(): gen_statement(); } elsif($ValPy[$fh] =~ /^(.*)\[(\d+)\]$/) { # issue s183: This is an argument to a sub my $var = $1; # issue s183 my $subscript = $2; # issue s183 # issue s184 $Pyf{_set_element} = 1; # issue s183 # issue s184 gen_chunk('_set_element', "($var", ',', $subscript, ',', "_binmode", # issue s184 "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors))"); # issue s183 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 my $extra = ''; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $extra = ", shifts=$als" if($als); # issue s184 gen_chunk("_binmode", "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors)$extra)"); # issue s183 # issue s241 } elsif($ValType[$fh] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$fh]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($ValType[$fh] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$fh]}) { # issue s185: This is a copy of a reference argument to a sub, issue s241 # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$fh]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$fh]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$fh], ':='); # issue s185 gen_chunk("_binmode", "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors)))"); # issue s185 } elsif(index($ValPy[$fh], '.') < 0) { gen_chunk("($ValPy[$fh]:=", '_binmode', "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors))"); } else { my $ldot = rindex($ValPy[$fh], '.'); $Pyf{_assign_global} = 1; gen_chunk('_assign_global', "('".substr($ValPy[$fh],0,$ldot)."','".substr($ValPy[$fh],$ldot+1)."', _binmode", "($ValPy[$fh], mode=$mode, encoding=$encoding, errors=$errors))"); } }elsif($perl_name eq 'IOFile_open' || $perl_name eq 'fdopen') { # SNOOPYJC # $fh->open(fname, mode, parms) -or- $fh->open(fname, IOLayers) # This has been already modified so when we see it, it looks like: # IOFile_open($fh, fname, mode, parms) -or- IOFile_open($fh, fname, mode, parms) my $fh = $start; $Pyf{$py_name} = 1; my $close = ')'; if($begin == 0) { gen_chunk("$ValPy[$fh] = ", $py_name, "($ValPy[$fh], "); } elsif(index($ValPy[$fh], '.') < 0) { gen_chunk("($ValPy[$fh]:=", $py_name, "($ValPy[$fh], "); $close = '))'; } else { my $ldot = rindex($ValPy[$fh], '.'); $Pyf{_assign_global} = 1; gen_chunk('_assign_global', "('".substr($ValPy[$fh],0,$ldot)."','".substr($ValPy[$fh],$ldot+1)."', ", $py_name, "($ValPy[$fh], "); $close = '))'; } # issue s271 my $comma = next_same_level_token(',', $fh, $end_pos); my $comma = next_same_level_tokens(',A', $fh, $end_pos); # issue s271 return -255 if($comma < 0); my $fn0 = $comma+1; $TrStatus=expression($fn0, $end_pos, 0); return -255 if ($TrStatus<0); gen_chunk($close); }elsif($perl_name eq 'caller') { # SNOOPYJC # issue s177 $Pyf{'_caller'} = 1; $Pyf{$py_name} = 1; # issue s177: Handle scalar context too my $close = ''; # issue s359 if($autovivification && ($py_name eq '_caller' || $py_name eq "$PERLLIB.caller")) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $close = ')'; # issue s359 } if($bracketed == -1) { # no args #gen_chunk(q(['main',__file__,sys._getframe(1).f_lineno])); # issue s177 gen_chunk('_caller', '()'); gen_chunk($py_name, '()'); # issue s177 } else { # definition here: https://perldoc.perl.org/functions/caller # note we leave some stuff out! #gen_chunk("['main',__file__,(_f:=sys._getframe("); # issue s177 gen_chunk('_caller', '('); gen_chunk($py_name, '('); # issue s177 $TrStatus=expression($start,$end_pos,0) if($end_pos >= $start); return -255 if ($TrStatus<0); gen_chunk(')'); #gen_chunk(")).f_lineno,_f.f_code.co_name,_f.f_code.co_argcount,0,'',0,0,0,0]"); } gen_chunk($close) if $close; # issue s359 }elsif($perl_name eq 'seek') { # SNOOPYJC gen_chunk($py_name); # method gen_chunk('('); my $fh = $start; # issue s271 my $comma = next_same_level_token(',', $start, $end_pos); my $comma = next_same_level_tokens(',A', $start, $end_pos); # issue s271 $TrStatus=expression($fh, $comma-1, 0); return -255 if ($TrStatus<0); gen_chunk(','); my $pos = $comma+1; # issue s271 $comma = next_same_level_token(',', $pos, $end_pos); $comma = next_same_level_tokens(',A', $pos, $end_pos); # issue s271 $TrStatus=expression($pos, $comma-1, 0); return -255 if ($TrStatus<0); gen_chunk(','); my $whence = $comma+1; $TrStatus=expression($whence, $end_pos, 0); return -255 if ($TrStatus<0); gen_chunk(')'); }elsif($perl_name eq 'tell') { # SNOOPYJC gen_chunk($py_name); # add method gen_chunk('('); my $fh = $start; $TrStatus=expression($fh, $end_pos, 0); return -255 if ($TrStatus<0); gen_chunk(')'); }elsif($py_name eq '.read' || $py_name eq '.sysread') { # issue 10 - read or sysread, not already transformed if(substr($perl_name,0,1) eq '.') { # SNOOPYJC: We already modified the function in fixup_read_in_expression gen_chunk($py_name); return expression($begin+1,$limit,1); } # SNOOPYJC: Redid this whole thing to support complex args, though they are # mostly handled above in fixup_read_in_expression # # read FILEHANDLE,SCALAR,LENGTH,OFFSET # read FILEHANDLE,SCALAR,LENGTH my $fh0 = $start; # issue s271 my $comma1 = next_same_level_token(',', $start, $end_pos); my $comma1 = next_same_level_tokens(',A', $start, $end_pos); # issue s271 return -255 if ($comma1<0); my $fh1 = $comma1-1; my $sc0 = $comma1+1; # issue s271 my $comma2 = next_same_level_token(',', $sc0, $end_pos); my $comma2 = next_same_level_tokens(',A', $sc0, $end_pos); # issue s271 return -255 if ($comma2<0); my $sc1 = $comma2-1; my $ln0 = $comma2+1; # issue s271 my $comma3 = next_same_level_token(',', $ln0, $end_pos); my $comma3 = next_same_level_tokens(',A', $ln0, $end_pos); # issue s271 my $ln1 = $comma3-1; my $of0 = undef; my $of1 = undef; if($comma3 < 0) { $ln1 = $end_pos; } else { $of0 = $comma3+1; $of1 = $end_pos; } my $readf = '_read'; $readf = '_sysread' if($perl_name eq 'sysread'); $Pyf{$readf} = 1; if($begin == 0) { # We don't care about the result # scalar = _read(fh, length) # scalar = _read(fh, length, scalar, offset) # Handle $sc0 being $_[N] my $extra = ''; # issue s184 if($sc0 == $sc1 && $ValPy[$sc0] =~ /^(.*)\[(\d+)\]$/) { # issue s184: This is an argument to a sub my $var = $1; # issue s184 my $subscript = $2; # issue s184 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 my $als = 0; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $extra = ')'; $extra = ", shifts=$als)" if($als); # issue s184 } else { $TrStatus = expression($sc0,$sc1,0); return -255 if ($TrStatus<0); gen_chunk('='); } gen_chunk($readf, '('); $TrStatus = expression($fh0,$fh1,0); return -255 if ($TrStatus<0); gen_chunk(','); expression($sc0,$sc1,0); gen_chunk(','); $TrStatus = expression($ln0,$ln1,0); return -255 if ($TrStatus<0); if(defined $of0) { gen_chunk(','); $TrStatus = expression($of0,$of1,0); return -255 if ($TrStatus<0); } gen_chunk(')'); gen_chunk($extra) if $extra; # issue s184 } else { if(defined $of0) { gen_chunk("(($ValPy[$sc0]:=($SUBSCRIPT_TEMP:=", $readf, '('); $TrStatus = expression($fh0,$fh1,0); return -255 if ($TrStatus<0); gen_chunk(','); gen_chunk($ValPy[$sc0]); gen_chunk(','); $TrStatus = expression($ln0,$ln1,0); return -255 if ($TrStatus<0); gen_chunk(','); $TrStatus = expression($of0,$of1,0); return -255 if ($TrStatus<0); gen_chunk(',need_len=True))[0])', ',', $SUBSCRIPT_TEMP, '[1])[1]'); } else { gen_chunk("(($ValPy[$sc0]:=($SUBSCRIPT_TEMP:=", $readf, '('); $TrStatus = expression($fh0,$fh1,0); return -255 if ($TrStatus<0); gen_chunk(','); gen_chunk($ValPy[$sc0]); gen_chunk(','); $TrStatus = expression($ln0,$ln1,0); return -255 if ($TrStatus<0); gen_chunk(',need_len=True))[0])', ',', $SUBSCRIPT_TEMP, '[1])[1]'); } } }elsif($perl_name eq 'stat_cando') { # issue s33 if($import_perllib) { gen_chunk("$PERLLIB.$py_name"); } else { gen_chunk($py_name); } if(substr($ValPy[$start],0,1) eq '*') { $ValPy[$start] = substr($ValPy[$start],1); # unsplat it } $k = expression($start, $end_pos, 1); }elsif($perl_name eq 're') { # SNOOPYJC: Regex without =~ or !~ # $py_name is like re.sub(r'a',r'b',_d) -or- re.sub(re.compile(r'a',re.G),r'b',_d) # -or- .replace(r'a',r'b',1) # issue s344 my $flags = process_re_flags($begin); $py_name = $ValPy[$begin]; if(substr($py_name,0,1) eq '.') { # issue s344 $py_name = "$CONVERTER_MAP{S}($DEFAULT_VAR)" . $py_name; # issue s344 } else { # issue s344 $py_name =~ s/\)\Z/,$flags)/ if($flags); } if($begin == 0 && !is_list($begin)) { # Statement context, issue s299 if($flags =~ /replace/) { $py_name =~ s/replace=False,//; gen_chunk($py_name); } else { gen_chunk($DEFAULT_VAR, '=', $py_name); } } elsif($begin == 0) { # issue s299: re at 0 but with a ',' expression if($flags =~ /replace/) { $py_name =~ s/replace=False,//; gen_chunk($py_name); } else { gen_chunk('(', $DEFAULT_VAR, ':=', $py_name, ')'); } } else { $Pyf{_substitute_and_count} = 1; my $sac = '_substitute_and_count'; $sac = "$PERLLIB.substitute_and_count" if($import_perllib); if($py_name =~ /^$CONVERTER_MAP{S}\($DEFAULT_VAR\)\.replace/) { # issue s344 $py_name =~ s/^$CONVERTER_MAP{S}\($DEFAULT_VAR\)\.replace/re.sub/; # issue s344 $py_name =~ s/,1\)\Z/,$CONVERTER_MAP{S}($DEFAULT_VAR),count=1)/; # issue s344 } # issue s344 $py_name =~ s/^re\.sub/$sac/; if($ValPerl[$begin-1] eq '{' && $begin-2 >= 0 && $ValClass[$begin-2] eq 'f' && $ValPerl[$begin-2] eq 'grep') { # issue s135 # issue s135: Special case 'grep' which wants the tuple value of _substitute_and_count gen_chunk($py_name); # issue s135 } else { # issue s135 gen_chunk('((', $DEFAULT_VAR, ':=', '(', $SUBSCRIPT_TEMP,':=', $py_name, ')[0])', ',', $SUBSCRIPT_TEMP, ')[1][1]'); } } return $begin+1; }elsif($perl_name eq 'tr') { # SNOOPYJC: tr without =~ # $py_name is like .maketrans('a','b'),flags=rc my $flags = ''; if($ValPy[$begin] =~ /,flags=([a-z]+)/) { $flags = $1; } my $args = tr_flags_to_args($ValPy[$begin]); if($begin == 0) { # Statement context if($flags =~ /r/) { $flags =~ s/,replace=False//; if($flags) { $Pyf{_translate} = 1; gen_chunk('_translate', '(',$args,",var=$CONVERTER_MAP{S}($DEFAULT_VAR)", ')'); # a=a.translate(str.maketrans(this, that)), issue s8 } else { gen_chunk("$CONVERTER_MAP{S}($DEFAULT_VAR)",'.translate(',$args,')'); # a=a.translate(str.maketrans(this, that)), issue s8 } } elsif($flags) { $Pyf{_translate} = 1; gen_chunk($DEFAULT_VAR,'=','_translate', '(',$args,",var=$CONVERTER_MAP{S}($DEFAULT_VAR)", ')'); # a=a.translate(str.maketrans(this, that)) issue s8 } else { gen_chunk($DEFAULT_VAR,'=',"$CONVERTER_MAP{S}($DEFAULT_VAR)",'.translate(',$args,')'); # a=a.translate(str.maketrans(this, that)) issue s8 } } else { $Pyf{_translate_and_count} = 1; if($ValPerl[$begin-1] eq '{' && $begin-2 >= 0 && $ValClass[$begin-2] eq 'f' && $ValPerl[$begin-2] eq 'grep') { # issue s135 gen_chunk('_translate_and_count', '(', $args, ', var=', "$CONVERTER_MAP{S}($DEFAULT_VAR)", ')'); # issue s135 } else { # issue s135 gen_chunk('((', $DEFAULT_VAR, ':=', '(', $SUBSCRIPT_TEMP, ':=', '_translate_and_count', '(', $args, ', var=', "$CONVERTER_MAP{S}($DEFAULT_VAR)", '))[0])', ',', $SUBSCRIPT_TEMP, ')[1][1]'); # issue s8 } } return $begin+1; } elsif($py_name eq '_isa_op') { # issue s287 gen_chunk($py_name, '('); my $comma = next_same_level_token(',', $start, $end_pos); if($ValClass[$start] eq 'i') { gen_chunk($ValPy[$start]); } else { $TrStatus = expression($start, $comma-1); } gen_chunk(','); if($ValClass[$comma+1] eq 'i') { gen_chunk($ValPy[$comma+1]); } else { $TrStatus = expression($comma+1, $end_pos); } gen_chunk(')'); }elsif( substr($py_name,0,1) eq '.' ){ #Generic Perl built-in function which is a method in Python my $context=-1; if($py_name =~ /_s$/) { # issue s3: keys or values used in scalar context $context = 1; substr($py_name,-2,2) = ''; } $ValPy[$limit]='' if $bracketed==1; # in this case we do not need to process closing bracket. if($start > $end_pos) { # SNOOPYJC $TrStatus = -1; return -255; } # issue s355 gen_chunk('list(') if($perl_name eq 'keys' && $ValPy[0] eq 'for'); # issue bootstrapping: RuntimeError: dictionary keys changed during iteration # issue s355 gen_chunk('len(') if($context == 1); # issue s3 my $close = ''; # issue s359 if($context == 1) { # issue s3, issue s359 gen_chunk('len('); # issue s3 $close = ')'; # issue s3 } elsif($autovivification && ($perl_name eq 'keys' || $perl_name eq 'values')) { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 $close = ')'; # issue s359 } elsif($ValPy[0] eq 'for' && $perl_name eq 'keys') { # issue bootstrapping: RuntimeError: dictionary keys changed during iteration gen_chunk('list('); # issue bootstrapping $close = ')'; # issue bootstrapping } $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk($py_name); # add method # issue s359 gen_chunk(')') if($perl_name eq 'keys' && $ValPy[0] eq 'for'); # issue bootstrapping # issue s359 gen_chunk(')') if($context == 1); # issue s3 gen_chunk($close) if $close; # issue s359 }elsif($py_name eq '_last_ndx') { # issue 119 gen_chunk('(', 'len', '('); $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk(')', '-1', ')'); }elsif($py_name eq 'math.exp' && $ValClass[$start] eq 'd' && $ValPy[$start] >= 710) { # issue s3 gen_chunk('math.inf'); # issue s3 }elsif($perl_name eq 'bless') { # issue s3 my $comma = next_same_level_token(',', $start, $end_pos); my $end = $comma-1; $end = $end_pos if($end < 0); if($comma < 0) { # issue s266 $comma = next_same_level_token('A', $start, $#ValClass); # issue s266 if($comma != -1) { # issue s266 $end = $comma-1; # issue s266 $end_pos = end_of_variable($comma+1); # issue s266 $limit = $end_pos; # issue s266 } # issue s266 } # issue s266 if($begin == 0 && $ValClass[$start] eq 's' && end_of_variable($start) == $end) { # If bless is used as a statement and we're passing a ref, then assign the ref to the object # issue s266 expression($start, $end, 0); for(my $i = $start; $i <= $end; $i++) { # issue s266: Remove any '.get(...)' we already inserted if($ValClass[$i] eq '(' && $ValPy[$i] eq '.get(') { $ValPy[$i] = '['; } elsif($ValClass[$i] eq ')' && $ValPerl[$i] eq '}' && $ValPy[$i] eq ')') { $ValPy[$i] = ']'; } } insert($end+1, '=', '=', '='); # issue s266: Don't use .get() (we don't send the = to expression as if the bless is in parens it gets changes to := - see issue s207 test for an example!) expression($start, $end, 0); destroy($end+1, 1); # issue s266 gen_chunk('='); } gen_chunk($py_name); gen_chunk('('); if($comma != -1) { $TrStatus = expression($start, $comma-1, 0); return -255 if ($TrStatus<0); gen_chunk(','); if($comma+1 == $end_pos && $ValClass[$end_pos] eq '"' && substr($ValPy[$end_pos],0,1) eq "'") { # escape the package name if necessary $ValPy[$end_pos] = &Perlscan::escape_quotes(escape_keywords(unquote_string($ValPy[$end_pos]), 1)); } $TrStatus = expression($comma+1, $end_pos, 0); return -255 if ($TrStatus<0); } else { $TrStatus=expression($start,$end_pos,0); return -255 if ($TrStatus<0); gen_chunk(','); my $p_escaped = escape_keywords($CurPackage, 1); gen_chunk("'$p_escaped'"); } # issue s216 if((exists $LocalSub{TIEHASH} && $LocalSub{TIEHASH} == 1) || # issue s216 (exists $LocalSub{TIEARRAY} && $LocalSub{TIEARRAY} == 1)) { # issue s154 # issue s216 gen_chunk(', is_tie_package=True'); # issue s154 # issue s216 $PYF_CALLS{_bless} .= ',_add_tie_methods,_raise'; # issue s216 # issue s216 } gen_chunk(')'); } elsif($perl_name eq 'tie') { # issue s154 my $class = $ValClass[$start]; # FIXME: Handle: # tie ${"${callpack}::$name"}, Env, $name; # for use Env; # =|ff("."),i,s|= ValPerl=tie _fetch_perl_global ( ${pkg}::$name . _v ) , TiedScalar , $name my $add_paren = 0; # issue s301 if($class eq 'f' && $ValPy[$start] eq '_fetch_perl_global') { # issue s301 my $close = matching_br($start+1); if($ValPerl[$close-1] eq '_v') { # scalar $class = 's'; $Pyf{_store_perl_meta} = 1; $ValPy[$start] = '_store_perl_meta'; } elsif($ValPerl[$close-1] eq '_a') { # array $class = 'a'; $Pyf{_store_perl_global} = 1; $ValPy[$start] = '_store_perl_global'; } else { $class = 'h'; $Pyf{_store_perl_global} = 1; $ValPy[$start] = '_store_perl_global'; } $add_paren = 1; } if(!exists $TIE_CONSTRUCTORS{$class}) { logme('S', "tie is only supported for arrays, hashes, and scalars"); # issue s301 return $#ValClass+1; } my $constructor = $TIE_CONSTRUCTORS{$class}; my $eq_ok = ($begin == 0); $eq_ok = 0 if $class eq 's' && !$add_paren; # issue s301: We always need _assign_meta gen_chunk('(') unless($eq_ok); if($add_paren) { # issue s301 gen_chunk($ValPy[$start], '('); $TrStatus = expression($start+2, matching_br($start+1)-1, 0); # issue s301 gen_chunk(','); # issue s301 } else { # issue s301 my $dot = rindex($ValPy[$start], '.'); # issue s301 my $add_paren = 0; if($dot >= 0 && !$eq_ok) { my $a = substr($ValPy[$start], 0, $dot); my $b = substr($ValPy[$start], $dot+1); if($class eq 's') { # issue s301 $Pyf{_assign_meta} = 1; # issue s301 gen_chunk('_assign_meta', '(', "'$a'", ',', "'$b'", ','); # issue s301 } else { # issue s301 $Pyf{_assign_global} = 1; gen_chunk('_assign_global', '(', "'$a'", ',', "'$b'", ','); } $add_paren = 1; } else { logme('S', "tie is not supported for scalars declared as 'my' or implicitly declared as 'my' with the -m option") if $class eq 's'; # issue s301 gen_chunk($ValPy[$start]); gen_chunk($eq_ok ? '=' : ':='); } } my $comma = next_same_level_token(',', $start+1, $end_pos); # issue s301 my $pkg = $ValPy[$comma+1]; # issue s301 my $comma2 = next_same_level_token(',', $comma+1, $end_pos); # issue s301 if($comma2 < 0) { # issue s301 $comma2 = $end_pos+1; # issue s301 } # issue s301 if($ValClass[$comma+1] eq 'i') { # issue s175 ; # issue s175 } elsif($ValClass[$comma+1] ne '"' || substr($ValPy[$comma+1],0,1) eq 'f') { #logme('S', "tie is only supported with a constant package specified"); $pkg = undef; } else { $pkg = unquote_string($ValPy[$comma+1]); } if(defined $pkg) { $pkg =~ tr/::/./s; # issue s319 $pkg = escape_keywords($pkg, 1); # issue s301 gen_chunk($pkg, '.', $constructor, '('); } else { # issue s301: Support non-constant package gen_chunk('getattr(main', ','); gen_chunk('('); # issue s319 $TrStatus = expression($comma+1, $comma2-1, 0); gen_chunk(')', ".replace('::', '.')"); # issue s319 gen_chunk(')'); gen_chunk('.', $constructor, '('); } # issue s301 $TrStatus = expression($start+4, $end_pos, 0) if($start+4 <= $end_pos); $TrStatus = expression($comma2+1, $end_pos, 0) if($comma2+1 <= $end_pos); # issue s301 gen_chunk(')'); gen_chunk(')') unless($eq_ok); gen_chunk(')') if($add_paren); } elsif($perl_name eq 'untie') { # issue s154 #gen_statement("if hasattr($ValPy[$start], 'UNTIE'):"); #correct_nest(1,1); #gen_statement("$ValPy[$start].UNTIE()"); #correct_nest(-1,-1); #gen_statement("$ValPy[$start] = None"); #gen_statement("$ValPy[$start] = $ValPy[$start].__untie__()"); if($ValClass[$start] eq 's') { $Pyf{_unassign_meta} = 1; my $pdot = rindex($ValPy[$start],'.'); my $pkg = substr($ValPy[$start],0,$pdot); $pkg = escape_keywords($pkg, 1); # issue s301 my $var = substr($ValPy[$start],$pdot+1); gen_statement($pkg . '.__class__.__dict__[' . "'$var'" . '].__untie__()'); gen_chunk('_unassign_meta', '(', "'$pkg'", ',', "'$var'", ')'); gen_statement(); } else { gen_statement("$ValPy[$start].__untie__()"); } gen_chunk($ValPy[$start], '='); if($ValClass[$start] eq 'a') { if($autovivification) { $Pyf{Array} = 1; gen_chunk('Array', '(', ')'); } else { gen_chunk('[]'); } } elsif($ValClass[$start] eq 's') { gen_chunk('None'); } else { if($autovivification) { $Pyf{Hash} = 1; gen_chunk('Hash', '(', ')'); } else { gen_chunk('{}'); } } } elsif($perl_name eq 'tied') { # issue s154 gen_chunk($ValPy[$start]); # issue s154 }elsif(exists $PYF_OUT_PARAMETERS{$orig_py_name}) { # SNOOPYJC: Function with an "out" parameter (we assume it's the first one), issue s183: Moved code down if($bracketed == -1) { gen_chunk("(($DEFAULT_VAR:=($SUBSCRIPT_TEMP:=", $py_name, "($DEFAULT_VAR))[0]),$SUBSCRIPT_TEMP", '[1])[1]'); } else { my ($text_s, $text_e); if($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S}) { $text_s = $start+2; $text_e = end_of_variable($text_s); } elsif($ValClass[$start] eq '(' && ($text_e = next_same_level_token('=', $start+1, matching_br($start))) != -1) { # issue s167: (e := '...') $text_s = $start+1; # issue s167 $text_e--; # issue s167 } else { $text_s = $start; $text_e = end_of_variable($text_s); } my $extra = ''; # issue s184 my $cs = &Perlscan::cur_sub(); # issue s185 if($text_s == $text_e && $ValPy[$text_s] =~ /^(.*)\[(\d+)\]$/) { # issue s183: This is an argument to a sub my $var = $1; # issue s183 my $subscript = $2; # issue s183 # issue s184 $Pyf{_set_element} = 1; # issue s183 # issue s184 gen_chunk('(', '_set_element', "(", $var, ',', $subscript, ','); # issue s183 $Pyf{_store_out_parameter} = 1; # issue s184 gen_chunk('(', '_store_out_parameter', "(", $var, ',', $subscript, ','); # issue s184 gen_chunk("($SUBSCRIPT_TEMP:=", $py_name, '('); # issue s183 my $als = 0; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $extra = ", shifts=$als" if($als); # issue s184 # issue s241 } elsif($text_s == $text_e && $ValType[$text_s] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$text_s]}) { # issue s185: This is a copy of a reference argument to a sub } elsif($text_s == $text_e && $ValType[$text_s] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$text_s]}) { # issue s185: This is a copy of a reference argument to a sub, issue s241 # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$text_s]}; # issue s185 my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$text_s]}; # issue s185, issue s241 $Pyf{_store_out_parameter} = 1; # issue s185 gen_chunk('(', '_store_out_parameter', "(", 'None', ',', $arg, ','); # issue s185 gen_chunk('(', $ValPy[$text_s], ':='); # issue s185 gen_chunk("($SUBSCRIPT_TEMP:=", $py_name, '('); # issue s185 $extra = ')'; } elsif($text_s == $text_e && index($ValPy[$text_s],'.')<0) { gen_chunk("(($ValPy[$text_s]:=($SUBSCRIPT_TEMP:=", $py_name, '('); } elsif($text_s == $text_e) { my $pdot = rindex($ValPy[$text_s],'.'); my $pkg = substr($ValPy[$text_s],0,$pdot); my $var = substr($ValPy[$text_s],$pdot+1); $Pyf{_assign_global} = 1; gen_chunk('(', '_assign_global', "('$pkg', '$var', ($SUBSCRIPT_TEMP:=", $py_name, '('); } elsif($ValClass[$text_s] eq 'f' && $ValPy[$text_s] eq '_assign_global') { # issue s167 my $pkg = unquote_string($ValPy[$text_s+2]); my $var = unquote_string($ValPy[$text_s+4]); gen_chunk('(', '_assign_global', "('$pkg', '$var', ($SUBSCRIPT_TEMP:=", $py_name, '('); } elsif($ValClass[$text_s] eq 'f' && $ValPy[$text_s] =~ /^_[a-z]+_element$/) { # issue s167: _set_element and friends my $base_s = $text_s+2; my $close = matching_br($text_s+1); # issue s271 my $comma = next_same_level_token(',', $text_s+2, $close-1); my $comma = next_same_level_tokens(',A', $text_s+2, $close-1); # issue s271 my $base_e = $comma-1; my $index_s = $comma+1; # issue s271 $comma = next_same_level_token(',', $index_s, $close-1); $comma = next_same_level_tokens(',A', $index_s, $close-1); my $index_e = $comma-1; gen_chunk('(', '_set_element', "("); $TrStatus = expression($base_s,$base_e,0); gen_chunk(','); $TrStatus = expression($index_s,$index_e,0); gen_chunk(','); gen_chunk("($SUBSCRIPT_TEMP:=", $py_name, '('); } else { my $rev = reverse_matching_br($text_e); $Pyf{_set_element} = 1; gen_chunk('(', '_set_element', '('); $TrStatus = expression($text_s,$rev-1,0); gen_chunk(','); $TrStatus = expression($rev+1,$text_e-1,0); gen_chunk(','); gen_chunk("($SUBSCRIPT_TEMP:=", $py_name, '('); } $TrStatus = expression($start,$end_pos,0); # issue s184 gen_chunk("))[0]),$SUBSCRIPT_TEMP", '[1])[1]'); gen_chunk("))[0]$extra),$SUBSCRIPT_TEMP", '[1])[1]'); } }elsif($perl_name eq 'scalar' && ($ValPy[$start] =~ /\blen\(/ || # Don't make a double-len ($ValClass[$start] eq 'i' && get_sub_attribute_at($start, 'wantarray') || ($start+3 <= $#ValClass && $ValClass[$start+2] eq 'D' && $ValClass[$start+3] eq 'i' && get_sub_attribute_at($start+3, 'wantarray'))))) { # issue s254 # issue s254: Generate no code for scalar(mysub(...)), where mysub has a 'wantarray' # because it will be returning a scalar already and that scalar may be None, and also # since we changed the arg type of scalar to 'm' from 'a', we don't gen any code if # the argument already has a len function on it $TrStatus=expression($start,$end_pos,0) if $start <= $end_pos; # issue s254 return -255 if ($TrStatus<0); # issue s254 }elsif($perl_name eq 'scalar' && $ValPerl[$start] eq '(' && $start+3 <= $#ValClass && $ValPerl[$start+1] eq ')' && $ValClass[$start+2] eq '=' && $ValClass[$start+3] eq 'f' && $ValPy[$start+3] eq 'lena') { # issue s302 # issue s302: Generate no code for scalar(() = lena(...)) since we already applied the len function $TrStatus=expression($start,$end_pos,0) if $start <= $end_pos; # issue s302 return -255 if ($TrStatus<0); # issue s302 }else{ $py_name = 'len' if($py_name eq 'lens'); # SNOOPYJC: string len has a different type but same function $py_name = 'len' if($py_name eq 'lena'); # issue s254: goatse uses 'scalar' mapped to this len function if($py_name eq '_ref' && ( ($ValClass[$start] eq "\\" || expression_uses_builtin_types($begin)) || is_scalar_out_parameter($start))) { # issue s3, issue s57, issue scalar ref $py_name = '_refs'; $Pyf{_refs} = 1; } elsif($py_name eq "$PERLLIB.ref" && ( ($ValClass[$start] eq "\\" || expression_uses_builtin_types($begin)) || is_scalar_out_parameter($start))) { # issue s3, issue s57, issue scalar ref $py_name = "$PERLLIB.refs"; } elsif($py_name eq '_ref' && $ValClass[$start] eq 's' && $ValType[$start] ne 'ss') { # issue scalar ref $py_name = '_ref_scalar'; $Pyf{_ref_scalar} = 1; } elsif($py_name eq "$PERLLIB.ref" && $ValClass[$start] eq 's' && $ValType[$start] ne 'ss') { # issue scalar ref $py_name = "$PERLLIB.ref_scalar"; } my $close = ''; # issue s359 if($autovivification) { my $ftype = substr(&Pythonizer::func_type($ValPerl[$begin], $ValPy[$begin]),0,1); # issue s359 $ftype = '' if($perl_name eq 'stat' || $perl_name eq 'lstat') && $uses_file_stat; # issue s359: Special object - not an array if(exists $AUTOVIVIFICATION_CONVERTER_MAP{$ftype}) { # issue s359 my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$ftype}; # issue s359 $Pyf{$converter} = 1; # issue s359 gen_chunk($converter, '('); # issue s359 $close = ')'; # issue s359 } # issue s359 } if ( $bracketed==-1 || $end_pos < $start){ # issue paren gen_chunk($py_name); # zero arguments -- special case gen_chunk('()'); # issue 13 }elsif( $end_pos==$start ){ # issue 13 # single argument # issue 13: int(PI) needs to call PI()!! # issue 13 gen_chunk('('.$ValPy[$start].')') }else{ gen_chunk('*') if $py_name eq '_method_call' && need_splat($start); # Promote the * gen_chunk($py_name); gen_chunk('('); gen_chunk('*') if($py_name ne 'len' && $perl_name ne 'ref' && $perl_name ne 'each' && $py_name ne '_get_element' && $py_name ne '_fetch_out_parameters' && # issue s184 $py_name ne '_set_element' && # issue s148 $py_name ne '_smartmatch' && # issue s251 $py_name ne '_flatten' && # issue s251 $py_name ne '_method_call' && $py_name ne '_sl' && # issue s308 $py_name ne '_list_to_hash' && # issue s316 $py_name ne 'min' && $py_name ne 'max' && $py_name ne 'math.prod' && $py_name ne 'sum' && # test list util need_splat($start)); # SNOOPYJC, issue s40 my $add_bracket = 0; # test list util if(($py_name eq 'math.prod' || $py_name eq 'sum' || # issue s271 (($py_name eq 'max' || $py_name eq 'min') && next_same_level_token(',', $start, $end_pos) < 0)) (($py_name eq 'max' || $py_name eq 'min') && next_same_level_tokens(',A', $start, $end_pos) < 0)) # issue s271 && !need_splat($start)) { # test list util gen_chunk('['); $add_bracket = 1; } my $comma; # issue s271 while(($comma = next_same_level_token(',', $start, $end_pos)) >= 0) { # issue bootstrap - handle one arg at a time while(($comma = next_same_level_tokens(',A', $start, $end_pos)) >= 0) { # issue bootstrap - handle one arg at a time, issue s271 if($ValClass[$start] eq 'f') { # issue s154: handle _assign_global('a', 'b', tie @h, 'Package', args) my $eof = end_of_function($start); # issue s154 if($eof > $comma) { # issue s154 $comma = $eof + 1; # issue s154 } # issue s154 } elsif($ValClass[$start] eq 'i' && $LocalSub{$ValPy[$start]} && $ValPerl[$start+1] ne '(') { # issue s237: handle 2 xor test_sub 2, 3 last; # issue s237: sub without args: the rest of the args are his, not ours } # issue s154 $TrStatus=expression($start,$comma-1,0); return -255 if ($TrStatus<0); gen_chunk(','); $start = $comma+1; last if $start > $end_pos; } gen_chunk('*') if $py_name eq '_method_call' && need_splat($start); # test Encode $TrStatus=expression($start,$end_pos,0) if $start <= $end_pos; return -255 if ($TrStatus<0); gen_chunk(']') if $add_bracket; # test list util gen_chunk(')'); } gen_chunk($close) if $close; # issue s359 } return $#ValClass+1 if(!defined $limit); # SNOOPYJC return $limit+1; # limit_1 always represnt the first not scanned symbol for this function. } #function sub function # SNOOPYJC { my $result = _function(@_); if($debug >= 3) { my (undef, $fn, $ln) = caller(0); say STDERR "function($_[0]) returns $result (called from $fn:$ln)" if(scalar(@_) == 1); say STDERR "function($_[0], $_[1]) returns $result (called from $fn:$ln)" if(scalar(@_) == 2); } return $result; } sub need_splat # SNOOPYJC: Does this function/sub arg need a '*' before it? { my $k = shift; return 0 if($k > $#ValClass); if(($ValClass[$k] eq 'a' || ($ValClass[$k] eq 's' && defined $ValType[$k] && $ValType[$k] eq '@s')) # issue s316 && substr($ValPy[$k],0,1) ne '*' # issue s316 && substr($ValPy[$k],0,4) ne 'len(') { return 0 if $k+1 <= $#ValClass && $ValClass[$k+1] eq 'y' && $ValPerl[$k+1] eq 'multi'; # issue s206: eg @hash{29, 32} return 1; } if($ValClass[$k] eq 'f' && substr(&Pythonizer::func_type($ValPerl[$k], $ValPy[$k]),0,1) eq 'a') { #NOTE: The following code is now handled by func_type: #if(exists $Perlscan::SPECIAL_FUNCTION_MAPPINGS{$ValPerl[$k]} && #$Perlscan::SPECIAL_FUNCTION_MAPPINGS{$ValPerl[$k]}{scalar} eq $ValPy[$k]) { #return 0; #} # issue s113: If this function is part of an OO construct, like stat(...)->mtime, then don't splat it! my $eof = end_of_function($k); # issue s113 #say STDERR "=|$TokenStr|= k=$k, eof=$eof, @ValPy"; # TEMP return 0 if $eof > $k && $eof < $#ValClass && $ValClass[$eof+1] eq 'D'; # issue s113 return 0 if $k != 0 && $ValClass[$k-1] eq 'y' && $ValPerl[$k-1] eq 'multi'; # issue s206: eg @arr[@ndx] return 1; } elsif($ValClass[$k] eq 's') { # $val =~ /regex/ is in list context $k = end_of_variable($k); # issue s151 return 1 if($k+2 <= $#ValClass && $ValClass[$k+1] eq '~' && $ValClass[$k+2] eq 'q'); return 1 if($k+2 <= $#ValClass && $ValClass[$k+1] eq 'p' && $ValClass[$k+2] eq 'q'); # issue s151 } elsif($ValClass[$k] eq '"') { # issue s308: 'str' =~ /regex/ is in list context return 1 if($k+2 <= $#ValClass && $ValClass[$k+1] eq 'p' && $ValClass[$k+2] eq 'q') && # for sub 'abc' =~ /pat/, the 'abc' belongs to the sub call, which the result is matched to the pattern $k-1 >= 0 && ($ValClass[$k-1] eq '(' || $ValClass[$k-1] eq ','); # issue s308 } elsif($ValClass[$k] eq 'q' && $ValPy[$k] =~ /\.split\(\)$/) { # qw(w1 w2 ..) return 0 if defined $ValType[$k] && $ValType[$k] eq 's'; # [qw(...)] doesn't get splatted return 1; } elsif($ValClass[$k] eq '(' && $ValPerl[$k] eq '(') { # issue s205 my $end = matching_br($k); # issue s205 return 0 if $end <= 0; # issue s205 return 0 if($end+1 <= $#ValClass && $ValClass[$end+1] eq '(' && ($ValPy[$end+1] eq '[' || $ValPy[$end+1] eq '.get(')); # Being subscripted, issue s359 return need_splat($k+1); # issue s205 } elsif($ValClass[$k] eq 'g') { # issue s249: globs need splats! return 1; # issue s249 } return 0; } sub getopts_fun # issue s67: implement getopt/getopts { my $which = shift; # getopt or getopts my $start = shift; my $end_pos = shift; if($ValClass[$start] ne '"' || substr($ValPy[$start],0,1) eq 'f') { logme('S', "$which with non-constant arg is not supported"); gen_chunk("$which # FAILTRAN"); return; } # Generate the options string for getopt.getopt if($which eq 'getopt') { $options = ''; for(my $o = ord('A'); $o <= ord('z'); $o++) { if(index($ValPerl[$start], chr($o)) >= 0) { $options .= chr($o) . ':'; } else { $options .= chr($o); } $o = ord('a')-1 if($o eq ord('Z')); } } else { $options = $ValPerl[$start]; } # issue s150: Determine if we need to capture a result or not my $need_result = 0; $need_result = 1 if($ValClass[0] eq 's' && $ValClass[1] eq '='); $need_result = 1 if($ValClass[0] eq 't' && $ValClass[1] eq 's' && $ValClass[2] eq '='); if($need_result) { gen_statement('try:'); correct_nest(1,1); } gen_statement("(${ARG_PARSER}_res, ${ARG_PARSER}_rem) = getopt.getopt(sys.argv[1:], '$options')"); # See if we have an options hash or not if($ValClass[$end_pos] eq 'h') { gen_statement("$ValPy[$end_pos] = {${ARG_PARSER}_res[$INDEX_TEMP][0][1:]: ${ARG_PARSER}_res[$INDEX_TEMP][1] for $INDEX_TEMP in range(len(${ARG_PARSER}_res))}"); gen_statement("for $SUBSCRIPT_TEMP in $ValPy[$end_pos]:"); correct_nest(1,1); gen_statement("if f'{$SUBSCRIPT_TEMP}:' not in '$options':"); correct_nest(1,1); gen_statement("$ValPy[$end_pos]\[$SUBSCRIPT_TEMP] = '1'"); correct_nest(-2,-2); } else { gen_statement("${ARG_PARSER}_opts = {${ARG_PARSER}_res[$INDEX_TEMP][0][1:]: ${ARG_PARSER}_res[$INDEX_TEMP][1] for $INDEX_TEMP in range(len(${ARG_PARSER}_res))}"); for(my $i = 0; $i < length($options); $i++) { my $c = substr($options,$i,1); next if($c eq ':'); if($which eq 'getopt') { # See if this variable is referenced in the program, if not, skip it next if(!exists $Perlscan::NameMap{"opt_$c"} || !exists $Perlscan::NameMap{"opt_$c"}{'$'}); } my $var = "opt_$c"; my $perl_name = '$' . $var; # issue s71 if(exists $Perlscan::NameMap{"opt_$c"}{'$'}) { $var = $Perlscan::NameMap{"opt_$c"}{'$'}; } if(!$::implicit_global_my) { # issue s71 $var = $CurPackage . '.' . $var; # issue s71 } # issue s71 if(substr($options,$i+1,1) eq ':') { # option takes an arg gen_statement("$var = ${ARG_PARSER}_opts\['$c'] if '$c' in ${ARG_PARSER}_opts else None"); } else { # option takes no arg gen_statement("$var = '1' if '$c' in ${ARG_PARSER}_opts else None"); } } } gen_statement("sys.argv[1:] = ${ARG_PARSER}_rem"); # issue 24 if($need_result) { # issue s150 gen_statement("$ELSIF_TEMP = 1"); correct_nest(-1,-1); gen_statement('except getopt.GetoptError as _err:'); correct_nest(1,1); gen_statement('print(_err, file=sys.stderr, end="")'); gen_statement("$ELSIF_TEMP = ''"); correct_nest(-1,-1); } } sub GetOptionsHandled # issue 48: Can we handle this GetOptions call? { # We handle 2 types of GetOptions calls. # Type 1: GetOption(\%hash, str, str, str, str, ...); # Type 2: GetOptions(str => \$var, str => \$var, ...); my $start = shift; my $end_pos = shift; # # First we check for Type 1: # if($ValClass[$start] eq '\\' && $ValClass[$start+1] eq 'h') { for(my $i = $start+2; ($i+1) <= $end_pos; $i+=2) { return 0 if($ValClass[$i] ne ','); return 0 if($ValClass[$i+1] ne '"'); } return 1; } else { # Check for Type 2: for(my $i = $start; ($i+4) <= $end_pos; $i += 5) { return 0 if($ValClass[$i] ne '"'); return 0 if($ValClass[$i+1] ne 'A'); # issue 93 return 0 if($ValClass[$i+2] ne '\\'); return 0 if($ValClass[$i+3] ne 's' && $ValClass[$i+3] ne 'a'); return 0 if($ValClass[$i+4] ne ',' && $ValClass[$i+4] ne ')'); } return 2; } } sub GetOptions_split # issue 48: Split the string GetOptions argument and return the pieces as a 4-array { my $str = shift; my ($key, $op, $typ, $arr) = $str =~ /([A-Za-z0-9_-|]+)([:=!+]?)([a-z0-9]*)([\%\$\@\{\d,\}]*)/; my @keys = split /[|]/, $key; #say STDERR "GetOptions_split($str): keys = @keys\n"; for(my $i=0; $i'str', i=>'int', f=>'float'); $typ = $TypeMap{$typ} if(exists $TypeMap{$typ}); #say STDERR "GetOptions_split($str) = (@keys, $op, $typ, $arr)\n"; return (\@keys, $op, $typ, $arr); } sub GetOptions_fun # issue 48: Generate code for GetOptions { my $type = shift; # 1 or 2 my $start = shift; my $end_pos = shift; # issue s150: Determine if we need to capture a result or not my $need_result = 0; $need_result = 1 if($ValClass[0] eq 's' && $ValClass[1] eq '='); $need_result = 1 if($ValClass[0] eq 't' && $ValClass[1] eq 's' && $ValClass[2] eq '='); $Pyf{_preprocess_arguments} = 1; if($import_perllib) { gen_statement("$PERLLIB.preprocess_arguments()"); } else { gen_statement('_preprocess_arguments()'); } if($need_result) { gen_statement("$ARG_PARSER = argparse.ArgumentParser(argument_default=argparse.SUPPRESS, exit_on_error=False)"); } else { gen_statement("$ARG_PARSER = argparse.ArgumentParser(argument_default=argparse.SUPPRESS)"); } if($type == 1) { # Type 1: GetOptions(\%hash, str, str, str...); for(my $i = $start+2; $i <= $end_pos; $i+=2) { my ($keys, $op, $typ, $arr) = GetOptions_split($ValPerl[$i+1]); gen_chunk("$ARG_PARSER.add_argument("); foreach my $key (@$keys) { gen_chunk("\"$key\", "); } $const = '""'; $const = '0' if($typ eq 'int' || $typ eq 'float'); if($typ =~ /\d+/) { gen_chunk("type=int, "); $const = $typ; $typ = 'int'; } elsif($typ) { gen_chunk("type=$typ, ") } if($arr eq '%') { logme('S', "Sorry, GetOptions(...'$ValPerl[$i+1]'...) - '%' hash option is not supported!"); $TrStatus=-1; } $nargs = ''; if($op eq ':') { $nargs = "'*'"; } elsif($op eq '=') { $nargs = "'+'"; } if($nargs) { if($arr eq '@') { gen_chunk("action='append', "); } elsif($arr =~ /{(\d+)}/) { gen_chunk("nargs=$1, "); } elsif($arr =~ /{,\d+}/ || $arr =~ /{,}/) { gen_chunk("nargs=$nargs, "); } elsif($arr =~ /{0,\d+}/) { gen_chunk("nargs='*', "); } elsif($arr =~ /{(\d+),(\d+)}/) { if($1 eq $2) { gen_chunk("nargs=$1, "); } else { gen_chunk("nargs='+', "); } } elsif($op eq ':') { gen_chunk("nargs='?', const=$const, "); } } if($op eq '+') { gen_chunk("action='count', default=0, "); } if($op eq '!' || $op eq '') { gen_chunk("action='store_true')"); gen_statement(); } if($op eq '!') { gen_chunk("$ARG_PARSER.add_argument("); foreach my $key (@$keys) { next if(length($key) == 2); # skip single flags gen_chunk('"--no'.substr($key,2)."\", action='store_false', dest=\"".substr($key,2).'")'); } } elsif($op ne '') { $Perlscan::PythonCode[-1] =~ s/, $/)/; # Change the trailing ', ' to a ')' } gen_statement(); } if($need_result) { # issue s150 gen_statement('try:'); correct_nest(1,1); } gen_statement("(${ARG_PARSER}_res, ${ARG_PARSER}_rem) = $ARG_PARSER.parse_known_args()"); gen_statement("$ValPy[$start+1].update(vars(${ARG_PARSER}_res))"); # issue 24 gen_statement("sys.argv[1:] = $PERL_ARG_ARRAY = ${ARG_PARSER}_rem"); $Pyf{_postprocess_arguments} = 1; # issue s150 gen_chunk('_postprocess_arguments', "($ARG_PARSER, ${ARG_PARSER}_rem)"); # issue s150 gen_statement(); # issue s150 gen_statement("sys.argv[1:] = ${ARG_PARSER}_rem"); # issue 24 } else { # Type 2: GetOptions(str => \$var, str => \$var, ...); for(my $i = $start; $i <= $end_pos; $i+=5) { my ($keys, $op, $typ, $arr) = GetOptions_split($ValPerl[$i]); gen_chunk("$ARG_PARSER.add_argument("); foreach my $key (@$keys) { gen_chunk("\"$key\", "); } $const = '""'; $const = '0' if($typ eq 'int' || $typ eq 'float'); if($typ =~ /\d+/) { gen_chunk("type=int, "); $const = $typ; $typ = 'int'; } elsif($typ) { gen_chunk("type=$typ, ") } #say STDERR "typ=$typ\n"; $dest = $ValPy[$i+3]; if($arr eq '%' || $ValClass[$i+3] eq 'h') { logme('S', "Sorry, GetOptions(...'$ValPerl[$i]'=>\\\%$ValPerl[$i+3]...) - '%' hash option is not supported!"); $TrStatus=-1; } $nargs = ''; if($op eq ':') { $nargs = "'*'"; } elsif($op eq '=') { $nargs = "'+'"; } if($nargs) { if($arr eq '@') { gen_chunk("action='append', "); } elsif($arr =~ /{(\d+)}/) { gen_chunk("nargs=$1, "); } elsif($arr =~ /{,\d+}/ || $arr =~ /{,}/) { gen_chunk("nargs=$nargs, "); } elsif($arr =~ /{0,\d+}/) { gen_chunk("nargs='*', "); } elsif($arr =~ /{(\d+),(\d+)}/) { if($1 eq $2) { gen_chunk("nargs=$1, "); } else { gen_chunk("nargs='+', "); } } elsif($ValClass[$i+3] eq 'a') { gen_chunk("action='append', "); } elsif($op eq ':') { gen_chunk("nargs='?', const=$const, default=$dest, "); } } if($op eq '+') { gen_chunk("action='count', default=0)"); } if($op eq '!' || $op eq '') { gen_chunk("action='store_true', default=bool($dest))"); gen_statement(); } if($op eq '!') { gen_chunk("$ARG_PARSER.add_argument("); foreach my $key (@$keys) { next if(length($key) == 2); # skip single flags gen_chunk('"--no'.substr($key,2)."\", action='store_false', dest=\"".substr($key,2).'")'); } } elsif($op ne '') { $Perlscan::PythonCode[-1] =~ s/, $/)/; # Change the trailing ', ' to a ')' #} elsif($op ne '' && $op ne '+') { #gen_chunk("default=bool($dest))"); } gen_statement(); } if($need_result) { # issue s150 gen_statement('try:'); correct_nest(1,1); } gen_statement("(${ARG_PARSER}_res, ${ARG_PARSER}_rem) = $ARG_PARSER.parse_known_args()"); gen_statement("${ARG_PARSER}_opts=vars(${ARG_PARSER}_res)"); for(my $i = $start; $i <= $end_pos; $i+=5) { $dest = $ValPy[$i+3]; my ($keys, $op, $typ, $arr) = GetOptions_split($ValPerl[$i]); my $key = @$keys[0]; $key =~ s/^[-]+//; gen_statement("$dest = ${ARG_PARSER}_opts.get(\"$key\", $dest)"); } # issue 24 gen_statement("sys.argv[1:] = $PERL_ARG_ARRAY = ${ARG_PARSER}_rem"); $Pyf{_postprocess_arguments} = 1; # issue s150 gen_chunk('_postprocess_arguments', "($ARG_PARSER, ${ARG_PARSER}_rem)"); # issue s150 gen_statement(); # issue s150 gen_statement("sys.argv[1:] = ${ARG_PARSER}_rem"); # issue 24 } if($need_result) { # issue s150 gen_statement("$ELSIF_TEMP = 1"); correct_nest(-1,-1); gen_statement('except argparse.ArgumentError as _err:'); correct_nest(1,1); gen_statement('print(_err, file=sys.stderr, end="")'); gen_statement("$ELSIF_TEMP = ''"); correct_nest(-1,-1); } } sub open_fun # # Process Perl open statement # assents three parameters # start -- Starting postion # limit -- End position # mode -- 's' or 'f' statement or invocation in expression, or 'c' if it's an "if not open" { my ($start,$limit,$mode)=@_; my $end_pos=($ValPerl[$start+1] eq '(') ? matching_br($start+1)-1 : $limit; my($k,$myline, $target,$open_mode,$handle); # open (SYSFORM,'>',$output_file ) || abend(__LINE__,"Cannot open file $output_file for"); $k=($ValPerl[$start+1] eq '(') ? $start+2: $start+1; $handle=$ValPy[$k]; my $handle_reference_arg; my $cs = &Perlscan::cur_sub(); # issue s185 # issue s241 if($ValType[$k] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$k]}) { # issue s185 # issue s241 $handle_reference_arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$k]}; # issue s185 if($ValType[$k] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$k]}) { # issue s185, issue s241 $handle_reference_arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$k]}; # issue s185, issue s241 } unless( $ValClass[$k] =~ /[is]/ ){ logme('W',"In open statement handle $ValPerl[$k] is not identifier or scalar variable. Translation might be incorrect"); } $Constants{$handle} = 1 if $ValClass[$k] eq 'i'; # issue 13 my $encoding = ''; # SNOOPYJC my $errors = ''; # SNOOPYJC my $dup = ''; # SNOOPYJC $target = undef; # SNOOPYJC my $variable_mode = ''; my $expr_mode_start = undef; # issue code coverage my $expr_mode_end; $k+=2 if( $ValPerl[$k+1] eq ','); # SNOOPYJC if( $ValClass[$k] eq '"' && ($k+1) <= $#ValClass && $ValClass[$k+1] eq ',' ){ if( ($k+1) <= $#ValClass && $ValClass[$k+1] eq ',' ){ if($ValClass[$k] eq '"') { # this is the second argument like in open(FILE,'>',$path); $open_mode=$ValPerl[$k]; # constant without quotes if(substr($open_mode,-1,1) eq '&') { # SNOOPYJC: dup $dup = '&'; # SNOOPYJC: dup substr($open_mode,-1,1) = ''; # SNOOPYJC: dup } } elsif($ValClass[$k] eq 's') { # SNOOPYJC: Variable $open_mode = undef; # SNOOPYJC $variable_mode=$ValPy[$k]; # SNOOPYJC } else { # SNOOPYJC return -1; # SNOOPYJC } # SNOOPYJC $k+=2; if( $ValClass[$k] eq '"' || ($ValClass[$k] eq 's' && end_of_variable($k) == $k) ){ # issue s166 $target=$ValPy[$k]; } elsif($ValClass[$k] eq 'i') { # issue s166: Could be a file handle or a sub call with no args $target=escape_keywords($ValPy[$k]); # issue s166 $target .= '()' if $LocalSub{$ValPy[$k]}; # issue s166 } }elsif( $ValClass[$k] eq '"' ){ # ValPerl does not preserve quotes # SNOOPYJC if( $ValPy[$k]=~/^(f?['"])([<->])+/ ){ if( $ValPy[$k]=~/^(f?['"]+)\s*([<>+|-]*)([&]?)\s*(.*?)\s*([|]?)\s*(['"]+)$/) { # SNOOPYJC $str_open=$1; # SNOOPYJC $open_mode=$2; # SNOOPYJC $dup=$3; # SNOOPYJC $file=$4; # SNOOPYJC $pipe=$5; # SNOOPYJC $str_close=$6; # SNOOPYJC if($open_mode eq '<-') { # SNOOPYJC $target = "sys.stdin"; $open_mode = undef; } elsif($open_mode eq '->') { $target = "sys.stdout"; $open_mode = undef; } else { $target = $str_open.$file.$str_close; } if($pipe) { $open_mode = '-|'; } # SNOOPYJC substr($ValPy[$k],length($1),1)=''; # SNOOPYJC $target=$ValPy[$k]; } if(defined $open_mode && $open_mode eq '' && $ValPy[$k] =~ /^['"]/) { # SNOOPYJC: Not an 'f' string # implicit filemode $open_mode='<'; $target=$ValPy[$k]; } }elsif( $ValClass[$k] eq 's' ){ # implicit filemode # issue 26 $open_mode='>'; $open_mode=undef; # issue 26 if($k == $end_pos) { # SNOOPYJC: Simple variable $target=$ValPy[$k]; } else { # SNOOPYJC: Expression for target $target = undef; } }elsif( $ValClass[$k] eq 'i' ) { # issue s166: Could be a FH or a sub call w/o arguments $open_mode=undef; # issue 26 $target=escape_keywords($ValPy[$k]); $target .= '()' if $LocalSub{$ValPy[$k]}; } elsif(($expr_mode_end = next_same_level_token(',', $k, $end_pos)) >= 0) { # complex mode expression $open_mode=undef; $expr_mode_start = $k; $k = $expr_mode_end+1; $expr_mode_end--; } # SNOOPYJC if ($target eq '-' ) { # SNOOPYJC $target='sys.argv[1]'; # SNOOPYJC } if (defined $open_mode) { # SNOOPYJC if(index($open_mode, ':') >= 0) { ($open_mode, $ext) = split /:/, $open_mode; $open_mode .= 'b' if($ext eq 'raw' || $ext eq 'bytes'); if($ext =~ /encoding\((.*)\)/) { $encoding = ", encoding='$1'"; } elsif($ext eq 'utf8') { $encoding = ", encoding='UTF-8'"; $errors = ", errors='ignore'"; } } if (exists($PyOpen{$open_mode}) ){ # SNOOPYJC $open_mode=$PyOpen{$open_mode} }else{ # SNOOPYJC logme('E',"The mode '$open_mode' in open statement needs to be manually translated to Python"); # SNOOPYJC $open_mode = '?'; $variable_mode = &Perlscan::escape_quotes($open_mode); # SNOOPYJC: Let _open_dynamic deal with it undef $open_mode; # SNOOPYJC } } my $function = '_open'; # SNOOPYJC if(!defined $open_mode) { $function = '_open_dynamic'; $Pyf{'_open'} = 1; $Pyf{'_dup'} = 1; $open_mode = ''; $open_mode = ", $variable_mode" if($variable_mode); if($k == $end_pos && $ValClass[$k] eq 'i' && $k <= $start+2) { # one arg open, issue s166: make sure there is only 1 thing replace($k, 's', '$'.$ValPerl[$k], scalar_var_name($ValPy[$k])); if(index($ValPy[$k], '.') < 0) { $ValPy[$k] = $CurPackage . '.' . $ValPy[$k] unless($implicit_global_my); } $target = $ValPy[$k] if defined $target; # issue s166 } } else { $open_mode = ", '$open_mode'"; if($dup) { $function = '_dup'; } } $Pyf{$function} = 1; # SNOOPYJC my $orig_mode = $mode; # SNOOPYJC: Handle complex handle $handle = escape_keywords($handle); # issue s25 if($mode ne 's' && ($handle !~ /^[A-Za-z0-9_]+$/ || defined $handle_reference_arg)) { # issue s185 $mode = 's'; save_code(); } if( $mode eq 'f' ){ # SNOOPYJC logme('E',"In case of error open function in Python raises the FileNotFoundError exception. The code should be revised"); # SNOOPYJC gen_chunk("($handle:=open($target,'$open_mode'))"); if(defined $target) { # SNOOPYJC gen_chunk("($handle:=", "$function", "($target$open_mode$encoding$errors))"); # SNOOPYJC } else { # SNOOPYJC gen_chunk("($handle:=", "$function", '('); # SNOOPYJC expression($k,$end_pos,0); # SNOOPYJC if(defined $expr_mode_start) { # issue code coverage gen_chunk(','); expression($expr_mode_start, $expr_mode_end, 0); } gen_chunk("$open_mode$encoding$errors))"); # SNOOPYJC } # issue paren return $k+1 if ($ValClass[$k+1] eq ')'); return $k+1 if ($ValPerl[$start+1] eq '('); # issue paren return $k+1; return $k; # issue paren }elsif( $mode eq 's' ){ # SNOOPYJC $k+=2; my $extra = ''; # issue s184 if($handle =~ /^$PERL_ARG_ARRAY\[(\d+)\]/ || defined $handle_reference_arg) { # issue s184, issue s185 my $which_arg; my $als = 0; # issue s184 if(defined $handle_reference_arg) { # issue s185 $which_arg = $handle_reference_arg; # issue s185 } else { # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $which_arg = $1; # issue s184 } $Pyf{_store_out_parameter} = 1; # issue s184 if(defined $handle_reference_arg) { # issue s185 gen_chunk('_store_out_parameter', '(', 'None', ',', $which_arg, ',', '(', "$handle := ", "$function", '('); # issue s185 $extra = '))'; # issue s185 } else { gen_chunk('_store_out_parameter', '(', $PERL_ARG_ARRAY, ',', $which_arg, ',', "$function", '('); # issue s184 $extra = ')'; # issue s184 } $extra = ", shifts=$als)" if($als); # issue s184 } else { # issue s184 gen_chunk("$handle = ", "$function", '('); # issue s184 } if(defined $target) { # SNOOPYJC # issue s184 gen_chunk("$handle = ", "$function", "($target$open_mode$encoding$errors, checked=False)"); gen_chunk("$target$open_mode$encoding$errors, checked=False)"); # issue s184 # issue s252 gen_statement(); } else { # issue s184 gen_chunk("$handle = ", "$function", '('); expression($k,$end_pos,0); # SNOOPYJC if(defined $expr_mode_start) { # issue code coverage gen_chunk(','); expression($expr_mode_start, $expr_mode_end, 0); } gen_chunk("$open_mode$encoding$errors, checked=False)"); } gen_chunk($extra) if($extra); # issue s184 }elsif( $mode eq 'c' ){ # Control statement, like if if(defined $target) { # SNOOPYJC gen_chunk("if not ($handle:=", "$function", "($target$open_mode$encoding$errors)):"); gen_statement(); } else { gen_chunk("if not ($handle:=$function("); expression($k,$end_pos,0); # SNOOPYJC if(defined $expr_mode_start) { # issue code coverage gen_chunk(','); expression($expr_mode_start, $expr_mode_end, 0); } gen_chunk("$open_mode$encoding$errors)):"); } $Perlscan::PREV_HAD_COLON = 1; } #if mode if($mode ne $orig_mode) { # SNOOPYJC: Handle complex handle like sys.stderr that can't appear in a := gen_statement(); restore_code(); # issue 26: Since we are using "checked=False", we get back a closed file handle, not a "None" if($orig_mode eq 'f') { gen_chunk('not', $handle, '.closed'); # issue 26 } else { output_line("if $handle.closed:"); # issue 26 $Perlscan::PREV_HAD_COLON = 1; } } return $#ValClass; } # open_fun sub open_dir # # Process Perl opendir statement # assents thrww parameters # start -- Starting postion # limit -- End position # mode -- 's' or 'f' statement or invocation in expression, or 'c' for if not opendir { my ($start,$limit,$mode)=@_; my $end_pos=($ValPerl[$start+1] eq '(') ? matching_br($start+1)-1 : $limit; my($k,$myline, $target,$open_mode,$handle); # open (SYSFORM,'>',$output_file ) || abend(__LINE__,"Cannot open file $output_file for"); $k=($ValPerl[$start+1] eq '(') ? $start+2: $start+1; $handle=$ValPy[$k]; unless( $ValClass[$k] =~ /[is]/ ){ logme('W',"In opendir statement handle $ValPerl[$k] is not identifier or scalar variable. Translation might be incorrect"); } $Constants{$handle} = 1 if $ValClass[$k] eq 'i'; # issue 13 $k+=2 if( $ValPerl[$k+1] eq ','); if( $ValClass[$k] eq 's' ){ if($k == $end_pos) { # SNOOPYJC: Simple variable $target=$ValPy[$k]; } else { # expression $target = undef; } }elsif( $ValClass[$k] eq 'i' && $LocalSub{$ValPy[$k]}) { $target=escape_keywords($ValPy[$k]).'()'; # SNOOPYJC } $Pyf{'_opendir'} = 1; $handle = escape_keywords($handle); # issue s25 my $orig_mode = $mode; # SNOOPYJC: Handle complex handle if($mode ne 's' && $handle !~ /^[A-Za-z0-9_]+$/) { $mode = 's'; save_code(); } if( $mode eq 'f' ){ #logme('E',"In case of error open function in Python raises the FileNotFoundError exception. The code should be revised"); if(defined $target) { gen_chunk("($handle:=", '_opendir', "($target))"); } else { gen_chunk("($handle:=", '_opendir', '('); expression($k,$end_pos,0); # SNOOPYJC gen_chunk("))"); } return $k+1 if ($ValClass[$k+1] eq ')'); return $k; }elsif( $mode eq 's' ){ # SNOOPYJC $k+=2; # SNOOPYJC if($autodie) { if(1) { # SNOOPYJC: Our opendir does not normally raise exceptions if(defined $target) { gen_chunk("$handle = ", '_opendir', "($target)"); gen_statement(); } else { gen_chunk("$handle = ", '_opendir', '('); expression($k,$end_pos,0); # SNOOPYJC gen_chunk(')'); } } else { output_line('try:'); correct_nest(1,1); if(defined $target) { gen_chunk("$handle = ", '_opendir', "($target)"); gen_statement(); } else { gen_chunk("$handle = ", '_opendir', '('); expression($k,$end_pos,0); # SNOOPYJC gen_chunk(')'); gen_statement(); } correct_nest(-1,-1); output_line('except OSError as _e:'); correct_nest(1,1); output_line('pass'); correct_nest(-1,-1); } }elsif( $mode eq 'c' ){ # SNOOPYJC if($autodie) { if(1) { # SNOOPYJC: Our opendir does not normally raise exceptions if(defined $target) { gen_chunk("if not($handle:=", '_opendir', "($target)):"); gen_statement(); } else { gen_chunk("if not($handle:=", '_opendir', '('); expression($k,$end_pos,0); # SNOOPYJC gen_chunk(")):"); } } else { output_line('try:'); correct_nest(1,1); output_line("$handle = None"); if(defined $target) { gen_chunk("$handle = ", '_opendir', "($target)"); # Opendir statement generation from collected info -- $handle and $target gen_statement(); } else { gen_chunk("$handle = ", '_opendir', '('); expression($k,$end_pos,0); # SNOOPYJC gen_chunk(')'); gen_statement(); } correct_nest(-1,-1); output_line('except OSError as _e:'); correct_nest(1,1); output_line('pass'); correct_nest(-1,-1); output_line("if not $handle:"); $Perlscan::PREV_HAD_COLON = 1; } } #if ValPerl if($mode ne $orig_mode) { # SNOOPYJC: Handle complex handle like main_.dirh that can't appear in a := gen_statement(); restore_code(); if($orig_mode eq 'f') { gen_chunk($handle); } else { output_line("if not $handle:"); $Perlscan::PREV_HAD_COLON = 1; } } return $#ValClass; } # open_dir sub expression # # Anything in round brackets, including the list # Arg1 == (obligatory) starting point # Arg2 -- limit -- the last token to scan. # Arg3 -- mode of operation # -1 - Put '' in ValPy for external brackets # 0 - do not intefere with external brackets # 1 -preserve round brackets # 2 - insert splats where appropriate # SNOOPYJC # 3 - do 2 and 1 # issue s3 # 4 = expand hashes to a list # 8 = don't use 'get' for hash references # issue s299 # Arg 4 -- if given set recursion level to 0 { my $begin=$_[0]; unless(defined($begin) ){ logme('S',"Internal error in expression call -- starting position is not defined while processing $.: $line" ); return -255; } my ($bracketed,$cur_pos,$limit,$mode,$split,$start,$prev_k,$end_pos,$pos); if( $begin<0 || $TrStatus<0 ){ $TrStatus=-1; return -255; }elsif( $begin>$#ValClass ){ $cur_pos=$#ValClass; }else{ $cur_pos=$begin; } # issue times $start=$cur_pos; # starting point possibly from && or || -- we need that for regular expressions. $mode=(scalar(@_)>2) ? $_[2] : 0; # $mode allows brackets to be supressed but only on recursion level 0 # $mode 1 injects ( and ) if they are not present $limit=$#ValClass; $bracketed=0; if( scalar(@_)>1 ){ $limit=$_[1]; }elsif( $ValClass[$begin] eq '(' ){ $limit=matching_br($begin); if($limit < 0) { $TrStatus=-1; return -255; } # issue 70 }else{ # issue 70 $limit=$_[1]; } # issue 90 $bracketed=1 if $ValClass[$begin] eq '('; $bracketed=1 if $ValClass[$begin] eq '(' && matching_br($begin) == $limit; # issue 90 # issue s311 happens here! $RecursionLevel++; # we are starting from 0 if($RecursionLevel > $MAX_DEPTH) { # SNOOPYJC logme("S","INTERNAL ERROR: Exceeded MAX_DEPTH ($MAX_DEPTH) recursion in expression processing!"); $TrStatus=-1; return -255; } state $nest = 0; if($debug >= 3) { $nest++; #print STDERR '>' x $nest; #say STDERR "expression($begin, $limit, $mode) =|$TokenStr|= @ValPerl\n" debug_start_end(('>' x $nest) . "expression($begin, $limit, $mode) =|%|= @ValPerl", $begin, $limit); } my $dont_use_get = 0; # issue s299 if($mode == 2 || $mode == 3) { # SNOOPYJC: Do splats $mode -= 2; if($ValClass[$begin] eq '(' && $ValPerl[$begin] eq '(') { # NOTE: The case w/o parens is directly below this code (and looks almost the same)! my $match = matching_br($begin); for(my $i = $begin+1; $i < $match; $i++) { if(substr($ValPy[$i],0,1) eq '*') { # issue s316 ; # issue s316: Skip if already splatted } elsif($ValClass[$i] eq 'h' && substr($ValPy[$i],0,4) ne 'len(') { # issue s308 $ValPy[$i] = "*itertools.chain.from_iterable($ValPy[$i].items())"; # issue s308 } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '%s') { # issue s316 if(&Pythonizer::vartype($i, $CurSub) =~ /^[hs]/) { # issue s316 $ValPy[$i] = "*itertools.chain.from_iterable($ValPy[$i].items())"; # issue s316 } else { # issue s316 $ValPy[$i] = "*(itertools.chain.from_iterable($ValPy[$i].items()) if $ValPy[$i] is not None else [])"; # issue s316 } # issue s316 } elsif($ValClass[$i] eq 'i' && $LocalSub{$ValPy[$i]}) { # issue s308: FIXME - this isn't invoked on sub args! my $sra = sub_returns_array($i); if($sra == 1) { my $ls = $LocalSub{$ValPy[$i]}; $ValPy[$i] = '*' . $ValPy[$i]; $LocalSub{$ValPy[$i]} = $ls; } elsif($sra) { my $ep = end_of_call($i); if(index('+-*/%&|>o0:', $ValClass[$ep+1]) == -1) { $ValType[$i] = 'sl'; # FIXME: Handle this later!! } } } elsif(need_splat($i)) { if($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '@s' && &Pythonizer::vartype($i, $CurSub) !~ /^[as]/) { # issue s316 $ValPy[$i] = "*($ValPy[$i] if $ValPy[$i] is not None else [])"; # issue s316 } else { $ValPy[$i] = '*' . $ValPy[$i]; } } if($ValClass[$i] eq 'f') { # issue s262 $i = end_of_function($i); # issue s262 } else { # issue s262 $i = end_of_variable($i); } } # issue s206 } elsif(need_splat($begin)) { } else { # issue s206 for(my $i = $begin; $i <= $limit; $i++) { if(substr($ValPy[$i],0,1) eq '*') { # issue s316 ; # issue s316: Skip if already splatted } elsif($ValClass[$i] eq 'h' && substr($ValPy[$i],0,4) ne 'len(') { # issue s308 $ValPy[$i] = "*itertools.chain.from_iterable($ValPy[$i].items())"; # issue s308 } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '%s') { # issue s316 if(&Pythonizer::vartype($i, $CurSub) =~ /^[hs]/) { # issue s316 $ValPy[$i] = "*itertools.chain.from_iterable($ValPy[$i].items())"; # issue s316 } else { # issue s316 $ValPy[$i] = "*(itertools.chain.from_iterable($ValPy[$i].items()) if $ValPy[$i] is not None else [])"; # issue s316 } # issue s316 } elsif($ValClass[$i] eq 'i' && $LocalSub{$ValPy[$i]}) { # issue s308 my $sra = sub_returns_array($i); if($sra == 1) { my $ls = $LocalSub{$ValPy[$i]}; $ValPy[$i] = '*' . $ValPy[$i]; $LocalSub{$ValPy[$i]} = $ls; } elsif($sra) { my $ep = end_of_call($i); if($ep+1 > $#ValClass || index('+-*/%&|>o0:', $ValClass[$ep+1]) == -1) { $ValType[$i] = 'sl'; } } } elsif(need_splat($i)) { if($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '@s' && &Pythonizer::vartype($i, $CurSub) !~ /^[as]/) { # issue s316 $ValPy[$i] = "*($ValPy[$i] if $ValPy[$i] is not None else [])"; # issue s316 } else { $ValPy[$i] = '*' . $ValPy[$i]; } } if($ValClass[$i] eq 'f') { # issue s262 $i = end_of_function($i); # issue s262 } else { # issue s262 $i = end_of_variable($i); } } } } elsif($mode == 4) { # issue s191: Expand hashes to a list # list(itertools.chain.from_iterable('.$ValPy[$start].'.items())) if($ValClass[$begin] eq 'h') { gen_chunk('*list(itertools.chain.from_iterable('); $pos = expression($begin, $limit, 0); gen_chunk('.items()))'); return $pos; } $mode = 0; # issue s191 } elsif($mode == 8) { # issue s299: Don't use '.get' for hashes $dont_use_get = 1; # issue s299 for(my $i = $begin; $i <= $limit; $i++) { # issue s299: Undo any we already changed (from prior calls to expression(..., 0)) if($ValClass[$i] eq '(' && $ValPy[$i] eq '.get(' && ($ValPerl[$i] eq '{' || $ValPerl[$i] eq '[')) { my $l = matching_br($i); next if $l < 0; $ValPy[$i] = '['; $ValPy[$l] = ']'; $i = $l; } elsif($ValClass[$i] eq 's' && $ValPerl[$i] eq '$_' && $ValPy[$i] =~ /^$PERL_ARG_ARRAY\.get\(/) { # issue s359 $ValPy[$i] =~ s/\.get\(/[/; # issue s359 $ValPy[$i] =~ s/\)/]/; # issue s359 } } $mode = 0; # issue s299 } if($ValClass[$begin] eq '(' && $ValPerl[$begin] eq '(' && matching_br($begin) == $begin+1 && # issue s311 happens here! $begin+1 != $#ValClass && $ValClass[$begin+2] ne ':' && # issue test coverage: not a () if wantarray else ... ($begin == 0 || $ValClass[$begin-1] !~ /[fi]/)) { # SNOOPYJC: goatse, not sub/function empty args, and not at end # Goatse is just used to signal list context, e.g. "my $l = () = localtime();" calls localtime and gives 9, not ctime $begin = $cur_pos = $begin+2; if($ValClass[$begin] eq '=') { $begin = $cur_pos = $begin+1; } $bracketed=1 if $ValClass[$begin] eq '(' && matching_br($begin) == $limit; # issue 90 } # issue 53: Change hash references to use ".get(...)" instead of "[...]" # issue s359: Also change array references to use ".get(...)" instead of "[...]" if autovivification my $f; for(my $i = $begin; $i <= $limit; $i++) { # issue 53 if($ValClass[$i] eq '(' && $ValPy[$i] eq '[' && ($ValPerl[$i] eq '{' || ($i-1 >= 0 && ($ValClass[$i-1] eq 's' || $ValClass[$i-1] eq ')') && $autovivification)) && # issue s359: also handle '[' if autovivification # issue s303 $i-1 != 0 && $ValClass[$i-1] ne 'f' # issue s3: not "sort {...} @arr" or "map {...} @arr" or "bless {}, $pkg" !($i-1 != 0 && $ValClass[$i-1] eq 'f') # issue s3: not "sort {...} @arr" or "map {...} @arr" or "bless {}, $pkg", issue s303 ) { # issue 53 $l = matching_br($i); # issue 53 next if($l < 0); # issue 53 if($ValPerl[$i] eq '{' && # issue s359 $l-$i == 1) { # issue bootstrapping: "return {};" $ValPy[$i] = '{'; $ValPy[$l] = '}'; if($autovivification) { $Pyf{Hash} = 1; $ValPy[$i] = 'Hash'; $ValPy[$l] = '()'; } next; } next if(index($TokenStr, '=') > $l); # issue 53: skip if on lhs of assignment next if(next_same_level_token('=', $l+1, $#ValClass) != -1); # issue s303: the above check may find an '=' inside the parens, make sure there is none after them next if((($f=index($TokenStr,'f')) != -1) && ($ValPerl[$f] =~ /keys|values/ || ($ValPerl[$f] =~ /push|unshift/ && $l < next_same_level_token(',',$f,$#ValClass)))); # issue bootstrap next if($autovivification && $l != $#ValClass); # SNOOPYJC: '.get()' is no longer needed for autovivification, use on last one only next if($autovivification && !last_subscript($i, $l)); # issue bootstrap: '.get()' is no longer needed for autovivification, use on last one only next if($autovivification && in_x_element_call($i)); # issue ddts: _set_element(h.get('key'),...) is not what we want here! next if($autovivification && $ValClass[0] eq 'c' && $ValPy[0] eq 'for'); # SNOOPYJC: don't use if autoviv on for loop next if($autovivification && same_as_lhs($l)); # issue s3 next if($autovivification && in_keys_or_values($i)); # issue s102 next if(is_function_out_parameter($i)); # issue s359 next if(next_same_level_token('r', $i+1, $l-1) != -1); # issue s359 next if($dont_use_get); # issue s299 if($ValPerl[$i] eq '{' && # issue s359 $i == $begin && end_of_variable($i+1) == $l-1 && # issue s3: Handle { %hash } or { %$hashref } - copy a hash $ValClass[$i+1] ne 'a') { # issue s88: this case handled below replace($l, 'y', 'copy', '.copy()'); replace($i, 'y', '', ''); # nop next; } if($ValPerl[$i] eq '{' && # issue s359 $i != 0 && ($ValPerl[$i-1] eq '(' || $ValClass[$i-1] eq ',') || $ValClass[$i-1] eq '=') { # issue s88: skip anonymous hashes in argument lists if($begin == $i && $ValClass[$i+1] eq 'a' && $l == $i+2) { # issue s88: Handle single array in anonymous hash my $j = $i+1; if($autovivification) { $Pyf{Hash} = 1; gen_chunk('Hash', "({$ValPy[$j]"."[$INDEX_TEMP]:".$ValPy[$j]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$j]."),2)})"); } else { gen_chunk("{$ValPy[$j]"."[$INDEX_TEMP]:".$ValPy[$j]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$j]."),2)}"); } $cur_pos = $l+1; } next; } if(substr($TokenStr,$i,($l+1)-$i) !~ /[,A]/) { # issue 53: don't change list or hash constant, issue 93 $ValPy[$i] = '.get('; # issue 53 $ValPy[$l] = ')'; # issue 53 } $i = $l; } elsif($autovivification && $ValClass[$i] eq 's' && $ValPerl[$i] eq '$_' && $ValPy[$i] =~ /^$PERL_ARG_ARRAY\[/) { # issue s359 $l = $i; # issue s359 next if(index($TokenStr, '=') > $l); # issue s359: skip if on lhs of assignment next if(next_same_level_token('=', $l+1, $#ValClass) != -1); # issue s359: the above check may find an '=' inside the parens, make sure there is none after them next if(in_x_element_call($i+1)); # issue s359: _set_element(h.get('key'),...) is not what we want here! next if($ValClass[0] eq 'c' && $ValPy[0] eq 'for'); # issue s359: don't use if autoviv on for loop next if(same_as_lhs($l)); # issue s359 next if(is_function_out_parameter($i+1)); # issue s359 next if($dont_use_get); # issue s359 $ValPy[$i] =~ s/\[/.get(/; # issue s359 $ValPy[$i] =~ s/\]/)/; # issue s359 } } # # we need tocoorect end_pos in case there is a closing bracket to $limit-1 # $end_pos=$limit; if( $mode==1 && $bracketed==0 ){ gen_chunk('('); # generate opening bracket, as requested }elsif( $mode==-1 && $ValClass[$begin] eq '(' && $ValClass[$limit] eq ')' && matching_br($begin) == $limit) { # issue s243: Make sure the brackets match! # eliminate closing bracket $ValPy[$limit]=''; $end_pos=$limit-1; } elsif($mode == -1) { # issue s243: Eliminate ( ) is specified, but we don't have matching brackets $mode = 0; # issue s243: Turn it off! } if(substr($TokenStr,$begin) =~ m'^d\*d\*d' && # issue s311 happens here! $ValPy[$begin] == 9 && $ValPy[$begin+1] eq '**' && $ValPy[$begin+2] == 9 && $ValPy[$begin+3] eq '**' && $ValPy[$begin+4] == 9) { # issue s3 - check for 9**9**9 representing inf gen_chunk('math.inf'); # issue s3 return $limit; # issue s3 } my $p; if($ValClass[0] eq 'c' && $ValPy[0] eq 'when' && $ValPy[$begin] eq '[' && ($p = next_same_level_token('r', $begin+1, $limit-1)) > 0) { # issue s129: range in case/when stmt gen_chunk('range('); $k=expression($begin+1, $p-1, 0); if($k < 0) { $TrStatus=-1; return -255; } gen_chunk(','); $k=expression($p+1, $limit-1, 0); if($k < 0) { $TrStatus=-1; return -255; } gen_chunk('+1', ')'); return $limit+1; } $prev_k=-1; # starting position of infinite loop preventor. while($cur_pos<=$limit ){ if( $cur_pos < 0 || $TrStatus<0 ){ $TrStatus=-1; return -255; } unless( defined($ValClass[$cur_pos]) ){ say "Undefined ValClass at pos $cur_pos. Attempting to switch to debug mode "; #$DB::single = 1; } $end_pos= (($bracketed ==1) ? $limit-1 : $limit); # issue code coverage: if we limited our pos to &&/||/and/or, put it back! # # issue s151 $pos = next_same_level_tokens('!:o0~,', $cur_pos, $limit); # issue 101, issue 124 $pos = next_same_level_tokens('!:o0p,', $cur_pos, $limit); # issue 101, issue 124, issue s151 if($pos != -1) { # issue 101 # issue s151 if($ValClass[$pos] eq '~' && $ValPerl[$pos] ne '~') { # issue 101, SNOOPYJC: Handle ~ operator if($ValClass[$pos] eq 'p') { # issue 101, issue s151 $cur_pos=regex_and_translate($cur_pos,$cur_pos,$pos,$limit); # issue 101, issue 106 next; # issue 101 } # issue 101: do nothing if we hit the 0 (or/and) or comma first } # issue 101 if( $ValClass[$cur_pos] eq '(' ){ my $match = matching_br($cur_pos); # issue paren if($match+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'f' && $ValPerl[$cur_pos+1] eq 'ref' && $ValClass[$match+1] eq 'D') { # issue s3: call of a class method with (ref $self)-> gen_chunk('getattr(builtins', ','); $cur_pos=expression($cur_pos+1,$match-1,0); gen_chunk(')'); $cur_pos = $match+1; next; } if($match == $cur_pos+1 && ($ValPy[$cur_pos] eq '(' || $ValPerl[$cur_pos] eq '[') && !subref_call($cur_pos-1)) { # issue test coverage: handle empty array specified as (), issue s109, issue s129 if($autovivification) { $Pyf{Array} = 1; gen_chunk('Array', '(', ')'); } else { gen_chunk('[', ']'); } $cur_pos+=2; } elsif($match == $cur_pos+1 && $ValPerl[$cur_pos] eq '{' && $ValPy[$cur_pos] eq '[') { # issue s129: handle empty hash specified as {} if($autovivification) { $Pyf{Hash} = 1; gen_chunk('Hash', '(', ')'); } else { gen_chunk('{', '}'); } $cur_pos+=2; } elsif($cur_pos-1 >= 0 && $ValClass[$cur_pos-1] eq 'y' && $ValPerl[$cur_pos-1] eq 'multi' && ($p=next_same_level_token('r', $cur_pos+1, $match-1)) != -1) { # issue s148: Handle chomp/chop with range operator gen_chunk('range('); $k=expression($cur_pos+1, $p-1, 0); if($k < 0) { $TrStatus=-1; return -255; } gen_chunk(','); $k=expression($p+1, $match-1, 0); if($k < 0) { $TrStatus=-1; return -255; } gen_chunk('+1', ')'); $cur_pos = $match+1; } else { # issue s315: (expr) in list context should return a list, not just a parenthesized expression if($ValPy[$cur_pos] eq '(' && $mode != -1 && list_or_scalar_context($begin, $cur_pos) == 1 && !is_list($cur_pos, $match) && &Pythonizer::expr_type($cur_pos, $match, $CurSub) =~ /^[smuSIFB]$/ && ($cur_pos == 0 || (!&Pythonizer::is_scalar_operator($cur_pos-1) && $ValClass[$cur_pos-1] ne 'y' && $ValClass[$cur_pos-1] ne ',')) && ($match+1 > $#ValClass || (!in_outer_list($match+1) && # Not part of a larger list !&Pythonizer::is_scalar_operator($match+1) && $ValClass[$match+1] ne 'y' && $ValClass[$match+1] ne ',' && $ValClass[$match+1] ne 'A' && $ValClass[$match+1] ne ':')) # Not a hash key, not the conditional in a ? : ) { # issue s315 $ValPy[$cur_pos] = '['; # issue s315 $ValPy[$match] = ']'; # issue s315 } # issue s315 # generate bracket if mode=1 or recursion level is above zero if($autovivification && ($ValPerl[$cur_pos] ne '(' || is_list($cur_pos, $match)) && # issue s359 !on_lhs($cur_pos) && # issue s359 ($cur_pos == 0 || index('sahGD)if', $ValClass[$cur_pos-1]) == -1)) { # issue s354 if($ValPy[$cur_pos] eq '[' || $ValPy[$cur_pos] eq '(') { # issue s354, issue s359 $Pyf{Array} = 1; # issue s354 gen_chunk('Array', '('); # issue s354 $ValPy[$match] .= ')' if length($ValPy[$match]) == 1; # issue s354 } elsif($ValPy[$cur_pos] eq '{') { # issue s354 $Pyf{Hash} = 1; # issue s354 gen_chunk('Hash', '('); # issue s354 $ValPy[$match] .= ')' if length($ValPy[$match]) == 1; # issue s354 } # issue s354 } # issue s354 gen_chunk($ValPy[$cur_pos]) unless($cur_pos == $begin && $mode == -1); # SNOOPYJC # issue 15 $cur_pos=expression($cur_pos+1,$end_pos,0); # preserve brackets if($match < 0) { $TrStatus=-1; return -255; } # SNOOPYJC: Handle [k=>v, ...] and (k=>v, ...) - needs to generate a list, not a hash (note not {...} brackets) if($ValPy[$cur_pos] ne '{') { for(my $i=$cur_pos+1; $i<$match; $i++) { if($ValClass[$i] eq 'A') { # issue 93 $ValPy[$i] = ','; } elsif($ValClass[$i] eq '(') { # issue bootstrapping $i = matching_br($i); last if $i < 0; } } } if(($ValPerl[$cur_pos] eq '[' || ($ValPerl[$cur_pos] eq '(' && is_list($cur_pos, $match) && !in_outer_list($match+1) && ($match+1 > $#ValClass || $ValClass[$match+1] ne 'y'))) # issue s327: Do splats in lists too && ($cur_pos == 0 || $ValClass[$cur_pos-1] !~ /[sahG)]/)) { # issue s206 $cur_pos=expression($cur_pos+1,$match-1,2); # issue s206: Add splats in [...] brackets if needed } else { # issue s206 $cur_pos=expression($cur_pos+1,$match-1,0); # preserve brackets # issue 15, paren } ($cur_pos<0) && return -255; } }elsif( $ValClass[$cur_pos] eq '<' ){ gen_chunk('readline()'); $cur_pos++; }elsif( $ValClass[$cur_pos] eq ')' ){ $RecursionLevel--; gen_chunk($ValPy[$cur_pos]); # issue paren return $cur_pos+1; $cur_pos++; # issue paren }elsif( $ValClass[$cur_pos] =~ /[0o]/ ) { # issue 93 gen_chunk($ValPy[$cur_pos]); $start=$cur_pos=$cur_pos+1; # change starting point -- we need that for regular expressions. }elsif( $ValClass[$cur_pos] eq 'x' ){ # execution of Unix uility via shell # SNOOPYJC: handle AUTODIE, TRACEBACK gen_chunk(qq{subprocess.run($ValPy[$cur_pos],capture_output=True,text=True,shell=True).stdout}); my $func = '_run'; my $context = list_or_scalar_context($start, $cur_pos); # issue 118 if($context != 1) { $func = '_run_s'; } $Pyf{$func} = 1; # issue 118 if($autovivification && $func eq '_run') { # issue s359 $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '('); # issue s359 } # issue s359 gen_chunk($func, '(', $ValPy[$cur_pos], ')'); # SNOOPYJC: handle AUTODIE, TRACEBACK, issue 118 if($autovivification && $func eq '_run') { # issue s359 gen_chunk(')'); # issue s359 } $cur_pos++; }elsif( $ValClass[$cur_pos] =~ /[ahs]/ && $cur_pos+1 < $limit && $ValPy[$cur_pos+1] eq ':=' && $mode != 1 && !(($cur_pos==0 || $ValPy[$cur_pos-1] eq '(') && ($limit+1>$#ValPy || $ValPy[$limit+1] eq ')' ))) { # issue 93 $pos = $cur_pos+1; # issue 93: ":=" operators have to be in parens $pos = next_lower_or_equal_precedent_token('=', $pos+1, $limit); # issue 93 $pos = $limit+1 if($pos<0); # issue 93 $cur_pos=expression($cur_pos, $pos-1, 1); # issue 93: Add parens to the := operator # issue 42 $cur_pos++; }elsif( $ValClass[$cur_pos]=~ /[sf]/ ){ # match in Puthon is library re.match # As the argument to =~ can be complex. currently we can transtalte only two simple case: a scalar and an element of array/hash $pos=next_same_level_tokens('0o',$cur_pos,$limit); # limit of search for '~' below # issue 93 $end_pos=( $pos>-1 )? $pos : (($bracketed ==1) ? $limit-1 : $limit); # limit scan to next && or || #say STDERR "found s/f at $cur_pos, pos=$pos, end_pos=$end_pos, limit=$limit, bracketed=$bracketed"; if($cur_pos+1 <= $end_pos && $ValClass[$cur_pos+1] eq '=' && exists $SpecialVarR2L{$ValPy[$cur_pos]}) { $ValPy[$cur_pos] = $SpecialVarR2L{$ValPy[$cur_pos]}; # SNOOPYJC: Map _nr() to INPUT_LINE_NUMBER, etc } if( $end_pos-$cur_pos>=2 && $ValClass[$cur_pos] eq 's' && $ValClass[$cur_pos+1] eq '=' && $ValClass[$cur_pos+2] eq 'f' ){ # can be method like while( $line=shift ) if(inParens($cur_pos) && $ValPy[$cur_pos+1] eq '=') { # SNOOPYJC gen_chunk($ValPy[$cur_pos], ':='); } else { gen_chunk($ValPy[$cur_pos],$ValPy[$cur_pos+1]); } # issue s207 $cur_pos=function($cur_pos+2,$end_pos); $cur_pos=function($cur_pos+2, $limit); # issue s207 # issue 90 }elsif( $end_pos-$cur_pos>1 && ($split=index(substr($TokenStr,$cur_pos,$end_pos-$cur_pos+1),'~'))>-1 ){ # issue s151 }elsif( $end_pos-$cur_pos>1 && ($split=next_same_level_token('~',$cur_pos,$end_pos))>-1 && $split <= $end_pos && $ValPerl[$split] ne '~') { # issue 90, issue 99, SNOOPYJC: Handle ~ operator # issue s196 }elsif( $end_pos-$cur_pos>1 && ($split=next_same_level_token('p',$cur_pos,$end_pos))>-1 && $split <= $end_pos) { # issue 90, issue 99, issue s151 }elsif( $end_pos-$cur_pos>1 && ($split=next_lower_or_equal_precedent_token('p',$cur_pos,$end_pos))>-1 && $split <= $end_pos && $ValClass[$split] eq 'p') { # issue 90, issue 99, issue s151 # REGEX processing $line=~/abc/ # issue 90 $cur_pos=regex_and_translate($start,$cur_pos,$cur_pos+$split); # split is index from $cur_pos not abs index # issue 99 $cur_pos=regex_and_translate($start,$cur_pos,$split); # issue 90 $cur_pos=regex_and_translate($cur_pos,$cur_pos,$split,$limit); # issue 90, issue 99, issue 106 }elsif( $ValClass[$cur_pos] eq 'f'){ if($cur_pos != 0 && $ValClass[$cur_pos-1] eq '\\' && ($cur_pos+1 > $#ValClass || index('(dsah"fgijGqy!-', $ValClass[$cur_pos+1]) == -1) ) { # issue s276: ref function my $py = $ValPy[$cur_pos]; # issue s276 $Pyf{$py} = 1 if $py =~ /^_[A-Za-z]/; # issue s276 $py =~ s/^[.]//; # issue s276 $py =~ tr/()//s; # issue s276 gen_chunk($py); # issue s276 $cur_pos++; # issue s276 } else { # issue s207 $cur_pos=function($cur_pos,$end_pos); $cur_pos=function($cur_pos, $limit); # issue s207 ($cur_pos<0) && return -255; } }else{ gen_chunk($ValPy[$cur_pos]); $cur_pos++; } # issue uninit value }elsif( $cur_pos<$#ValClass && $ValClass[$cur_pos] eq 'i' && $ValClass[$cur_pos+1] eq '(' ){ }elsif( $cur_pos<$#ValClass && $ValClass[$cur_pos] eq 'i' && $ValClass[$cur_pos+1] eq '(' && $ValPerl[$cur_pos+1] eq '('){ # issue uninit, issue s199 $end_pos=matching_br($cur_pos+1); # find balanced bracket for the current bracket if($end_pos < 0) { $TrStatus=-1; return -255; } # issue s151 if($end_pos+1<=$limit && $ValClass[$end_pos+1] eq '~' && $ValPerl[$end_pos+1] ne '~') { # issue 99, SNOOPYJC: Handle '~' operator if($end_pos+1<=$limit && $ValClass[$end_pos+1] eq 'p') { # issue 99, issue s151 $cur_pos=regex_and_translate($cur_pos,$cur_pos,$end_pos+1,$limit); # issue 99, issue 106 } else { # issue 41 gen_chunk($ValPy[$cur_pos]); &Perlscan::add_package_name_sub($cur_pos); # SNOOPYJC gen_chunk(escape_keywords($ValPy[$cur_pos])); my $sub_pos = $cur_pos; # issue s3 if( $LocalSub{$ValPy[$cur_pos]} || ($cur_pos-1 >= 0 && $ValClass[$cur_pos-1] eq 'D')){ # issue s205: Handle method calls like localsub calls # Perl user defined function -- need to pass an array gen_chunk('('); # SNOOPYJC # issue parens expression($cur_pos+2,$end_pos-1,0); # call without brackets my $c = ''; # issue s199 if($ValPerl[$cur_pos+1] eq '{') { # issue ddts: Handle local_sub {hashref} # issue s199 $ValPy[$cur_pos+1] = '{'; # issue s199 $ValPy[$end_pos] = '}'; # issue s199 $TrStatus=expression($cur_pos+1, $end_pos, 0); # issue s199 $c = ', '; # issue s199 } else { { # issue s199 $cur_pos += 2; my $close = ''; # issue s199 while($cur_pos <= $end_pos-1) { $c = ', '; gen_chunk('*') if(need_splat($cur_pos)); # SNOOPYJC if($autovivification && $ValClass[$cur_pos] eq '(' && $ValPerl[$cur_pos] ne '(') { # issue s199: '{' or '[' my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$ValPerl[$cur_pos]}; # issue s199 $Pyf{$converter} = 1; # issue s199 gen_chunk($converter, '('); # issue s199 $close = ')'; # issue s199 } my $comma = next_same_level_token(',', $cur_pos, $end_pos-1); if($comma != -1) { if($ValClass[$cur_pos] eq 'f') { # issue test coverage: this comma could belong to the function $cur_pos = function($cur_pos); } else { expression($cur_pos, $comma-1, 4); # issue s191: Expand hashes to a list, issue s199: don't emit ',' here $cur_pos = $comma+1; if($close) { # issue s199 gen_chunk($close); # issue s199 $close = ''; # issue s199 } # issue s199 gen_chunk(','); # issue s199 } } else { expression($cur_pos,$end_pos-1,4) if($cur_pos <= $end_pos-1); # call without brackets # issue paren, issue s191 if($close) { # issue s199 gen_chunk($close); # issue s199 $close = ''; # issue s199 } # issue s199 last; } } } # issue s236 if(exists $SubAttributes{$ValPy[$sub_pos]}{wantarray} && list_or_scalar_context($sub_pos, $limit) == 1) { # issue s3 if(inherited_wantarray($sub_pos)) { # issue s241 gen_chunk("${c}wantarray=wantarray)"); # issue s241 # issue s241 } elsif((($sub_pos-1 >= 0 && $ValClass[$sub_pos-1] eq 'D' && exists $SubAttributes{'->' . $ValPy[$sub_pos]}{wantarray}) || # issue s241 exists $SubAttributes{$ValPy[$sub_pos]}{wantarray}) && list_or_scalar_context($sub_pos, $limit) == 1) { # issue s3, issue s236 } elsif(defined get_sub_attribute_at($sub_pos, 'wantarray') && list_or_scalar_context($sub_pos, $limit) == 1) { # issue s3, issue s236, issue s241 gen_chunk("${c}wantarray=True)"); # issue s241 } elsif((($sub_pos-1 >= 0 && $ValClass[$sub_pos-1] eq 'D' && exists $SubAttributes{'->' . $ValPy[$sub_pos]}{wantarray}) || # issue s241 exists $SubAttributes{$ValPy[$sub_pos]}{wantarray}) && void_context($sub_pos)) { # issue s241 } elsif(defined get_sub_attribute_at($sub_pos, 'wantarray') && void_context($sub_pos)) { # issue s241 gen_chunk("${c}wantarray=None)"); } else { gen_chunk(')'); # SNOOPYJC } $cur_pos=$end_pos+1; }elsif( $ValClass[$cur_pos+2] eq 'f' ){ #built-in function gen_chunk('('); # issue paren function($cur_pos+2,$end_pos-1); function($cur_pos+2,$end_pos-1) if($cur_pos+2 <= $end_pos-1); # issue paren if(inherited_wantarray($sub_pos)) { # issue s241 if($cur_pos+2 <= $end_pos-1) { gen_chunk(", wantarray=wantarray)"); } else { gen_chunk("wantarray=wantarray)"); } # issue s241 } elsif(exists $SubAttributes{$ValPy[$sub_pos]}{wantarray} && list_or_scalar_context($sub_pos, $limit) == 1) { # issue s3 } elsif(defined get_sub_attribute($ValPy[$sub_pos], 'wantarray') && list_or_scalar_context($sub_pos, $limit) == 1) { # issue s3 if($cur_pos+2 <= $end_pos-1) { gen_chunk(", wantarray=True)"); } else { gen_chunk("wantarray=True)"); } # issue s241 } elsif(exists $SubAttributes{$ValPy[$sub_pos]}{wantarray} && void_context($sub_pos)) { # issue s241 } elsif(defined get_sub_attribute($ValPy[$sub_pos], 'wantarray') && void_context($sub_pos)) { # issue s241 if($cur_pos+2 <= $end_pos-1) { gen_chunk(", wantarray=None)"); } else { gen_chunk("wantarray=None)"); } } else { gen_chunk(')'); } }else{ #function of unknown origin if($cur_pos == 0 || $ValClass[$cur_pos-1] ne 'D') { # SNOOPYJC: Suppress warning on object methods if(index($ValPy[$cur_pos], '.') < 0) { # Suppress message on package refs logme("W","Function $ValPy[$cur_pos] is neither internal nor built-in function. Please check the correspondence of arguments"); } } my $gen_close = 0; if($ValClass[$cur_pos+1] eq '(' && $ValPerl[$cur_pos+1] ne '(') { # issue ddts: "new Method {hashref};" gen_chunk('('); $gen_close = 1; } # issue s3 expression($cur_pos+1,$end_pos,1); # preseve brackets if($cur_pos+2 == $end_pos && $ValPerl[$cur_pos+1] eq '(' && $ValPerl[$end_pos] eq ')') { # issue code coverage: No args gen_chunk('()'); } else { expression($cur_pos+1,$end_pos,3); # issue s3: preseve brackets and insert splats } gen_chunk(')') if($gen_close); # issue ddts if(inherited_wantarray($cur_pos)) { # issue s241 if($Perlscan::PythonCode[-2] eq '(') { # no args substr($Perlscan::PythonCode[-1],-1,1) = 'wantarray=wantarray)'; # sneak it in the generated code } else { substr($Perlscan::PythonCode[-1],-1,1) = ', wantarray=wantarray)'; # sneak it in the generated code } # issue s241 } elsif(exists $SubAttributes{$ValPy[$cur_pos]}{wantarray} && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3 } elsif(defined get_sub_attribute($ValPy[$cur_pos], 'wantarray') && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3 if($Perlscan::PythonCode[-2] eq '(') { # no args substr($Perlscan::PythonCode[-1],-1,1) = 'wantarray=True)'; # sneak it in the generated code } else { substr($Perlscan::PythonCode[-1],-1,1) = ', wantarray=True)'; # sneak it in the generated code } # issue s241 } elsif(exists $SubAttributes{$ValPy[$cur_pos]}{wantarray} && void_context($cur_pos)) { # issue s241 } elsif(defined get_sub_attribute($ValPy[$cur_pos], 'wantarray') && void_context($cur_pos)) { # issue s241 if($Perlscan::PythonCode[-2] eq '(') { # no args substr($Perlscan::PythonCode[-1],-1,1) = 'wantarray=None)'; # sneak it in the generated code } else { substr($Perlscan::PythonCode[-1],-1,1) = ', wantarray=None)'; # sneak it in the generated code } } } $cur_pos=$end_pos+1; } # issue 99 # SNOOPYJC }elsif($ValClass[$cur_pos] eq 'i' && $ValPy[$cur_pos] eq $ValPerl[$cur_pos] && !inDotOp($cur_pos)) { # issue 13 }elsif($ValClass[$cur_pos] eq 'i' && !inDotOp($cur_pos)) { # issue 13, SNOOPYJC # issue s151 $pos=next_same_level_tokens('o0>~)',$cur_pos,$limit); # issue 13, issue 99 # issue s308 $pos=next_same_level_tokens('o0>p)',$cur_pos,$limit); # issue 13, issue 99, issue s151 my $eoc = end_of_call($cur_pos); # issue s308 $pos=next_same_level_tokens('o0>p),',$eoc+1,$limit); # issue 13, issue 99, issue s151, issue s308 $end_pos=( $pos>-1 )? $pos-1 : (($bracketed ==1) ? $limit-1 : $limit); # issue 13: limit scan to next && or ||, issue 99 if($cur_pos == 0 && ($#ValClass == 0 || index('f"sahd!~-+', $ValClass[$cur_pos+1]) != -1) && !exists $LocalSub{$ValPy[$cur_pos]}) { # issue s168 $LocalSub{$ValPy[$cur_pos]} = 4; # issue s168: we know this is a sub, just not where it came from if($implicit_global_my || !exists $LocalSub{'main'.'.'.$ValPy[$cur_pos]}) { # issue s186 logme('W', "Could not locate definition of sub $ValPy[$cur_pos]"); } # issue s186 } # issue s168 # issue s151 if($pos>-1 && $ValClass[$pos] eq '~' && $ValPerl[$pos] ne '~') { # issue 99, SNOOPYJC: Handle '~' operator if($pos>-1 && $ValClass[$pos] eq 'p') { # issue 99, issue s151 $cur_pos=regex_and_translate($cur_pos,$cur_pos,$pos,$limit)-1; # issue 99 (-1 is because we add 1 to it below), issue 106 } elsif( ($LocalSub{$ValPy[$cur_pos]} || $ValPerl[$cur_pos] =~ /::/ || (in_boolean_context($cur_pos) && !$Constants{$ValPy[$cur_pos]} && substr($ValPerl[$cur_pos],0,1) ne '-') || # issue s36 & handle issue 88 (-bareword) ($cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'i' && # issue s72 ($cur_pos+2 > $#ValClass || $ValClass[$cur_pos+2] ne 'D')) || ($cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] =~ /[ahsd"]/) # issue s3: bare followed by sub arg is a sub call ) && ($cur_pos+1 > $#ValClass || $ValPerl[$cur_pos+1] ne '=>')){ # issue 13: local sub call with no parens, SNOOPYJC: Handle module call with no parens if($cur_pos+1 <= $end_pos && $ValClass[$cur_pos+1] eq 'i' && ($cur_pos+2 > $end_pos || $ValClass[$cur_pos+2] ne 'A') && # issue s244: NOT struct Person => {...} !$LocalSub{$ValPy[$cur_pos+1]} && !$Constants{$ValPy[$cur_pos+1]}) { # SNOOPYJC: like new Package() gen_chunk(escape_keywords($ValPy[$cur_pos+1],1), '.'); gen_chunk(escape_keywords($ValPy[$cur_pos])); # issue 13, issue 41 $cur_pos++; if($cur_pos+1 <= $end_pos && $ValClass[$cur_pos+1] eq '(' && $ValPerl[$cur_pos+1] eq '(') { # SNOOPYJC: eat the parens $bracketed = 1; $limit = matching_br($cur_pos+1); if($limit < 0) { $TrStatus=-1; return -255; } $end_pos = $limit-1; $cur_pos++; } } else { &Perlscan::add_package_name_sub($cur_pos); # SNOOPYJC gen_chunk(escape_keywords($ValPy[$cur_pos])); # issue 13, issue 41 } my $skip_parens = 0; $skip_parens = 1 if($cur_pos != 0 && $ValClass[$cur_pos-1] eq '\\'); # SNOOPYJC: Ref to a sub gen_chunk('(') if(!$skip_parens); # issue 13, SNOOPYJC $k = 0; # issue 13 my $c = ''; # issue s3 my $start_pos = $cur_pos; # issue s199 if($cur_pos+1 <= $#ValClass && index("^*~p/%+-.HI>&|0or?:=,A", $ValClass[$cur_pos+1]) >= 0) { # SNOOPYJC: If op next, then no args!, issue s151, issue s199 $end_pos = $cur_pos; # issue s199 } # issue s199 if($cur_pos+1 <= $end_pos) { # issue s199 $c = ', '; # issue s3 # issue s199 gen_chunk('*') if(need_splat($cur_pos+1)); # SNOOPYJC # issue s199 # issue s151 if(index("^*~/%+-.HI>&|0or?:=,A", $ValClass[$cur_pos+1]) >= 0) { # SNOOPYJC: If op next, then no args! # issue s199 if(index("^*~p/%+-.HI>&|0or?:=,A", $ValClass[$cur_pos+1]) >= 0) { # SNOOPYJC: If op next, then no args!, issue s151 # issue s199 $end_pos = $cur_pos; # issue s199 } else { # issue s199 $k=expression($cur_pos+1, $end_pos, 4); # issue 13, issue s191: Expand hashes to a list # issue s199 if($k < 0) { $TrStatus=-1; return -255; } # issue 13 # issue s199 } # issue s199 } my $close = ''; # issue s199 $cur_pos++; # issue s199 while($cur_pos <= $end_pos) { # issue s199: New code - copied from the sub(...) case above $c = ', '; gen_chunk('*') if(need_splat($cur_pos)); # SNOOPYJC if($autovivification && $ValClass[$cur_pos] eq '(' && $ValPerl[$cur_pos] ne '(') { # issue s199: '{' or '[' my $converter = $AUTOVIVIFICATION_CONVERTER_MAP{$ValPerl[$cur_pos]}; # issue s199 $Pyf{$converter} = 1; # issue s199 gen_chunk($converter, '('); # issue s199 $close = ')'; # issue s199 } my $comma = next_same_level_token(',', $cur_pos, $end_pos); if($comma != -1) { if($ValClass[$cur_pos] eq 'f') { # issue test coverage: this comma could belong to the function $cur_pos = function($cur_pos); } else { expression($cur_pos, $comma-1, 4); # issue s191: Expand hashes to a list $cur_pos = $comma+1; if($close) { # issue s199 gen_chunk($close); # issue s199 $close = ''; # issue s199 } # issue s199 gen_chunk(','); # issue s199 } } else { expression($cur_pos,$end_pos,4) if($cur_pos <= $end_pos); # call without brackets # issue paren, issue s191 if($close) { # issue s199 gen_chunk($close); # issue s199 $close = ''; # issue s199 } # issue s199 last; } } # issue s199 if(!$skip_parens && exists $SubAttributes{$ValPy[$cur_pos]}{wantarray} && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3 if(!$skip_parens && inherited_wantarray($start_pos)) { # issue s241 gen_chunk("${c}wantarray=wantarray)"); # issue s241 # issue s241 } elsif(!$skip_parens && exists $SubAttributes{$ValPy[$start_pos]}{wantarray} && list_or_scalar_context($start_pos, $limit) == 1) { # issue s3 } elsif(!$skip_parens && defined get_sub_attribute($ValPy[$start_pos], 'wantarray') && list_or_scalar_context($start_pos, $limit) == 1) { # issue s3 gen_chunk("${c}wantarray=True)"); # issue s3 # issue s241 } elsif(!$skip_parens && exists $SubAttributes{$ValPy[$start_pos]}{wantarray} && void_context($start_pos)) { # issue s241 } elsif(!$skip_parens && defined get_sub_attribute($ValPy[$start_pos], 'wantarray') && void_context($start_pos)) { # issue s241 gen_chunk("${c}wantarray=None)"); # issue s241 } else { gen_chunk(')') if(!$skip_parens); # issue 13, SNOOPYJC } $cur_pos = $end_pos; # issue 13: we add one to it below $cur_pos++ if($bracketed == 1); # issue 13 } elsif ($Constants{$ValPy[$cur_pos]}) { # issue 13: constant or file handle gen_chunk($ValPy[$cur_pos]); # issue 13 } elsif($cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'i') { # SNOOPYJC: Like new XXXX my $last_i; for($last_i = $cur_pos+1; $last_i <= $#ValClass; $last_i++) { last if($ValClass[$last_i] ne 'i' && $ValClass[$last_i] ne 'D'); } $last_i--; #say STDERR "last_i = $last_i"; if($last_i <= $#ValClass && $ValClass[$last_i] eq 'i') { $ValPy[$last_i] .= ".$ValPy[$cur_pos]"; # SNOOPYJC: Change new XXXX to XXXX.new } else { gen_chunk($ValPy[$cur_pos]); } } elsif($cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'P') { # package:: - see test_feed_lib gen_chunk($ValPy[$cur_pos]); } else { # issue 13: bare word - treat as string gen_chunk("'".$ValPy[$cur_pos]."'"); # issue 13 } # issue 13 $cur_pos++; # issue 13 }elsif($ValClass[$cur_pos] eq 'i' && $cur_pos != 0 && $ValClass[$cur_pos-1] eq 'D' && # issue s244 ($cur_pos+1 > $#ValClass || ($ValClass[$cur_pos+1] ne '(' && $ValClass[$cur_pos+1] ne 'D'))) { # Method call with no () ($cur_pos+1 > $#ValClass || ($ValPerl[$cur_pos+1] ne '(' && $ValClass[$cur_pos+1] ne 'D'))) { # Method call with no (), issue s244: check ValPerl and not ValClass so '{' is not recognized as a paren # issue s236 if(exists $SubAttributes{$ValPy[$cur_pos]}{wantarray} && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3 if(inherited_wantarray($cur_pos)) { # issue s241 gen_chunk(escape_keywords($ValPy[$cur_pos]), '(wantarray=wantarray)'); # issue s241 # issue s241 } elsif(exists $SubAttributes{'->' . $ValPy[$cur_pos]}{wantarray} && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3, issue s236 } elsif(defined get_sub_attribute($ValPy[$cur_pos], 'wantarray', 1) && list_or_scalar_context($cur_pos, $limit) == 1) { # issue s3, issue s236, issue s241 gen_chunk(escape_keywords($ValPy[$cur_pos]), '(wantarray=True)'); # issue s241 } elsif(exists $SubAttributes{'->' . $ValPy[$cur_pos]}{wantarray} && void_context($cur_pos)) { # issue s241 } elsif(defined get_sub_attribute($ValPy[$cur_pos], 'wantarray', 1) && void_context($cur_pos)) { # issue s241 gen_chunk(escape_keywords($ValPy[$cur_pos]), '(wantarray=None)'); } else { gen_chunk(escape_keywords($ValPy[$cur_pos]), '()'); } $cur_pos++; }elsif($ValClass[$cur_pos] eq 'r') { # issue range # See if this looks like a slice, then we can implement it my @range_expanded = (); if(inSubscript($cur_pos)) { # issue range/slice gen_chunk(':1+'); # issue range/slice } elsif($cur_pos != 0 && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos-1] eq 'd' && int($ValPy[$cur_pos-1]) == $ValPy[$cur_pos-1] && $ValClass[$cur_pos+1] eq 'd' && int($ValPy[$cur_pos+1]) == $ValPy[$cur_pos+1] && ($ValPy[$cur_pos+1] - $ValPy[$cur_pos-1]) < 100) { # issue s174 gen_chunk(','); for(my $i = $ValPy[$cur_pos-1]+1; $i < $ValPy[$cur_pos+1]; $i++) { gen_chunk($i, ','); } } elsif($cur_pos != 0 && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos-1] eq '"' && length($ValPy[$cur_pos-1]) == 3 && $ValClass[$cur_pos+1] eq '"' && length($ValPy[$cur_pos+1]) == 3 && (ord(substr($ValPy[$cur_pos+1],1,1)) - ord(substr($ValPy[$cur_pos-1],1,1))) < 100) { # issue s174 gen_chunk(','); for(my $i = ord(substr($ValPy[$cur_pos-1],1,1))+1; $i < ord(substr($ValPy[$cur_pos+1],1,1)); $i++) { gen_chunk("'".chr($i)."'", ','); } } elsif(@range_expanded = expand_range($cur_pos)) { # issue s206 gen_chunk(','); # issue s206 gen_chunk(join(',', @range_expanded)); # issue s206 gen_chunk(','); # issue s206 } else { logme('S',"'..' range operator not implemented outside of for loop or slice"); # issue range gen_chunk($ValPy[$cur_pos]); # issue range } $cur_pos++; # issue range }elsif($ValClass[$cur_pos] eq '&' && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 's' && # SNOOPYJC: scalar that contains a subref ($cur_pos == 0 || index('difs)',$ValClass[$cur_pos-1])<0)) { # SNOOPYJC: but not a logical '&' if($cur_pos+2 > $#ValClass || $ValClass[$cur_pos+2] ne '(') { # no args gen_chunk($ValPy[$cur_pos+1], '(', ')'); $cur_pos++; } else { # has args ; # Just ignore the '&' } $cur_pos++; }elsif($ValClass[$cur_pos] eq '+' && ($cur_pos == 0 || $ValClass[$cur_pos-1] eq '(' || ($ValClass[$cur_pos-1] eq 'f' && ($ValPy[$cur_pos-1] eq 'print' || $ValPy[$cur_pos-1] eq 'wprint' || $ValPy[$cur_pos-1] eq 'printf')))) { # issue unary +, issue printf, issue s101 $cur_pos++; # skip it }elsif($ValClass[$cur_pos] eq 'k' && $ValPerl[$cur_pos] eq 'sub') { # issue 81: sub in expression gen_chunk('lambda *', $PERL_ARG_ARRAY, ':'); # issue 81 my $walrus = 0; for(my $i = $cur_pos+1; $i <= $limit; $i++) { if($ValClass[$i] eq 'f' && $ValPerl[$i] eq 'die') { $Pyf{'_die'} = 1; $ValPy[$i] = '_die'; # Can't use "raise" in a lambda } elsif($ValClass[$i] eq '=') { $ValPy[$i] = ':='; $walrus = 1; #} elsif($ValClass[$i] eq 'i' && $ValPy[$i] eq 'traceback.print_stack' && #$ValClass[$i+1] eq '(' && $ValClass[$i+2] eq 's') { #$ValPy[$i+2] = 'f'; # Not main.f } } my $s = $cur_pos+1; my $end_pos = matching_br($s); if($end_pos < 0) { $TrStatus=-1; return -255; } my $e = $end_pos-1; $e-- if($ValClass[$e] eq ';'); gen_chunk('(') if($walrus); if($s+1 <= $e) { $k = expression($s+1, $e, 0); if($k < 0) { $TrStatus=-1; return -255; } } else { # e.g. sub {} gen_chunk('None'); } gen_chunk(')') if($walrus); $cur_pos = $end_pos+1; }elsif($ValClass[$cur_pos] eq 'k' && $cur_pos != 0) { # SNOOPYJC if($ValPerl[$cur_pos] eq 'next' || $ValPerl[$cur_pos] eq 'last') { # If we have a next or last in an expression, during the first pass # we already marked this loop as to need an exception, so we just # need to raise the exception now - we use _raise(...) to do that # since we can't emit a raise statement here. $Pyf{_raise} = 1; if($cur_pos+1 <= $end_pos && $ValClass[$cur_pos+1] eq 'i') { # We have a label my $ex_name = label_exception_name($ValPerl[$cur_pos+1]); gen_chunk('_raise', "($ex_name('$ValPy[$cur_pos]'))"); $cur_pos += 2; } else { # issue bootstrap my $ex_name = label_exception_name(undef); my $ex_name = label_exception_name(&Perlscan::cur_loop_label()); # issue bootstrap gen_chunk('_raise', "($ex_name('$ValPy[$cur_pos]'))"); $cur_pos++; } } elsif($ValPerl[$cur_pos] eq 'return') { # Return in an expression $Pyf{_raise} = 1; if(scalar(@eval_stack) != 0 && !in_sub_in_eval_at($#eval_stack)) { # In an 'eval', issue s243 if($cur_pos != $end_pos) { # Not a plain "return" my $lno = $eval_stack[-1]->{lno}; my $suffix = $eval_stack[-1]->{suffix}; # issue s13 gen_chunk('_raise', "($EVAL_RETURN_EXCEPTION($EVAL_RESULT$lno$suffix:="); # issue s13 my $add_paren = convert_return_expression($cur_pos+1, $end_pos); # issue s9, issue s3 $TrStatus = expression($cur_pos+1, $end_pos, -1); gen_chunk($add_paren) if($add_paren); # issue s9 gen_chunk('))'); $cur_pos = $end_pos+1; } else { gen_chunk('_raise', "($EVAL_RETURN_EXCEPTION)"); $cur_pos++; } } elsif(&Perlscan::in_BEGIN() && !&Perlscan::in_sub()) { # issue s30 my $ex_name = label_exception_name(&Perlscan::begin_loop_label()); gen_chunk('_raise', "($ex_name('break'))"); $cur_pos = $end_pos+1; } else { # In a sub my $cs = &Perlscan::cur_sub(); # issue s241 if($cur_pos != $end_pos) { gen_chunk('_raise', "($FUNCTION_RETURN_EXCEPTION("); my $add_paren = convert_return_expression($cur_pos+1, $end_pos); # issue s9, issue s3 $TrStatus = expression($cur_pos+1, $end_pos, -1); gen_chunk($add_paren) if($add_paren); # issue s9 gen_chunk('))'); $cur_pos = $end_pos+1; } elsif(defined get_sub_attribute($cs, 'wantarray')) { # issue s241 gen_chunk('_raise', "($FUNCTION_RETURN_EXCEPTION("); # issue s241 $cur_pos++; # issue s241 if($autovivification) { # issue s241 $Pyf{Array} = 1; # issue s241 gen_chunk('Array', '()', 'if', 'wantarray', 'else', 'None'); # issue s241 } else { # issue s241 gen_chunk('[]', 'if', 'wantarray', 'else', 'None'); # issue s241 } # issue s241 gen_chunk('))'); # issue s241 } else { gen_chunk('_raise', "($FUNCTION_RETURN_EXCEPTION(None))"); $cur_pos++; } } } elsif($ValPerl[$cur_pos] eq 'use' || $ValPerl[$cur_pos] eq 'require' || $ValPerl[$cur_pos] eq 'no') { # SNOOPYJC $cur_pos = do_use_require($cur_pos); } else { $TrStatus = -255; $cur_pos++; } }elsif($ValClass[$cur_pos] eq '=' && $ValPy[$cur_pos] eq '=' && inParens($cur_pos)) { # issue assign in expr gen_chunk(':='); $cur_pos++; }elsif($ValClass[$cur_pos] eq ',' && $cur_pos == $#ValClass) { # issue trailing ',' - ignore it! $cur_pos++; }elsif($ValClass[$cur_pos] eq 'q' && substr($ValPy[$cur_pos],0,9) eq 're.search' && $ValPy[$cur_pos] =~ /re\.G/) { # issue ddts $ValPy[$cur_pos] =~ s/,re\.G\|/,/; $ValPy[$cur_pos] =~ s/.re\.G//; gen_chunk($ValPy[$cur_pos]); $cur_pos++; }elsif($ValClass[$cur_pos] eq "\\" && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 's') { # issue s169 logme("W", "Reference to scalar $ValPerl[$cur_pos+1] replaced with scalar value"); #$TrStatus=-1; $cur_pos++; }elsif($ValClass[$cur_pos] eq '"' && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'D') { # issue s3: call of a class method gen_chunk('getattr(builtins', ',', $ValPy[$cur_pos], ')'); $cur_pos++; }elsif($ValClass[$cur_pos] eq 'i' && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos+1] eq 'D') { # issue s18: call of a class method gen_chunk(escape_keywords($ValPy[$cur_pos], 1)); # issue s18 $cur_pos++; # issue s18 }elsif($ValClass[$cur_pos] eq 'C' && $ValPerl[$cur_pos] eq 'do' && $cur_pos+1 <= $#ValClass) { # issue s231 $cur_pos = do_use_require($cur_pos); # issue s231 } elsif($ValClass[$cur_pos] eq '/' && $uses_integer) { # use integer gen_chunk('//'); # use integer: Integer division $cur_pos++; # use integer } elsif($autovivification && $ValClass[$cur_pos] eq 'q' && substr($ValPy[$cur_pos],0,1) ne '*' && $ValPy[$cur_pos] =~ /\.split\(\)$/) { # issue s359: qw/.../ needs to be changed into an Array $Pyf{Array} = 1; # issue s359 gen_chunk('Array', '(', $ValPy[$cur_pos], ')'); # issue s359 $cur_pos++; # issue s359 }else{ gen_chunk($ValPy[$cur_pos]); if(defined $ValCom[$cur_pos] && length($ValCom[$cur_pos]) > 1 && $cur_pos != $#ValClass && ok_to_break_line()) { # issue s228: special case inline comments gen_chunk(' ' . $ValCom[$cur_pos] . "\n"); # issue s228 $ValCom[$cur_pos] = undef; # issue s228 } # issue s228 $cur_pos++; } if( $cur_pos eq $prev_k ){ logme("S","Internal error -- no progress in scanning expression from position $cur_pos"); $TrStatus=-1; return -255; } $prev_k=$cur_pos } # issue 90 if( $mode==1 && $ValClass[$begin] ne '(' ){ if( $mode==1 && $bracketed == 0){ # issue 90 #we generated opening bracket, so let's geneerate closing gen_chunk(')'); } $RecursionLevel--; if($cur_pos > $limit) { # issue paren $cur_pos = $limit; # issue paren } # issue paren if($debug >= 3) { print STDERR '<' x $nest; $nest--; say STDERR 'expression returns ' . ($cur_pos+1); } return $cur_pos+1; } #expression sub inDotOp # issue 13 - check to see if this bare word is involved in a "->" operation { my $pos = shift; if($pos != 0) { return 1 if($ValClass[$pos-1] eq 'D'); } if($pos != $#ValClass) { return 1 if($ValClass[$pos+1] eq 'D'); } return 0; } sub inSubscript # is this '::' operator in an array subscript? { my $pos = shift; my $close_p = next_same_level_token(')', $pos+1, $#ValClass); return 0 if($close_p < 0); return 0 if($ValPy[$close_p] ne ']'); my $open_p = reverse_matching_br($close_p); return 0 if($open_p < 0); if($open_p < $pos) { # issue s206 return 1 if($open_p == 0); return 1 if($ValClass[$open_p-1] =~ /[ahsG)]/); # issue s206: Don't return 1 for an arrayref like [..., ...] } return 0; } sub inParens # is this '=' operator in a parenthesized expression? { my $pos = shift; my $close_p = next_same_level_token(')', $pos+1, $#ValClass); return 0 if($close_p < 0); my $open_p = reverse_matching_br($close_p); return 0 if($open_p < 0); return 1 if($open_p < $pos); return 0; } sub handle_double_or_and_assignment # issue s3: handle ||= and &&= { my $start = shift; my $op_pos = shift; my $limit = shift; my $adjust = 0; $start = start_of_var($op_pos-1); # issue s218: Handle return $Q ||= ... -or- ($Q ||= ...) my $op = $ValPerl[$op_pos] eq '||=' ? '||' : '&&'; my $pyop = $op eq '||' ? 'or' : 'and'; if($debug >= 3) { print STDERR "handle_double_or_and_assignment($start, $op_pos, $limit) with $ValPerl[$op_pos]"; } insert($op_pos+1, '0', $op, $pyop); $adjust++; for(my $i = $op_pos-1; $i >= $start; $i--) { insert($op_pos+1, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); $adjust++; } replace($op_pos, '=', '=', '='); if($debug >= 3) { say STDERR " = $adjust, now =|$TokenStr|="; } return $adjust; } sub handle_incr_decr # issue 74: handle ++ and -- in expressions { my $start = shift; my $op_pos = shift; my $limit = shift; my $force = shift; # issue s184: force it to make a transformation if true # determine if this is a ++$t or a $t++ my $op = $ValPerl[$op_pos] eq '++' ? '+' : '-'; my $rop = $ValPerl[$op_pos] eq '++' ? '-' : '+'; my $pre_op = 0; my $lvalue_start; my $lvalue_end; if($debug >= 3) { print STDERR "handle_incr_decr($start, $op_pos, $limit) with $ValPerl[$op_pos]"; } return 0 if($ValPerl[$op_pos] eq '^'); # Get out quick if this is an exclusive or # issue s334 if($op_pos == 0 && !has_comma_operator($start, $limit)) { if($op_pos == 0 && !has_comma_operator($start, $limit) && end_of_variable($start) == $limit) { # issue s334 print "\n" if($debug >= 3); return 0 unless($force); # we handle this case natively } elsif($ValClass[$op_pos-1] eq ';') { # Like for(...;++i) { } print "\n" if($debug >= 3); return 0 unless($force); # we handle this case natively } # issue s362 if($op_pos+1 <= $#ValClass && $ValClass[$op_pos+1] eq 's') { if($op_pos+1 <= $#ValClass && ($ValClass[$op_pos+1] eq 's' || $ValClass[$op_pos+1] eq 'f')) { # issue s362 $pre_op = 1; $lvalue_end = $lvalue_start = $op_pos+1; while($lvalue_end+1 <= $#ValClass && $ValClass[$lvalue_end+1] eq '(') { # array sub or hash key $lvalue_end = matching_br($lvalue_end+1); } } elsif($op_pos == 0) { replace($op_pos, $op, $op, $op); if($debug >= 3) { say STDERR "- can't figure it out!"; } return 0; # Not sure what this is so ignore it } else { # post op $lvalue_start = $lvalue_end = $op_pos-1; while($ValClass[$lvalue_start] eq ')') { # Handle $num{$key}{$hour}++; $lvalue_start = reverse_matching_br($lvalue_start) - 1; } if((($lvalue_start == 0 && $lvalue_end == 0) || $ValClass[$lvalue_end-1] eq ';') && # ';' is before 'for' loop incr $op_pos == $limit) { print "\n" if($debug >= 3); return 0 unless($force); # we handle this case natively } } if($debug >= 3) { print STDERR ", pre_op=$pre_op, lvalue_start=$lvalue_start, lvalue_end=$lvalue_end"; } $inc = 0; if($lvalue_start != 0 && $ValClass[$lvalue_start-1] eq 'i' && $ValClass[$lvalue_start] ne '(' && $LocalSub{$ValPy[$lvalue_start-1]}) { # We have a sub call w/o parens here - since we may insert parens after the function reference, # we have to surround the entire set of args with parens to make sure we process it right # issue s151 $pos=next_same_level_tokens('o0~',$lvalue_start,$limit); $pos=next_same_level_tokens('o0p',$lvalue_start,$limit); # issue s151 $end_pos=( $pos>-1 )? $pos-1 : $limit; insert($end_pos+1, ')', ')', ')'); insert($lvalue_start, '(', '(', '('); $inc = 2; $limit += 2; $op_pos++; $lvalue_start++; $lvalue_end++; } if($lvalue_start == $lvalue_end) { # simple scalar - handle using the walrus operator if($ValPy[$lvalue_start] =~ /^\(len\((.*)\)-1\)$/) { # issue 14 - increment or decrement array length $arrName = $1; # issue 14 save_code(); if($op eq '+') { # issue 14: add one element to array gen_chunk("$arrName.append(None)"); # issue 14 } else { # issue 14 gen_chunk("del $arrName".'[len('.$arrName.')-1:]'); # issue 14 } gen_statement(); restore_code(); destroy($op_pos, 1); # remove the ++ or -- if(!$pre_op) { # post - need to adjust the value $ValPy[$lvalue_start] =~ s/-1\)$/-2\)/; } if($debug >= 3) { say STDERR " = ".(-1+$inc)." now =|$TokenStr|="; } return -1+$inc; } if(($pre_op && $lvalue_end+1 <= $#ValClass && $ValClass[$lvalue_end+1] eq ';') || (!$pre_op && $op_pos+1 <= $#ValClass && $ValClass[$op_pos+1] eq ';')) { # issue s146 # issue s146: Handle incr/decr as first part of for loop destroy($op_pos, 1); # remove the ++ or -- $lvalue_start-- if($pre_op); insert($lvalue_start+1, 'd', '1', '1'); insert($lvalue_start+1, $op, $op, $op); insert($lvalue_start+1, 's', $ValPerl[$lvalue_start], $ValPy[$lvalue_start]); insert($lvalue_start+1, '=', '=', ':='); if($debug >= 3) { say STDERR " = ".(3+$inc)." now =|$TokenStr|="; } return 3+$inc; # how many we inserted } if($pre_op) { # generate ($val:=$val+1) replacing ++$val destroy($op_pos, 1); # remove the ++ or -- $lvalue_start--; insert($lvalue_start+1, ')', ')', ')'); insert($lvalue_start+1, 'd', '1', '1'); insert($lvalue_start+1, $op, $op, $op); insert($lvalue_start+1, 's', $ValPerl[$lvalue_start], $ValPy[$lvalue_start]); insert($lvalue_start+1, '=', '=', ':='); insert($lvalue_start, '(', '(', '('); if($debug >= 3) { say STDERR " = ".(5+$inc)." now =|$TokenStr|="; } return 5+$inc; # how many we inserted } else { # post op: generate (($val:=$val+1)-1) replacing $val++ destroy($op_pos, 1); # remove the ++ or -- insert($lvalue_start+1, ')', ')', ')'); insert($lvalue_start+1, 'd', '1', '1'); insert($lvalue_start+1, $rop, $rop, $rop); insert($lvalue_start+1, ')', ')', ')'); insert($lvalue_start+1, 'd', '1', '1'); insert($lvalue_start+1, $op, $op, $op); insert($lvalue_start+1, 's', $ValPerl[$lvalue_start], $ValPy[$lvalue_start]); insert($lvalue_start+1, '=', '=', ':='); insert($lvalue_start, '(', '(', '('); insert($lvalue_start, '(', '(', '('); if($debug >= 3) { say STDERR " = ".(9+$inc)." now =|$TokenStr|="; } return 9+$inc; # how many we inserted } } else { # array index or hashref - split it out # for pre: # $arr[$ndx] += 1 # (... $arr[$ndx] ...) # for post: # $arr[$ndx] += 1 # (... ($arr[$ndx]-1) ...) # # If we're replacing the entire statement, then just remove all the code since we are generating it # if($pre_op && $op_pos == 0 && $lvalue_end == $#ValClass) { # entire line destroy($op_pos, 1); # remove the ++ or -- append('=', '+=', '+='); append('d', '1', '1'); if($debug >= 3) { say STDERR " = ".(2+$inc)." now =|$TokenStr|="; } return 2+$inc; } elsif(!$pre_op && $lvalue_start == 0 && $op_pos == $#ValClass) { # entire line if($ValClass[$lvalue_start] eq 'f' && ($ValPerl[$lvalue_start] eq $CONVERTER_MAP{N} || $ValPerl[$lvalue_start] eq $CONVERTER_MAP{I})) { # issue s362 # isue s362: This happens on for loops that we change to while loops: Change f(s)^ to s=f(s)+1 replace($op_pos, $op, $op, $op); # issue s362 append('d', '1', '1'); # issue s362 insert(0, '=', '=', '='); # issue s362 $lvalue_start++; # issue s362 $lvalue_end++; # issue s362 my $adj = 2; # issue s362 for(my $i = $lvalue_end-1; $i > $lvalue_start+1; $i--) { # issue s362: Copy the expr insert(0, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); # issue s362 $adj++; # issue s362 } # issue s362 if($debug >= 3) { # issue s362 say STDERR " = ".($adj+$inc)." now =|$TokenStr|="; # issue s362 } # issue s362 return $adj+$inc; # issue s362 } else { replace($op_pos, '=', "$op=", "$op="); append('d', '1', '1'); if($debug >= 3) { say STDERR " = ".(1+$inc)." now =|$TokenStr|="; } return 1+$inc; } } # We use a library function (_add_element) to handle the assignment, which will be inserted later. # Here we just need to make the following substitutions: # ++$arr[$ndx] ($arr[$ndx]+=1) # --$arr[$ndx] ($arr[$ndx]-=1) # $arr[$ndx]++ (($arr[$ndx]+=1)-1) # $arr[$ndx]-- (($arr[$ndx]-=1)+1) # ^$lvalue_start # ^$lvalue_end # ^$op_pos if($pre_op) { insert($lvalue_end+1,')',')',')'); insert($op_pos,'(','(','('); $op_pos++; $lvalue_start++; $lvalue_end++; insert($lvalue_end+1,'d','1','1'); insert($lvalue_end+1,'=',"$op=", "$op="); destroy($op_pos,1); $lvalue_start--; $lvalue_end--; my $adj = fix_type_issues($lvalue_start, $lvalue_end, undef); return $inc+3+$adj; } else { insert($op_pos+1,')',')',')'); insert($op_pos+1,'d','1','1'); my $nop = ($op eq '+') ? '-' : '+'; insert($op_pos+1,$nop,$nop,$nop); insert($op_pos+1,')',')',')'); insert($op_pos+1,'d','1','1'); insert($op_pos+1,'=',"$op=", "$op="); insert($lvalue_start,'(','(','('); insert($lvalue_start,'(','(','('); $op_pos += 2; $lvalue_start += 2; $lvalue_end += 2; destroy($op_pos,1); my $adj = fix_type_issues($lvalue_start, $lvalue_end, undef); return $inc+7+$adj; } # This is a BAD idea as the statement we pull out may be running in the wrong context now. See test.pm for # an example. # save_code(); # if($pre_op) { # insert($lvalue_end+1, '=', "$op= 1", "$op= 1"); # Not actually used but it tells expression() that we're on the LHS # } else { # replace($op_pos, '=', "$op= 1", "$op= 1"); # Not actually used but it tells expression() that we're on the LHS # } # my $adj = fix_type_issues($lvalue_start, $lvalue_end, undef); # $lvalue_end += $adj; # $k = expression($lvalue_start, $lvalue_end, 0); # if($pre_op) { # destroy($lvalue_end+1, 1); # remove the extra '=' we put in # } else { # $op_pos += $adj; # } # if(&Pythonizer::expr_type($lvalue_start, $lvalue_end, $CurSub) =~ /[NIF]/) { # gen_chunk(" $op= 1"); # += 1 or -= 1 # } else { # gen_chunk('='); # $Pyf{_num} = 1; # gen_chunk('_num', '('); # expression($lvalue_start, $lvalue_end, 0); # gen_chunk(')', $op, '1'); # } # gen_statement(); # restore_code(); # if($debug >= 3) { # print STDERR " =|$TokenStr|=, op_pos=$op_pos, "; # } # destroy($op_pos, 1); # remove the ++ or -- # if($pre_op) { # if($debug >= 3) { # say STDERR " = ". (-1+$inc+$adj)." (arr/hash)"." now =|$TokenStr|="; # } # return -1+$inc+$adj; # } else { # post op # insert($lvalue_end+1, ')', ')', ')'); # insert($lvalue_end+1, 'd', '1', '1'); # insert($lvalue_end+1, $rop, $rop, $rop); # insert($lvalue_start, '(', '(', '('); # if($debug >= 3) { # say STDERR " = ".(3+$inc+$adj)." now =|$TokenStr|="; # } # return 3+$inc+$adj; # } } } sub handle_cmp_spaceship # SNOOPYJC: Handle cmp and <=> operators { my $start = shift; my $op_pos = shift; my $limit = shift; # Replace a cmp b with _cmp(a,b) # Replace a <=> b with _spaceship(a,b) # We determine where to stop by looking at the operator precidence chart here: https://perldoc.perl.org/perlop my ($a_start, $a_end, $b_start, $b_end); $a_end = $op_pos-1; for($a_start=$a_end; $a_start >= $start; $a_start--) { if($ValClass[$a_start] eq ')') { $a_start = reverse_matching_br($a_start); } elsif(index('k&|^o0r:A?=,n(', $ValClass[$a_start]) >= 0) { last; } } $a_start++; $b_start = $op_pos+1; for($b_end=$b_start; $b_end <= $limit; $b_end++) { if($ValClass[$b_end] eq '(') { $b_end = matching_br($b_end); } elsif(index('&|^o0r:A?=,n)', $ValClass[$b_end]) >= 0) { last; } } $b_end--; insert($b_end+1, ')', ')', ')'); my $pl = $ValPerl[$op_pos]; my $py = $ValPy[$op_pos]; replace($op_pos, ',', ',', ','); insert($a_start, '(', '(', '('); insert($a_start, 'f', $pl, $py); $Pyf{$py} = 1; # Causes it to load the function from our library into the generated code if($debug >= 3) { say STDERR "handle_cmp_spaceship($start, $op_pos, $limit): a[$a_start:$a_end], b[$b_start:$b_end] = 3 (=|$TokenStr|=)"; } return 3; # How many things we added } sub handle_xor # issue s237: Implement xor { my $start = shift; my $op_pos = shift; my $limit = shift; # Replace a xor b with _logical_xor(a,b) # We determine where to stop by looking at the operator precidence chart here: https://perldoc.perl.org/perlop # In this case, there is nothing lower in precidence than or/xor my ($a_start, $a_end, $b_start, $b_end); $a_end = $op_pos-1; for($a_start=$a_end; $a_start >= $start; $a_start--) { if($ValClass[$a_start] eq ')') { $a_start = reverse_matching_br($a_start); } elsif(index('ko(', $ValClass[$a_start]) >= 0) { next if($ValPerl[$a_start] eq 'and'); # and is higher prec than xor last; } } $a_start++; $b_start = $op_pos+1; for($b_end=$b_start; $b_end <= $limit; $b_end++) { if($ValClass[$b_end] eq '(') { $b_end = matching_br($b_end); } elsif(index('o)', $ValClass[$b_end]) >= 0) { next if($ValPerl[$b_end] eq 'and'); # and is higher prec than xor last; } } $b_end--; insert($b_end+1, ')', ')', ')'); my $pl = $ValPerl[$op_pos]; my $py = $ValPy[$op_pos]; my $adjust = 3; if($ValClass[$a_start] =~ /[if]/ && $ValClass[$a_start+1] ne '(' && $a_start+1 != $op_pos) { # Unparenthesized sub or function call # We have to add parens to it, else we don't know where the argument list ends insert($op_pos, ')', ')', ')'); insert($a_start+1, '(', '(', '('); $adjust += 2; $op_pos += 2; } replace($op_pos, ',', ',', ','); insert($a_start, '(', '(', '('); insert($a_start, 'f', $pl, $py); $Pyf{$py} = 1; # Causes it to load the function from our library into the generated code if($debug >= 3) { say STDERR "handle_xor($start, $op_pos, $limit): a[$a_start:$a_end], b[$b_start:$b_end] = $adjust (=|$TokenStr|=)"; } return $adjust; # How many things we added } sub handle_smartmatch # issue s251: Implement ~~ { my $start = shift; my $op_pos = shift; my $limit = shift; # Replace a ~~ b with _smartmatch(a,b) # We determine where to stop by looking at the operator precidence chart here: https://perldoc.perl.org/perlop my ($a_start, $a_end, $b_start, $b_end); $a_end = $op_pos-1; for($a_start=$a_end; $a_start >= $start; $a_start--) { if($ValClass[$a_start] eq ')') { $a_start = reverse_matching_br($a_start); } elsif(index('k&|^o0r:A?=,n(', $ValClass[$a_start]) >= 0) { last; } } $a_start++; $a_start = start_of_function($a_start); # issue s262 if($ValClass[$a_end] eq 'q') { $ValPy[$a_end] =~ s/^re.search\((re.compile.*),_str\(_d\)\)/$1/; $ValPy[$a_end] =~ s/^re.search\((.*),_str\(_d\)\)/re.compile($1)/; } $b_start = $op_pos+1; for($b_end=$b_start; $b_end <= $limit; $b_end++) { if($ValClass[$b_end] eq '(') { $b_end = matching_br($b_end); } elsif(index('&|^o0r:A?=,n)', $ValClass[$b_end]) >= 0) { last; } } $b_end--; insert($b_end+1, ')', ')', ')'); my $pl = $ValPerl[$op_pos]; my $py = $ValPy[$op_pos]; my $adjust = 3; # issue s262 if($ValClass[$a_start] =~ /[if]/ && $ValClass[$a_start+1] ne '(' && $a_start+1 != $op_pos) { # Unparenthesized sub or function call if(($ValClass[$a_start] =~ /[if]/ && $ValPerl[$a_start+1] ne '(' && $a_start+1 != $op_pos) || ($ValClass[$a_start] eq "\\" && $ValClass[$a_start+1] =~ /[if]/ && $ValPerl[$a_start+2] ne '(' && $a_start+2 != $op_pos) ) { # Unparenthesized sub or function call, issue s262: handle map {...} @arr -or- \map {...} @arr # We have to add parens to it, else we don't know where the argument list ends insert($op_pos, ')', ')', ')'); insert($a_start+1, '(', '(', '('); $adjust += 2; $op_pos += 2; } replace($op_pos, ',', ',', ','); insert($a_start, '(', '(', '('); insert($a_start, 'f', $pl, $py); $Pyf{$py} = 1; # Causes it to load the function from our library into the generated code if($debug >= 3) { say STDERR "handle_smartmatch($start, $op_pos, $limit): a[$a_start:$a_end], b[$b_start:$b_end] = $adjust (=|$TokenStr|=)"; } return $adjust; # How many things we added } sub handle_isa # issue s287: Implement isa { my $start = shift; my $op_pos = shift; my $limit = shift; # Replace a isa b with _isa_op(a,b) # We determine where to stop by looking at the operator precedence chart here: https://perldoc.perl.org/perlop my ($a_start, $a_end, $b_start, $b_end); $a_end = $op_pos-1; for($a_start=$a_end; $a_start >= $start; $a_start--) { if($ValClass[$a_start] eq ')') { $a_start = reverse_matching_br($a_start); } elsif(index('ko,A=?:r0|&M>(', $ValClass[$a_start]) >= 0) { last; } } $a_start++; $b_start = $op_pos+1; for($b_end=$b_start; $b_end <= $limit; $b_end++) { if($ValClass[$b_end] eq '(') { $b_end = matching_br($b_end); } elsif(index('o,A=?:r0|&M>)', $ValClass[$b_end]) >= 0) { last; } } $b_end--; insert($b_end+1, ')', ')', ')'); my $pl = $ValPerl[$op_pos]; my $py = $ValPy[$op_pos]; my $adjust = 3; if($ValClass[$a_start] =~ /[if]/ && $ValClass[$a_start+1] ne '(' && $a_start+1 != $op_pos) { # Unparenthesized sub or function call # We have to add parens to it, else we don't know where the argument list ends insert($op_pos, ')', ')', ')'); insert($a_start+1, '(', '(', '('); $adjust += 2; $op_pos += 2; } replace($op_pos, ',', ',', ','); insert($a_start, '(', '(', '('); insert($a_start, 'f', $pl, $py); $Pyf{$py} = 1; # Causes it to load the function from our library into the generated code if($debug >= 3) { say STDERR "handle_isa($start, $op_pos, $limit): a[$a_start:$a_end], b[$b_start:$b_end] = $adjust (=|$TokenStr|=)"; } return $adjust; # How many things we added } sub handle_range # issue s307: Handle more range operators { my $start = shift; my $op_pos = shift; my $limit = shift; # Replace a .. b with _range_op(a,b) # We determine where to stop by looking at the operator precedence chart here: https://perldoc.perl.org/perlop my ($a_start, $a_end, $b_start, $b_end); return 0 if inSubscript($op_pos); $a_end = $op_pos-1; for($a_start=$a_end; $a_start >= $start; $a_start--) { if($ValClass[$a_start] eq ')') { $a_start = reverse_matching_br($a_start); } elsif(index('ko,A=?:(f', $ValClass[$a_start]) >= 0) { last; } } $a_start++; return 0 if list_or_scalar_context($a_start, $op_pos) != 1; return 0 if $ValClass[$a_start] eq '"'; # String $b_start = $op_pos+1; return 0 if $ValClass[$b_start] eq '"'; # String for($b_end=$b_start; $b_end <= $limit; $b_end++) { if($ValClass[$b_end] eq '(') { $b_end = matching_br($b_end); } elsif(index('o,A=?:)', $ValClass[$b_end]) >= 0) { last; } } $b_end--; insert($b_end+1, ')', ')', ')'); my $pl = $ValPerl[$op_pos]; my $py = '_range_op'; # replaced with 'range' iterator in python my $adjust = 3; if($ValClass[$a_start] =~ /[if]/ && $ValClass[$a_start+1] ne '(' && $a_start+1 != $op_pos) { # Unparenthesized sub or function call # We have to add parens to it, else we don't know where the argument list ends insert($op_pos, ')', ')', ')'); insert($a_start+1, '(', '(', '('); $adjust += 2; $op_pos += 2; } replace($op_pos, ',', ',', ','); insert($a_start, '(', '(', '('); insert($a_start, 'f', $pl, $py); # This is not a real function - we replace the code with the range iterator from python #$Pyf{$py} = 1; # Causes it to load the function from our library into the generated code if($debug >= 3) { say STDERR "handle_range($start, $op_pos, $limit): a[$a_start:$a_end], b[$b_start:$b_end] = $adjust (=|$TokenStr|=)"; } return $adjust; # How many things we added } sub handle_reset_each_on_keys_or_values # issue s305 { my($start, $pos, $limit) = @_; my $st = $pos+1; my $en = $pos+1; if($ValPerl[$st] eq '(') { $en = matching_br($st); $st++; } insert($en+1,'y','','[0]'); insert($en+1, ')', ')', ')'); insert($en+1, ')', ')', ')'); insert($en+1, $ValClass[$st], $ValPerl[$st], $ValPy[$st]); insert($en+1, '(', '(', '('); $Pyf{_reset_each} = 1; insert($en+1, 'f', '_reset_each', '_reset_each'); insert($en+1, ',', ',', ','); insert($pos, '(', '(', '('); return 8; } sub handle_question_mark_colon # issue 52 handle ? : in expressions { my $start = shift; my $q_pos = shift; my $limit = shift; # cond ? tval : fval # issue s204 my $c_pos = next_same_level_token(':', $q_pos+1, $limit); my $c_pos = next_same_level_tokens('?:', $q_pos+1, $limit); return -1 if($c_pos < 0); # issue s204: If we find another '?' operator, then his ':' is NOT our ':' while($ValClass[$c_pos] eq '?') { # issue s204 $c_pos = next_same_level_tokens('?:', $c_pos+1, $limit); return -1 if($c_pos < 0); if($ValClass[$c_pos] eq ':') { $c_pos = next_same_level_token(':', $c_pos+1, $limit); return -1 if($c_pos < 0); last; } } my $fval_start = $c_pos+1; #my $fval_end = next_same_level_tokens(',:!)', $fval_start+1, $limit)-1; my $tval_start = $q_pos+1; my $tval_end = $c_pos-1; my $cond_start = $start; my $cond_end = $q_pos-1; my $adjust = 0; if(next_lower_or_equal_precedent_token('?', $tval_start, $tval_end) != -1) { # issue s204 insert($tval_end+1, ')', ')', ')'); insert($tval_start, '(', '(', '('); $tval_end += 2; $fval_start += 2; $c_pos += 2; $limit += 2; $adjust = 2; say "handle_question_mark_colon: after inserting (tval): =|$TokenStr|= ValPy = @ValPy" if($debug >= 3); } if($ValClass[$cond_end] eq ')' && $ValPerl[$cond_end] eq ')') { # issue s194: We have it in real parens, just point to the open paren # issue s194: What we have here is map {...}(condition)?true:false, and we were backing up over the {...} $cond_start = reverse_matching_br($cond_end); # issue s194 if($cond_start != 0 && $ValClass[$cond_start-1] =~ /[fi]/) { # issue s194: function or sub call $cond_start--; # issue s194 if($cond_start != 0 && $ValClass[$cond_start-1] eq 'D') { # issue s197 $cond_start = start_of_var($cond_start-2); # issue s197 } # issue s197 $cond_start-- if($cond_start != 0 && $ValClass[$cond_start-1] =~ /[fi]/); # issue s197: defined $self->http('accept') } # issue s194 } else { # issue s194 $cond_start = $cond_end; # issue s358 } # issue s358 for($cond_start = $cond_end; $cond_start >= $start; $cond_start--) { for( ; $cond_start >= $start; $cond_start--) { # issue s358 if($ValClass[$cond_start] eq ')') { $cond_start = reverse_matching_br($cond_start); } elsif(index("(=,:kc", $ValClass[$cond_start]) >= 0) { last; } } $cond_start++ if $cond_start < $start || $cond_start != reverse_matching_br($cond_end); # issue s358 if($debug >= 3) { say STDERR "handle_question_mark_colon($start, $q_pos, $limit) cond=[$cond_start:$cond_end], fval=[$fval_start:], tval=[$tval_start:$tval_end]"; debug_start_end("cond =|%|=", $cond_start, $cond_end); debug_start_end("fval =|%|=", $fval_start); debug_start_end("tval =|%|=", $tval_start, $tval_end); } # we need to generate this code: # # tval if cond else fval replace($c_pos, ':', ':', 'else'); for(my $i = $cond_end; $i >= $cond_start; $i--) { insert($c_pos, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); } # now we have: cond ? tval cond else fval my $p; if(($p = next_same_level_tokens('if', $tval_start, $tval_end)) != -1 && $ValPerl[$p+1] ne '(' && $tval_end != $tval_start) { # issue s256 # If we have an unparenthesized function or sub call in tval, we can get confused about where it stops # in end_of_function, so surround it with parens insert($tval_end+1, ')', ')', ')'); # issue s256 insert($tval_start, '(', '(', '('); # issue s256 $adjust += 2; # issue s256 $tval_end += 2; # issue s256 } insert($tval_end+1, ':', '?', 'if'); # Needs to be an op with the same precedence, but not '?' # now we have: cond ? tval if cond else fval destroy($cond_start, $cond_end-$cond_start+2); # now we have: tval if cond else fval if($debug >= 3) { say STDERR "after handle_question_mark_colon: =|$TokenStr|=, ValPy = @ValPy"; } return $adjust; # we usually have the same number of tokens as before, issue s204 } sub handle_negative_bareword # issue 88 { # given a -bareword, remove the - and put it in the bareword # arg = position of the '-' my $pos = shift; $ValPerl[$pos+1] = '-'.$ValPerl[$pos+1]; $ValPy[$pos+1] = '-'.$ValPy[$pos+1]; destroy($pos, 1); return -1; } sub start_of_function # issue s262 # Given an operand that may be part of a function call, return the start of the function, else just return the operand { my $pos = shift; for(my $i = 0; $i < $pos; $i++) { if($ValClass[$i] eq 'f') { my $eof = end_of_function($i); if($eof >= $pos) { if($i != 0 && $ValClass[$i-1] eq '\\') { # If they are taking a ref to the result, include that too $i--; } return $i; } } } return $pos; } sub start_of_var # Get the start of this lvalue { my $end_pos = shift; if($ValClass[$end_pos] eq 'P') { # issue s236: feed_lib:: - this is the '::' $end_pos--; } if($ValClass[$end_pos] eq ')' && $ValPerl[$end_pos] eq ')') { # issue s236 $end_pos = reverse_matching_br($end_pos); return 0 if($end_pos < 0); $end_pos-- if $end_pos > 0 && $ValClass[$end_pos-1] =~ /[if]/; } while($ValClass[$end_pos] eq ')' && ($ValPerl[$end_pos] eq ']' || $ValPerl[$end_pos] eq '}')) { $end_pos = reverse_matching_br($end_pos) - 1; return 0 if($end_pos < 0); } if($ValClass[$end_pos] eq 'D') { # $s->[...] return start_of_var($end_pos-1); # issue s236: handle $hashref->{arr}->[0] } while($ValClass[$end_pos] eq 'i' && ($end_pos-2 >= 0 && $ValClass[$end_pos-1] eq 'D')) { $end_pos -= 2; } return $end_pos; } sub start_of_expr # issue s96 # Get the start of this expression { my $end_pos = shift; while($ValClass[$end_pos] eq ')') { $end_pos = reverse_matching_br($end_pos) - 1; return 0 if($end_pos <= 0); } if($end_pos < $#ValClass && $ValClass[$end_pos+1] eq '(' && ($ValClass[$end_pos] eq 'f' || $ValClass[$end_pos] eq 'i' || $ValClass[$end_pos] eq 's')) { return $end_pos; } if($ValClass[$end_pos] eq 'D') { # $s->[...] return $end_pos-1; } while($ValClass[$end_pos] eq 'i' && ($end_pos-2 >= 0 && $ValClass[$end_pos-1] eq 'D')) { $end_pos -= 2; } if($end_pos < $#ValClass && $ValClass[$end_pos+1] eq '(') { return $end_pos+1; } return $end_pos; } sub fixup_read_in_expression # SNOOPYJC # Remove 0 offsets from read operations and add the length calculation { my $pos = shift; # read FH,scalar,length,offset # read FH,scalar,length # issue s184 - do this check later return 0 if($pos == 0); # Nothing to do if this is a read statement my $begin = $pos; my $limit = $#ValClass; return 0 if(substr($ValPerl[$begin],0,1) eq '.'); # We were already here my $readf = "_read"; $readf = "_sysread" if($ValPerl[$begin] eq 'sysread'); $pos++; # Point to FH my $bracketed = 0; if($pos <= $#ValClass && $ValClass[$pos] eq '(') { # Skip any '(' $limit = matching_br($pos) -1; return 0 if($limit < 0); $pos++; $bracketed = 1; } my $fh0 = $pos; my $comma = next_same_level_token(',', $pos, $limit); return 0 if($comma < 0); my $fh1 = $comma-1; my $sc0 = $comma+1; $comma = next_same_level_token(',', $sc0, $limit); return 0 if($comma < 0); my $sc1 = $comma-1; # issue s184: If this is a read statement that sets a sub out parameter, then continue processing, # else we get out quick here. if($begin == 0) { # issue s184 return 0 if($CurSub eq '__main__'); # issue s184 return 0 if $sc0 != $sc1; # issue s184 return 0 if $ValClass[$sc0] ne '$_' && $ValType[$sc0] ne 'ss'; # issue s184, issue s185 } # issue s184 my $ln0 = $comma+1; $comma = next_same_level_token(',', $ln0, $limit); my $ln1 = $comma-1; my ($of0, $of1); if($comma < 0) { if(!$bracketed) { my $lower = next_lower_or_equal_precedent_token('F', $comma+1, $limit); $limit = $lower-1 if($lower != -1); } $ln1 = $limit; $of0 = undef; } else { $of0 = $comma+1; $of1 = $limit; } my $adjust = 0; if(defined $of0 && $ValClass[$of0] eq 'd' && $ValPy[$of0] eq '0') { destroy($of0-1, 2); $adjust = -2; $limit -= 2; $of0 = undef; } # # Change read(fh,scalar,length) -to- ((scalar:=(_s:=_read(fh,length,need_len=True))[0]),_s[1])[1] # Change read(fh,scalar,length,offset) -to- ((scalar:=(_s:=_read(fh,length,scalar,offset,need_len=True))[0]),_s[1])[1] # ^begin ^sc0 ^ln0 ^of0 ^limit # ^fh0 ^sc1 ^ln1 ^of1 my $read = $begin; if(!$bracketed) { insert($limit+1,')',')',')'); insert($sc0,'(','(','('); $limit += 2; $adjust += 2; $fh0++; $fh1++; $sc0++; $sc1++; $ln0++; $ln1++; if(defined $of0) { $of0++; $of1++; } } $Pyf{$readf} = 1; replace($read,'f',$readf,$readf); my $j = 2; insert($limit+$j++,')',')',')'); insert($limit+$j++,'y','','[0]'); insert($limit+$j++,')',')',')'); insert($limit+$j++,',',',',','); insert($limit+$j++,'y','',"$SUBSCRIPT_TEMP".'[1]'); insert($limit+$j++,')',')',')'); insert($limit+$j,'y','','[1]'); $adjust += $j-2; insert($limit+1,'y','','need_len=True'); insert($limit+1,',',',',','); $adjust += 2; $limit += 2; say STDERR "Read: after inserting end stuff =|$TokenStr|= ValPy=@ValPy, read=$read, limit=$limit, adjust=$adjust" if($debug >= 3); insert($read,'=','=',':='); insert($read,'s','$'.$SUBSCRIPT_TEMP,$SUBSCRIPT_TEMP); insert($read,'(','(','('); insert($read,'=','=',':='); my $here = $read; $read += 4; $fh0 += 4; $fh1 += 4; $sc0 += 4; $sc1 += 4; $ln0 += 4; $ln1 += 4; $adjust += 4; if(defined $of0) { $of0 += 4; $of1 += 4; } $j = 0; for(my $i = $sc0; $i <= $sc1; $i++) { insert($here+$j++, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); $i++; $ValType[$here+$j-1] = $ValType[$i]; # issue s185 $sc1++; } insert($here,'(','(','('); insert($here,'(','(','('); $read += $j+2; $fh0 += $j+2; $fh1 += $j+2; $sc0 += $j+2; $sc1 += 2; $ln0 += $j+2; $ln1 += $j+2; $adjust += $j+2; if(defined $of0) { $of0 += $j+2; $of1 += $j+2; } say STDERR "Read: completed =|$TokenStr|= ValPy=@ValPy, adjust=$adjust" if($debug >= 3); return $adjust; } sub split_up_multiple_assignment # issue 115 # issue 115: Split up multiple assignment of the form %h1 = %h2 = (); # or complex cases like ($k, $v) = %h1 = %h2 = @a1 = @a2 = ('key', 'value'); # We don't do anything on cases we already handle like $v1 = $v2 = value; @a1 = @a2 = value; *G1 = *G1 = value; # Return packaged code for what to generate next. { my $test_only = $_[0] if(scalar(@_) > 0); # Don't do any conversion, just test if we will return undef if($ValClass[0] eq 't'); # Only handles global vars, no 'my', etc. my $eq1 = next_same_level_tokens('=o0,', 0, $#ValClass); return undef if($eq1 < 0 || $ValClass[$eq1] ne '='); my $eq2 = next_same_level_tokens('=o0,', $eq1+1, $#ValClass); return undef if($eq2 < 0 || $ValClass[$eq2] ne '='); # Find the last '=' and remember the one before that my $prev_eq = $eq1; my $last_eq = $eq2; my $eqn; while(1) { $eqn = next_same_level_tokens('=o0,', $last_eq+1, $#ValClass); last if($eqn < 0 || $ValClass[$eqn] ne '='); $prev_eq = $last_eq; $last_eq = $eqn; } return undef if($eqn >= 0 && $ValClass[$eqn] ne '='); # See if it's something we handle elsewhere, namely ValClass all 's', all 'a' or all 'G' or goatse my $type = undef; my $yup = 1; for(my $i = 0; $i < $last_eq; $i+=2) { if($ValClass[$i] =~ /[asG]/ && $ValClass[$i+1] eq '=') { if(!defined $type) { $type = $ValClass[$i]; } elsif($type ne $ValClass[$i]) { $yup = 0; last; } } elsif($ValClass[$i] eq '(' && $ValClass[$i+1] eq ')' && $ValClass[$i+2] eq '=') { # goatse $i++; } else { $yup = 0; last; } } if($yup || $TokenStr =~ /=\(\)=/) { say STDERR "split_up_multiple_assignment($TokenStr) = undef, last_eq=$last_eq" if($debug); return undef; } return 1 if($test_only); # Ok we have a case like ($k, $v) = %h1 = %h2 = @a1 = @a2 = ('key', 'value'); # or probably something simpler. Using this as an example we would generate: # @a2 = ('key', 'value'); # and return packaged code of: # ($k, $v) = %h1 = %h2 = @a1 = @a2 $result = package_tokens(); destroy(0, $prev_eq+1); # Leaves us with "@a2 = ('key', 'value')" in our example p_destroy($result, $last_eq, (scalar(@{$result->{class}})-$last_eq)); # ($k, $v) = %h1 = %h2 = @a1 = @a2 my $PkgTokenStr = join('', @{$result->{class}}); say STDERR "split_up_multiple_assignment gives =|$TokenStr|= and packages =|$PkgTokenStr|= for next time" if($debug); return $result; } sub add_parens # Helper for handle_assignment_in_expression { my ($start, $pos, $end_pos, $adjust) = @_; if($start == 0 || $ValClass[$start-1] ne '(' || $ValPerl[$start-1] ne '(' || $ValClass[$end_pos+1] ne ')' || $ValPerl[$end_pos+1] ne ')') { # All := operations must be in '(' ')' my $ep = $end_pos; # issue s299 if(has_comma_operator($start, $end_pos)) { # issue s299 $ep = is_list($start, $end_pos) - 1; # issue s299: Points us just before the ',' $ep = $end_pos unless $ep > 0; # issue s299 } # issue s299 insert($start, '(', '(', '('); $pos++; $end_pos++; $ep++; # issue s299 $start++; # issue s299 insert($end_pos+1, ')', ')', ')'); insert($ep+1, ')', ')', ')'); # issue s299 $adjust += 2; } return ($start, $pos, $end_pos, $adjust); } sub has_comma_operator # Does this expression have a comma operator at the current level? { my $start = shift; my $end = shift; my $pos = next_same_level_tokens('if,',$start,$end); return 0 if($pos < 0); while($ValClass[$pos] ne ',' && $pos+1 <= $#ValClass && $ValPerl[$pos+1] eq '(') { # Skip any function/sub calls with parens $pos = matching_br($pos+1); return 0 if($pos < 0); $pos = next_same_level_tokens('if,',$pos+1,$end); return 0 if($pos < 0); } return 0 if($ValClass[$pos] eq 'i' && ($pos+1 > $end || $ValClass[$pos+1] ne '(')); # sub call with no parens - all are args if($ValClass[$pos] eq 'f' && $pos+1 <= $#ValClass && $ValPerl[$pos+1] ne '(') { # issue s3: Handle non-paren function call # issue s299 $pos++; # issue s299 while(defined arg_type_from_pos($pos)) { # issue s299 $pos = next_same_level_token(',', $pos, $end); # issue s299 return 0 if $pos < 0; # issue s299 $pos++; # issue s299 } $pos = end_of_function($pos) + 1; # issue s299 $pos = next_same_level_tokens('if,',$pos,$end); # issue s299 } return ($pos > 0 && $ValClass[$pos] eq ','); } sub handle_assignment_in_expression { # Fixup any assignment operation that's not in a place we can handle # arg = position of the '=' or '=~' (p) my $pos = shift; my $m; return 0 if($pos == 1 && $ValClass[0] =~ /[ashG]/ && !has_comma_operator(2,$#ValClass)); # $a = expr return 0 if($pos == 2 && $ValClass[0] eq 't' && $ValClass[1] =~ /[ashG]/ && !has_comma_operator(3,$#ValClass)); # my $a = expr; return 0 if($pos >= 3 && $ValClass[$pos-1] eq ')' && reverse_matching_br($pos-1) == 0); # (...) = expr; return 0 if($pos >= 4 && $ValClass[$pos-1] eq ')' && reverse_matching_br($pos-1) == 1 && $ValClass[0] eq 't'); # my (.,.) = expr; return 0 if($ValClass[0] eq 's' && next_same_level_token('=', 0, $#ValClass) == $pos && !has_comma_operator($pos+1,$#ValClass)); # $a{...}[...] = expr; return 0 if($ValClass[0] eq 's' && next_same_level_tokens('p', 0, $#ValClass) == $pos && # issue s299 next_matching_tokens('=i^', 0, $pos-1) == -1 && # issue s299: Can't have a potential side-effect (($m = next_matching_token('f', 0, $pos-1)) == -1 || $ValPerl[$m] ne '_assign_global') && # issue s328 !has_comma_operator($pos+1,$#ValClass)); # $a{...}[...] = expr; return 0 if($ValClass[0] eq 'a' && next_same_level_tokens('=p', 0, $#ValClass) == $pos) && # issue s299 next_same_level_token(',', 0, $#ValClass) < 0; # @h{list} = list, issue s144: Don't return on a=(...),... return 0 if($ValClass[0] eq 'c' && ($ValPerl[0] eq 'for' || $ValPerl[0] eq 'foreach') && index($TokenStr, ';') > 0); # for(...;...;...) return 0 if($ValClass[0] eq 'f' && ($ValPerl[0] eq 'chomp' || $ValPerl[0] eq 'chop') && next_same_level_token($ValClass[$pos], 2, $#ValClass) == $pos); # chomp($x = ...); # issue s328: Add check to handle assignment later in complex expression return 0 if($ValClass[0] eq '(' && $ValClass[-1] eq ')' && next_same_level_token('=', 1, $#ValClass-1) == $pos && matching_br(0) == $#ValClass && # issue s328 !has_comma_operator($pos+1, $#ValClass-1)); # ($a = 1) if... # issue s151 return 0 if($ValClass[$pos] eq '~' && $ValPerl[$pos] eq '~'); # Complement, not a regex # issue s151 return 0 if($ValClass[$pos] eq '~' && ($pos+1 > $#ValClass || $ValClass[$pos+1] ne 'f' || ($ValPerl[$pos+1] ne 're' && $ValPerl[$pos+1] ne 'tr'))); return 0 if($ValClass[$pos] eq '~'); # Complement, issue s151 #$DB::single = 1 unless defined($ValClass[$pos]); # TEMP return 0 if($ValClass[$pos] eq 'p' && ($pos+1 > $#ValClass || $ValClass[$pos+1] ne 'f' || ($ValPerl[$pos+1] ne 're' && $ValPerl[$pos+1] ne 'tr'))); # issue s151 return 0 if($pos >= 5 && $ValClass[0] eq 't' && $ValClass[1] eq 's' && $ValClass[2] eq '(' && end_of_variable(1)+1 == $pos); # issue s151 if($ValClass[0] eq '(' && ($m = matching_br(0)) > $pos && $m+2 <= $#ValClass && $ValClass[$m+1] eq '~' && $ValClass[$m+2] eq 'f') { # issue s143 if($ValClass[0] eq '(' && ($m = matching_br(0)) > $pos && $m+2 <= $#ValClass && $ValClass[$m+1] eq 'p' && $ValClass[$m+2] eq 'f') { # issue s143, issue s151 if($ValPerl[$m+2] eq 'tr' && $ValPy[$m+2] !~ /,flags=[a-qs-z]*r[a-qs-z]*$/) { # issue s143 return 0; # issue s143: if this is a tr without an r flag, then no need to process it here } elsif($ValPerl[$m+2] eq 're' && $ValPy[$m+2] !~ /\bre\.R[|)]/) { # issue s143 return 0; # issue s143: if this is a re substitute without an r flag, then no need to process it here } # issue s143 } # issue s143 my $p = 0; $p = 1 if($ValClass[0] eq 't'); if($ValClass[$p] =~ /[ashG]/ && $ValClass[$pos] eq '=' && !has_comma_operator($pos+1,$#ValClass)) { # See if this is @a=@b=@c my $yup = 1; for(my $i = $p; $i <= $pos; $i += 2) { if($ValClass[$i] !~ /[ashG]/ || $ValClass[$i+1] ne '=') { $yup = 0; last; } } return 0 if($yup); # @a=@b=... } return 0 if(split_up_multiple_assignment(1)); # issue 115: Don't change it if we're gonna split it up my $start = start_of_var($pos-1); return 0 if($start < 0); # Not sure what this is return 0 if($ValClass[$start] !~ /[ashG]/); # Not something we handle my $end_pos = $#ValClass; $end_pos = matching_br($start-1)-1 if($start != 0 && $ValClass[$start-1] eq '('); return 0 if($end_pos < 0); # issue s181 my $lower = next_lower_or_equal_precedent_token($ValClass[$pos], $pos+1, $end_pos); if($lower >= 0) { # for test_slice with -M, we were placing the closing paren improperly due # to a function call with no parens if($ValClass[$lower] eq ',') { my $fi = next_same_level_tokens('fi', $pos, $lower); if($fi != -1 && $ValClass[$fi+1] ne '(') { # non-paren sub or function call while(($lower = next_lower_or_equal_precedent_token($ValClass[$pos], $lower+1, $end_pos)) != -1 && $ValClass[$lower] eq ',') { ; # Skip all commas until we get another low prec operator or run out of road } } } $end_pos = $lower-1 if($lower != -1); } my $close = next_same_level_tokens(');', $pos+1, $end_pos); $end_pos = $close-1 if($close >= $pos && $close <= $end_pos); say STDERR "pos=$pos, lower=$lower, close=$close, end_pos=$end_pos, \$#ValClass=$#ValClass" if($debug >= 5); my $adjust = 0; my $op; #if($start == 0 || $ValClass[$start-1] ne '(' || $ValClass[$end_pos+1] ne ')') { # All := operations must be in '(' ')' #insert($start, '(', '(', '('); #$pos++; #$end_pos++; #$start++; #insert($end_pos+1, ')', ')', ')'); #$adjust += 2; #} while($ValClass[$start+1] eq 'D' && $ValClass[$start+2] eq 'i') { # $obj->var, change to obj.var $ValPerl[$start] .= '->' . $ValPerl[$start+2]; $ValPy[$start] .= '.' . $ValPy[$start+2]; destroy($start+2, 2); $adjust -= 2; } my $cs = &Perlscan::cur_sub(); # issue s185 my $arg; if($ValClass[$pos] eq '=' && $ValClass[$start] eq 's' && ($pos-$start) == 1 && (($ValPerl[$start] eq '$_' && $ValPy[$start] =~ /^$PERL_ARG_ARRAY\[(\d+)\]$/) || # issue s241 $ValType[$start] eq 'ss' && exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arg_copies} && # issue s241 exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$start]} && ($arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$start]}) >= 0) $ValType[$start] eq 'ss' && defined get_sub_attribute($cs, 'arg_copies') && exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$start]} && ($arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$start]}) >= 0) # issue s241 ) { # Assignment to constant arg, or a reference to one, or a copy of a reference to one # issue s184 logme('W', 'Assignment to sub arg will not change the argument passed in python'); # issue s184 insert($start+1, ')', ']', ']'); # make the subscript explicit # issue s184 insert($start+1, 'd', $1, $1); # issue s184 insert($start+1, '(', '[', '['); # issue s184 $ValPy[$start] = $PERL_ARG_ARRAY; # issue s184 $adjust += 3; # issue s184 $pos += 3; # issue s184 $end_pos += 3; # issue s184: Handle this case for real now! my $which_arg; my $als = 0; # issue s184 my $perl_arg_array = '@_'; # issue s185 my $python_arg_array = $PERL_ARG_ARRAY; # issue s185 if(defined $arg) { # issue s185 $which_arg = $arg; # issue s185 $perl_arg_array = 'undef'; # issue s185: for an arg copy, we don't store it in the arglist $python_arg_array = 'None'; # issue s185 } else { # issue s185 $which_arg = $1; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 } insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', '', ", shifts=$als") if($als); if(defined $arg) { # issue s185: We need to set the arg copy variable to the result of the expression insert($end_pos+1, ')', ')', ')'); # issue s185 insert($pos+1, '=', '=', ':='); # issue s185 insert($pos+1, $ValClass[$start], $ValPerl[$start], $ValPy[$start]); # issue s185 # Don't set the ValType else we will try to do this transformation again!! $ValType[$pos+1] = $ValType[$start]; # issue s185 insert($pos+1, '(', '(', '('); # issue s185 $adjust += 4; # issue s185 } replace($pos, ',', ',', ','); replace($start, 'd', $which_arg, $which_arg); insert($start, ',', ',', ','); insert($start, 'y', $perl_arg_array, $python_arg_array); # Make it 'y' so we don't try to splat it insert($start, '(', '(', '('); insert($start, 'f', '_store_out_parameter', '_store_out_parameter'); $adjust += ($als ? 6 : 5); say STDERR "After handle_assignment_in_expression($pos): =|$TokenStr|=, ValPy=@ValPy, adjust=$adjust" if($debug); return $adjust; } if($ValClass[$start] =~ /[ashG]/ && $pos-$start == 1) { # Something we can easily handle if($ValPy[$pos] eq '=') { ($start, $pos, $end_pos, $adjust) = add_parens($start, $pos, $end_pos, $adjust); $ValPy[$pos] = ':='; } if($ValClass[$pos] eq '=' && $ValPy[$pos] ne ':='){ # '+=' and friends ($start, $pos, $end_pos, $adjust) = add_parens($start, $pos, $end_pos, $adjust); $op = substr($ValPy[$pos],0,1); # '+', etc insert($pos+1, $op, $op, $op); insert($pos+1, $ValClass[$start], $ValPerl[$start], $ValPy[$start]); $ValPy[$pos] = ':='; $ValPerl[$pos] = '='; $adjust += 2; $end_pos += 2; } if(index($ValPy[$start], '.') >= 0) { # a.b := ..., change to _assign_global('a', 'b', ...) ($start, $pos, $end_pos, $adjust) = add_parens($start, $pos, $end_pos, $adjust); my $dot = rindex($ValPy[$start], '.'); my $a = substr($ValPy[$start], 0, $dot); my $b = substr($ValPy[$start], $dot+1); $op = $ValClass[$pos]; # issue s151 if($op eq '~' && $ValPerl[$pos+1] eq 're' && $ValPy[$pos+1] =~ /re\.R/) { # If 'r' flag, we don't need any of this! if($op eq 'p' && $ValPerl[$pos+1] eq 're' && $ValPy[$pos+1] =~ /re\.R/) { # If 'r' flag, we don't need any of this!, issue s151 say STDERR "After handle_assignment_in_expression($pos): =|$TokenStr|=, ValPy=@ValPy, adjust=$adjust" if($debug); return $adjust; } replace($start, '"', $ValPerl[$start], "'$a'"); replace($pos, ',', ',', ','); insert($pos, '"', $b, "'$b'"); insert($pos, ',', ',', ','); my $func = '_assign_global'; # issue s151 if($op eq '~') { # Regex if($op eq 'p') { # Regex if($ValPerl[$pos+3] eq 're') { $func = '_substitute_global'; my $flags = process_re_flags($pos+3); if( substr($ValPy[$pos+3],0,1) eq '.' ){ # issue s344: .replace(x,y,1) $ValPy[$pos+3] =~ s/\.replace/re.sub/; # issue s344: Can't use the ez method in this case $ValPy[$pos+3] =~ s/,1\)/,/; # issue s344 } # issue s344 $ValPy[$pos+3] =~ s/^re\.sub\(//; $ValPy[$pos+3] = $ValPy[$pos+3] . $flags; } else { $func = '_translate_global'; # issue bootstrap $ValPy[$pos+3] = 'str' . tr_flags_to_args($ValPy[$pos+3]); $ValPy[$pos+3] = tr_flags_to_args($ValPy[$pos+3]); # issue bootstrap } # issue s328 $ValClass[$pos+3] = 'y'; # Plain python code replace($pos+3, 'y', $ValPerl[$pos+3], $ValPy[$pos+3]); # issue s328: This makes $TokenStr consistent with $ValClass[$pos+3] } insert($start-1, 'f', $func, $func); $Pyf{$func} = 1; $adjust += 3; } elsif($ValClass[$pos] eq 'p' && has_comma_operator($start, $end_pos)) { # issue s299: We need to put the regex in parens ($start, $pos, $end_pos, $adjust) = add_parens($start, $pos, $end_pos, $adjust); # issue s299 } } elsif($ValClass[$pos-1] eq ')' && ($ValPerl[$pos-1] eq '}' || $ValPerl[$pos-1] eq ']')) { # $a[...]{N} := ..., change to _set_element($a[...], N, ...) ($start, $pos, $end_pos, $adjust) = add_parens($start, $pos, $end_pos, $adjust); my $rev = reverse_matching_br($pos-1); return $adjust if($rev < 0); if($ValClass[$pos] eq '=') { $op = substr($ValPerl[$pos],0,length($ValPerl[$pos])-1); # '+', '<<', etc $op = '' if($op eq '=' || $op eq ':'); return $adjust if(!exists $ARRAY_INDEX_FUNCS{$op}); } else { if($ValPerl[$pos+1] eq 'tr') { $op = '~tr'; # to get us _translate_element $ValPy[$pos+1] = tr_flags_to_args($ValPy[$pos+1]); $ValClass[$pos+1] = 'y'; # Plain python code } else { $op = '~re'; # to get us _substitute_element $ValClass[$pos+1] = 'y'; # Plain python code my $j = 2; my $flags = process_re_flags($pos+1); if(substr($ValPy[$pos+1],0,1) eq '.') { # issue s344 $ValPy[$pos+1] =~ s/^\.replace/re.sub/; # issue s344 $ValPy[$pos+1] =~ s/,1\)\Z/,/; # issue s344 } # issue s344 $ValPy[$pos+1] =~ s/^re\.sub\(//; insert($pos+$j++, 'y', '', $flags); $adjust++; $end_pos++; #insert($pos+$j, ')', ')', ')'); #$adjust++; } } my $func = $ARRAY_INDEX_FUNCS{$op}; $Pyf{$func} = 1; replace($pos, ',', ',', ','); insert($rev, ',', ',', ','); destroy($pos,1); # Eat the '}' destroy($rev+1,1); # Eat the '{' insert($start-1, 'f', $func, $func); $start++; $end_pos++; if($ValPerl[$start] eq '$_' && $ValPy[$start] eq $PERL_ARG_ARRAY && $ValClass[$start+1] eq ',') { # issue s184 # Handle assignment to a variable element of $PERL_ARG_ARRAY by calling _store_out_parameter # Be careful, as the functions _translate_element and _substitute_element return the count, not the result! # # f(s,s,f) # ^start # ^end_pos $Pyf{_store_out_parameter} = 1; my $als = 0; # issue s184 # issue 241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 if($op eq '~tr' || $op eq '~re') { # Hard cases, as we don't have the result handy except in the arglist element # Generate (_translate_element(_args, (_s:=pos), value), _store_out_parameter(_args, _s, _args[_s], shifts=N))[0] insert($end_pos+1, 'y', '', '[0]'); insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', '', ", shifts=$als") if($als); insert($end_pos+1, ')', ']', ']'); insert($end_pos+1, 'y', '', $SUBSCRIPT_TEMP); insert($end_pos+1, '(', '[', '['); insert($end_pos+1, $ValClass[$start], $ValPerl[$start], $ValPy[$start]); insert($end_pos+1, ',', ',', ','); insert($end_pos+1, 'y', '', $SUBSCRIPT_TEMP); insert($end_pos+1, ',', ',', ','); insert($end_pos+1, $ValClass[$start], $ValPerl[$start], $ValPy[$start]); insert($end_pos+1, '(', '(', '('); insert($end_pos+1, 'f', '_store_out_parameter', '_store_out_parameter'); insert($end_pos+1, ',', ',', ','); my $c1 = next_same_level_token(',', $start, $end_pos); my $c2 = next_same_level_token(',', $c1+1, $end_pos); insert($c2, ')', ')', ')'); insert($c1+1, '=', '=', ':='); insert($c1+1, 'y', '', $SUBSCRIPT_TEMP); insert($c1+1, '(', '(', '('); insert($start-2, '(', '(', '('); $adjust += ($als ? 20 : 19); } elsif($op eq '') { # Easist case: _set_element # Replace _set_element(_args, pos, value) with _store_out_parameter(_args, pos, value, shifts=N) insert($end_pos, 'y', '', ", shifts=$als") if($als); replace($start-2, 'f', '_store_out_parameter', '_store_out_parameter'); $adjust++; } else { # Generate _store_out_parameter(_args, (_s:=pos), _add_element(_args, _s, value), shifts=N) insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', '', ", shifts=$als") if($als); insert($start-2, ',', ',', ','); insert($start-2, ')', ')', ')'); my $c1 = next_same_level_token(',', $start+2, $end_pos+2); my $c2 = next_same_level_token(',', $c1+1, $end_pos+2); my $adj = 0; for(my $i = 1; $i < ($c2-$c1); $i++) { # $c2 effectively moves each time we insert insert($start-2, $ValClass[$c2-1], $ValPerl[$c2-1], $ValPy[$c2-1]); # Copy 'pos' $adj++; } insert($start-2, '=', '=', ':='); insert($start-2, '(', '(', '('); insert($start-2, ',', ',', ','); insert($start-2, 's', '$_', $PERL_ARG_ARRAY); insert($start-2, '(', '(', '('); insert($start-2, 'f', '_store_out_parameter', '_store_out_parameter'); $c1 += 6 + $adj; $c2 += 6 + $adj; replace($c1+1, 'y', '', $SUBSCRIPT_TEMP); destroy($c1+2, ($c2-$c1)-2) if($c2-$c1 > 2); # Blow away the rest of 'pos' if there is any $adjust += ($als ? 11 : 10); } } } say STDERR "After handle_assignment_in_expression($pos): =|$TokenStr|=, ValPy=@ValPy, adjust=$adjust" if($debug); return $adjust; } sub handle_eval_in_expression # issue 42 # If this expression has an eval in it, then generate the code for it first { my $pos = shift; # Point to the eval # Return in the only cases we handle already return 0 if($pos == 0 && ($#ValClass == 0 || $ValClass[1] eq '(')); return 0 if($pos == 2 && $ValClass[0] eq 's' && $ValClass[1] eq '=' && ($#ValClass == 2 || $ValClass[3] eq '(')); # issue s13 return 0 if($pos == 3 && $ValClass[0] eq 't' && $ValClass[1] eq 's' && $ValClass[2] eq '=' && ($#ValClass == 3 || $ValClass[4] eq '(')); # issue s13 return 0 if $pos == $#ValClass && exists $Perlscan::line_contains_stmt_modifier{$Perlscan::statement_starting_lno}; # issue s219: Handled elsewhere if($saved_eval_tokens) { logme('S', "Only 1 eval expression per line handled"); } my $need_result = ($pos != 0); my $suffix = (exists $eval_suffix{$.} ? chr(ord($eval_suffix{$.})+1) : ''); my $result = "$EVAL_RESULT$.$suffix"; # # We save the original tokens, then change the current line to something we can handle, which is a simple # _eval_resultLNO = eval {...} # then replace the eval in the original tokens with the _eval_resultLNO. # $saved_eval_tokens = package_tokens(); $saved_eval_lno = $.; my $t; # issue s179 my @tmpBuffer = @Perlscan::BufferValClass; # SNOOPYJC: Skip the block on getting the next line @saved_eval_BufferValClass = @Perlscan::BufferValClass; # issue s179 @Perlscan::BufferValClass = (); while(($t = getline())) { push @saved_eval_buffer, $t; say STDERR "pushed $t onto saved_eval_buffer" if($debug >= 5); } # issue s179 @Perlscan::BufferValClass = @tmpBuffer; $saved_eval_token_buffer_active = $token_buffer_active; # issue s179 $token_buffer_active = 0; # issue s179 if($pos == 0) { # We don't need the result p_replace($saved_eval_tokens, $pos, 'C', 'nop', ''); # Make it a no-op } else { p_replace($saved_eval_tokens, $pos, 's', '$'.$result, $result); } my $adjust = 0; if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '"') { # String or here doc string my $fc; if(($fc = substr($ValPy[$pos+1],0,1)) ne "'" && $fc ne '"') { # issue s350: Handle dynamic 'require' and 'use' only # NOTE: Dynamic 'use' is not handled by do_use_require, so we exclude it # if($ValPerl[$pos+1] =~ /^(require|use)\s+([^\s;]*)(\s*.*?(?:;\s*1;?)?)$/) { # issue s350: Handle as special case if($ValPerl[$pos+1] =~ /^(require)\s+([^\s;]*)(\s*(?:;\s*1;?)?)$/) { # issue s350: Handle as special case $ValPy[$pos+1] = &Perlscan::escape_quotes("$1 \"$2\"$3"); # issue s350: e.g. require "$test"; 1 logme('W', "eval with dynamic require does not allow Pythonizer to properly examine the module being imported"); } else { logme('S', "eval with interpolated string not handled!"); } } p_destroy($saved_eval_tokens, $pos+1, 1); my $text; #if(substr($ValPy[$pos+1],0,3) eq '"""') { #$text = substr($ValPy[$pos+1],3,length($ValPy[$pos+1])-6); #} elsif(substr($ValPy[$pos+1],0,3) eq "'''") { #$text = substr($ValPy[$pos+1],3,length($ValPy[$pos+1])-6); #} elsif(substr($ValPy[$pos+1],0,1) eq 'f') { # was flagged as an error above, but we still generate something (probably wrong) if(substr($ValPy[$pos+1],0,1) eq 'f') { $text = "$ValPerl[$pos+1] #FAILTRAN"; } else { #$text = substr($ValPy[$pos+1], 1, length($ValPy[$pos+1])-2); $text = unquote_string($ValPy[$pos+1]); } say STDERR "eval contents = $text" if $debug >= 5; my @lines = split(/^/m, $text); getline('{'); # Push to regular buffer (helps us count lines easier) for my $ln (@lines) { #say STDERR "Pushing " . substr($ln,0,length($ln)-1); getline($ln,1); # Push to special_buffer } getline('}',1); # Push to special_buffer $adjust = $pos-$#ValClass; destroy($pos+1, $#ValClass-$pos); } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '(') { my $close = matching_br($pos+1); return 0 if($close < 0); $adjust = $close-$#ValClass; destroy($close+1, $#ValClass-$close) if($close != $#ValClass); p_destroy($saved_eval_tokens, $pos+1, $close-$pos); # Remove the {...} } else { $end_pos = $#ValClass; my $close = next_same_level_token(')', $pos+1, $end_pos); $end_pos = $close-1 if($close > 0); $adjust = $end_pos-$#ValClass; destroy($end_pos+1, $#ValClass-$end_pos) if($end_pos != $#ValClass); p_destroy($saved_eval_tokens, $pos+1, $end_pos-$pos); } if($pos == 0) { # We don't need the result ; } else { # we need the result insert($pos, '=', '=', '='); destroy(0, $pos) if($pos != 0); insert(0, 's', '$'.$result, $result); $adjust += 2-$pos; } say STDERR "handle_eval_in_expression gives =|$TokenStr|=, adjust=$adjust, ValPy=@ValPy" if($debug); return $adjust; } sub handle_statement_function_in_expression # issue s150 # If this expression has an statement function like getopts/GetOptions in it, then generate the code for it first { my $pos = shift; # Point to the statement function if($ValPerl[$pos] eq 'chop' || $ValPerl[$pos] eq 'chomp') { # issue s167: These are handled by perllib replacements my $start = $pos+1; my $end_pos; my $bracketed = 0; if($start <= $#ValClass && $ValPerl[$start] eq '(') { $end_pos = matching_br($start)-1; $start++; $bracketed = 1; } else { $end_pos = end_of_function($pos); } my $comma = next_same_level_token(',', $start, $end_pos); if($comma == -1) { # easy case - one arg $ValPerl[$pos] = "_$ValPerl[$pos]_with_result"; # _chop_with_result or _chomp_with_result $ValPy[$pos] = $ValPerl[$pos]; $Pyf{$ValPy[$pos]} = 1; return 0; } # Hard case - a list of args - need one function per arg # Start by just making a list of args w/o f(...) my $adjust = 0; my $orig_function = $ValPerl[$pos]; my $new_function = ($orig_function eq 'chop' ? "_chop_without_result" : "_chomp_with_result"); my $final_function = ($orig_function eq 'chop' ? "_chop_with_result" : "_chomp_with_result"); my @op = ($orig_function eq 'chop' ? ('.', '.', '+') : ('+', '+', '+')); if($bracketed) { destroy($end_pos+1, 1); destroy($start-1, 1); $start--; $end_pos--; $comma--; $adjust = -2; } destroy($pos, 1); $start--; $end_pos--; $comma--; $adjust -= 1; while($comma != -1) { replace($comma, @op); insert($comma, ')',')',')'); insert($start, '(','(','('); insert($start, 'f', $new_function, $new_function); $adjust += 3; $comma += 3; $end_pos += 3; $start = $comma+1; $comma = next_same_level_token(',', $start, $end_pos); } insert($end_pos, ')', ')', ')'); insert($start, '(','(','('); insert($start, 'f', $final_function, $final_function); $adjust += 3; say STDERR "handle_statement_function_in_expression($pos) for $orig_function w/list gives =|$TokenStr|= ValPerl = @ValPerl, adjust=$adjust" if($debug); return $adjust; } # Return in the only cases we handle already return 0 if($pos == 0 && ($#ValClass == 0 || $ValClass[1] eq '(')); if($saved_eval_tokens) { logme('S', "Only 1 eval/getopts/GetOptions expression per line handled"); } my $need_result = ($pos != 0); my $suffix = ''; my $result = "$ELSIF_TEMP"; # # We save the original tokens, then change the current line to something we can handle, which is a simple # _e = GetOptions(...) # then replace the GetOptions call in the original tokens with the _e # $saved_eval_tokens = package_tokens(); $saved_eval_lno = $.; my $t; # issue s179 my @tmpBuffer = @Perlscan::BufferValClass; # SNOOPYJC: Skip the block on getting the next line @saved_eval_BufferValClass = @Perlscan::BufferValClass; # issue s179 @Perlscan::BufferValClass = (); while(($t = getline())) { push @saved_eval_buffer, $t; say STDERR "pushed $t onto saved_eval_buffer" if($debug >= 5); } # issue s179 @Perlscan::BufferValClass = @tmpBuffer; $saved_eval_token_buffer_active = $token_buffer_active; # issue s179 $token_buffer_active = 0; # issue s179 p_replace($saved_eval_tokens, $pos, 's', '$'.$result, $result); my $adjust = 0; if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '(') { my $close = matching_br($pos+1); return 0 if($close < 0); $adjust = $close-$#ValClass; destroy($close+1, $#ValClass-$close) if($close != $#ValClass); p_destroy($saved_eval_tokens, $pos+1, $close-$pos); # Remove the {...} } else { $end_pos = $#ValClass; my $close = next_same_level_token(')', $pos+1, $end_pos); $end_pos = $close-1 if($close > 0); $adjust = $end_pos-$#ValClass; destroy($end_pos+1, $#ValClass-$end_pos) if($end_pos != $#ValClass); p_destroy($saved_eval_tokens, $pos+1, $end_pos-$pos); } insert($pos, '=', '=', '='); destroy(0, $pos) if($pos != 0); insert(0, 's', '$'.$result, $result); $adjust += 2-$pos; say STDERR "handle_statement_function_in_expression gives =|$TokenStr|=, adjust=$adjust, ValPy=@ValPy" if($debug); return $adjust; } sub tr_flags_to_args # Convert flags on 'tr' to appropriate args for the handlers _translate, _translate_and_count, _translate_global and _translate_element { my $py = shift; my %flag_map=(r=>'replace=False', c=>'complement=True', d=>'delete=True', s=>'squash=True'); my $orig_py = $py; my $flags=''; if($py =~ /,flags=([a-z]+)/) { $flags = $1; $py =~ s/,flags=[a-z]+//; } my @args = (); for(my $i=0; $i < length($flags); $i++) { $flag = substr($flags,$i,1); if(exists $flag_map{$flag}) { push @args, $flag_map{$flag}; } } if(@args) { $py .= ',' . join(',', @args); } say STDERR "tr_flags_to_args($orig_py)=$py" if($debug >= 3); return $py; } sub tr_count_only # Is this tr only doing a count? { my $py = shift; # Case 1: We have the same LHS and RHS and no flags: e.g. str.maketrans('()','()') return 1 if($py =~ /^str.maketrans\('(.+)','(.+)'\)$/ && $1 eq $2); return 1 if($py =~ /^str.maketrans\("(.+)","(.+)"\)$/ && $1 eq $2); return 1 if($py =~ /^str.maketrans\("""(.+)""","""(.+)"""\)$/ && $1 eq $2); return 1 if($py =~ /^str.maketrans\('''(.+)''','''(.+)'''\)$/ && $1 eq $2); # Case 2: Only complement is set and the RHS is empty: e.g. perllib.maketrans_c('0123456789',''),complement=True return 1 if($py =~ /maketrans_c\(.+,''\),complement=True$/); return 0; } sub process_re_flags # Process the re flags that don't really exist by making them options { my $pos = shift; my $re_count = 1; # issue 11 if($ValPy[$pos] =~ /re\.G/) { # issue 11 $re_count = 0; # issue 11 $ValPy[$pos] =~ s/,re\.G\|/,/; # issue 11 $ValPy[$pos] =~ s/ else re\.G/ else 0/; # issue s140 $ValPy[$pos] =~ s/.re\.G//; # issue 11 } my $replace = ''; if($ValPy[$pos] =~ /re\.R/) { $replace = 'replace=False,'; $ValPy[$pos] =~ s/,re\.R\|/,/; $ValPy[$pos] =~ s/.re\.R//; } return "${replace}count=$re_count"; } sub handle_anonymous_sub_in_expression # We have a list of tokens that stop abruptly with a "sub", save those tokens, # generate the code for the sub, then continue lexxing and generating the # rest of the expression, with the sub replaced by a reference to it. { # issue s26 my $subname = "$ANONYMOUS_SUB$."; my $subname = new_anonymous_sub(); # issue s26 # issue s76: if this is a function template, then generate an outer def with one argument being # the template variable, and remove the "global" declaration for that variable, then declare an inner # def with the normal arguments, and the template variable defined as nonlocal, and add a "return" # statement to return this inner def. Then replace the reference to this sub, with a call of the sub, # passing the template variable as an argument. # A function template is defined as *$template_var = sub {...} (is this right???) # The tokens of a function template look like *(s)=k, and ValPy = main.__dict__ [ tag ] = def $top = $Perlscan::nesting_stack[-1]; # issue s76 if($TokenStr eq '*(s)=k') { # issue s76 say STDERR "Potential function template with $ValPerl[2] detected!" if($debug); # issue s76 $nested_subs{$subname} = $ValPy[2]; # issue s76 $top->{function_template} = $ValPerl[2]; # issue s76 } elsif($TokenStr eq 's(")=k' && ($ValPy[2] =~ /::\{(\w+)\}.$/ || $ValPy[2] =~ /::\{_bn\((\w+)\)\}.$/)) { # issue s244 say STDERR "Potential function template with $1 detected!" if($debug); # issue s244 $nested_subs{$subname} = $1; # issue s244 my $ft = $ValPerl[2]; # issue s244 $ft =~ s/^.*:://; # issue s244 $top->{function_template} = $ft; # issue s244 } else { # issue s76 $nested_subs{$subname} = "\*$PERL_ARG_ARRAY"; } push @saved_sub_tokens_stack, $saved_sub_tokens; # issue s311 push @saved_sub_tokens_level, $nested_sub_at_level; # issue s311 $saved_sub_tokens = package_tokens(); say STDERR "handle_anonymous_sub_in_expression: nesting_level=$Perlscan::nesting_level, nested_sub_at_level=$nested_sub_at_level, nested_sub_at_levels=@nested_sub_at_levels" if($debug>=3); p_replace($saved_sub_tokens, $#ValClass,'"',$subname,$subname); # Change the 'sub' to the subname reference if(exists $top->{function_template}) { # issue s76 # Make this a call with one argument - our template variable p_append($saved_sub_tokens, '(','(','('); # issue s76 p_append($saved_sub_tokens, 's', $top->{function_template}, $nested_subs{$subname}); # issue s76 p_append($saved_sub_tokens, ')',')',')'); # issue s76 } # issue s76 destroy(0, $#ValClass); append('i', $subname, $subname); # Since we already processed the '{' after the 'sub', adjust the nesting_info at the top of the stack # issue s76 $top = $Perlscan::nesting_stack[-1]; $top->{is_sub} = 1; $top->{in_sub} = 1; $top->{cur_sub} = $subname; # issue s243 $top->{type} = 'sub'; $top->{type} = 'def'; # issue s243: We need to use the python name here if(scalar(@eval_stack)) { # issue s243 $top->{in_eval_at_stack_level} = $#eval_stack; # issue s243 } # Now we go and generate the code for the nested sub } sub handle_do_in_expression # issue s74 # We have a list of tokens that stop abruptly with a "do", save those tokens, # generate the code for the do as a sub, then continue lexxing and generating the # rest of the expression, with the do replaced by a reference to it. { my $subname = new_anonymous_sub(); $nested_subs{$subname} = ""; push @saved_sub_tokens_stack, $saved_sub_tokens; # issue s311 push @saved_sub_tokens_level, $nested_sub_at_level; # issue s311 $saved_sub_tokens = package_tokens(); p_replace($saved_sub_tokens, $#ValClass,'i',$subname,$subname); # Change the 'do' to the subname reference p_append($saved_sub_tokens,'(','(','('); # insert '()' p_append($saved_sub_tokens,')',')',')'); destroy(0, $#ValClass); replace(0,'k','sub','def'); append('i', $subname, $subname); # Since we already processed the '{' after the 'do', adjust the nesting_info at the top of the stack $top = $Perlscan::nesting_stack[-1]; $top->{is_sub} = 1; $top->{in_sub} = 1; $top->{cur_sub} = $subname; $top->{type} = 'sub'; $top->{was_do} = 1; # issue s137 # Now we go and generate the code for the nested sub } sub handle_conditional_eval # issue s219 # We have a list of tokens that stop abruptly with an "eval" that also has a statement modifier like "if ...;', # save those tokens, generate the code for the eval as a sub, then continue lexxing and generating the # rest of the expression, with the eval replaced by a reference to it. { $top = $Perlscan::nesting_stack[-1]; # issue s318 # issue s318: if we have an eval without {...}, then we already processed the if statement modifier, and that is # what is at the top of the nesting stack, not an eval, so we don't need this transformation return if !$top->{is_eval}; # issue s318: See issue_s179 case eval 'mysub()' unless 1==2; my $subname = new_anonymous_sub(); $nested_subs{$subname} = ""; push @saved_sub_tokens_stack, $saved_sub_tokens; # issue s311 push @saved_sub_tokens_level, $nested_sub_at_level; # issue s311 $saved_sub_tokens = package_tokens(); p_append($saved_sub_tokens, 'i',$subname,$subname); # Insert _f after the 'eval' p_append($saved_sub_tokens,'(','(','('); # insert '()' p_append($saved_sub_tokens,')',')',')'); destroy(0, $#ValClass); replace(0,'k','sub','def'); append('i', $subname, $subname); # Since we already processed the '{' after the 'eval', adjust the nesting_info at the top of the stack # issue s318 $top = $Perlscan::nesting_stack[-1]; $top->{is_sub} = 1; $top->{in_sub} = 1; $top->{cur_sub} = $subname; $top->{type} = 'sub'; $top->{was_eval} = 1; # Now we go and generate the code for the nested sub } #sub handle_anonymous_sub_in_expression # issue 81 #{ # # given a "sub { ... }" in an expression, bust it out and replace it with an anonymous sub ref # # arg1 = starting position # # arg2 = position of "sub" # # arg3 = end of line # my $start = shift; # my $pos = shift; # my $limit = shift; # state $anon_counter = 1; # # return if($pos == $limit || $ValClass[$pos+1] ne '('); # my $close_br = matching_br($pos+1); # my $fname = "$ANONYMOUS_SUB$anon_counter"; # $anon_counter++; # insert($pos+1, 'i', $fname, $fname); # $close_br++; # control($pos, $close_br); # $adjust = ($close_br - ($pos+2))+1; # destroy($pos+2, $adjust); # destroy($pos, 1); # $adjust++; # return -$adjust; #} sub is_expression_simple # Heuristic to see if this expression is simple or not # This is used in the case of $arr[EXPR] += 1, where we have to # first do a type conversion on the $arr[EXPR]. Since _num($arr[EXPR])+=1 won't do # the trick, we have to generate arr[EXPR] = _num(arr[EXPR]) + 1. If EXPR # has any side-effects, or is slow to compute, we wouldn't want to run it twice, # so we generate: arr[_s0] = _num(arr[(_s0:=EXPR)]) + 1. (_s is called $SUBSCRIPT_TEMP) # This is also used for a hash key. { my $start = shift; my $end = shift; return 0 if($end-$start >= 10); # too long for(my $i=$start; $i<=$end; $i++) { # Just allow a few simple things return 0 if(index('"ds+-*()', $ValClass[$i]) < 0); } return 1; } sub unquote_string # SNOOPYJC # Remove the quotes (and escapes) from the given python string { my $string = shift; my $result = $string; $string =~ s/^(?:fr|rf|f|r)//; my $quote = substr($string,0,1); return $result if $quote ne '"' && $quote ne "'"; # Get out quick if it's not quoted my $quote3 = substr($string,0,3); $quote = $quote3 if($quote3 eq '"""' || $quote3 eq "'''"); $result = ''; for(my $i = length($quote); $i <= length($string)-length($quote); $i++) { my $ch = substr($string, $i, 1); if($ch eq "\\") { my $ch1 = substr($string,$i+1,1); if($ch1 eq "\\" || $ch1 eq '"' || $ch1 eq "'") { $result .= $ch1; $i++; next; } } elsif($ch eq $quote) { last; } elsif(length($quote) == 3 && substr($string,$i,3) eq $quote) { last; } $result .= $ch; } say STDERR "unquote_string($string) = $result" if($debug >= 5); return $result; } sub escape_string # Escape any \ or delim chars in the given string { my $string = shift; my $delim = shift; my $result = ''; for(my $i=0; $i < length($string); $i++) { my $ch = substr($string, $i, 1); if($ch eq "\\" || $ch eq $delim) { $result .= "\\"; } $result .= $ch; } return $result; } sub do_use_require { # require VERSION # require EXPR # require (uses $_ as EXPR) # # use Module VERSION LIST # use Module VERSION # use Module LIST # use Module # use VERSION # # no Module VERSION LIST # no Module VERSION # no Module LIST # no Module # no VERSION # # Lets get the 'VERSION' and predefined forms out of the way first: my $pos = shift; say STDERR "do_use_require($pos)" if($debug>=3); if($pos+1 <= $#ValClass && # use v5.24.1 -or- use 5.24.1 -or- use 5.024_001 -or- ($ValClass[$pos+1] eq 'd' || # use Carp::Assert (something built-in) ($ValClass[$pos+1] eq '"' && substr($ValPy[$pos+1],0,3) eq "'\\x") || ($ValClass[$pos+1] eq 'i' && exists $BUILTIN_LIBRARY_SET{$ValPerl[$pos+1]}))) { if(exists $STAT_SUB{$ValPerl[$pos+1]}) { $uses_file_stat = 1; #$Perlscan::keyword_tr{stat} = $STAT_SUB{$ValPerl[$pos+1]}; # Swap it out! } if(exists $LSTAT_SUB{$ValPerl[$pos+1]}) { $uses_file_stat = 1; #$Perlscan::keyword_tr{lstat} = $LSTAT_SUB{$ValPerl[$pos+1]}; # Swap it out! } if($ValPerl[$pos+1] eq 'English') { # use English handle_block_scope_pragma($uses_english, 'english', sub { $uses_english = $_[0]; }, ($ValPerl[$pos] eq 'no' ? 0 : 1)); } elsif($ValPerl[$pos+1] eq 'integer') { # use integer handle_block_scope_pragma($uses_integer, 'integer', sub { $uses_integer = $_[0]; $CONVERTER_MAP{N} = ($uses_integer ? '_int' : '_num'); }, ($ValPerl[$pos] eq 'no' ? 0 : 1)); } elsif($ValPerl[$pos+1] eq 'autodie') { $autodie = 1; if($import_perllib) { gen_statement("$PERLLIB.AUTODIE = 1"); } else { gen_statement("AUTODIE = 1"); } } elsif($ValPerl[$pos+1] eq 'autovivification') { $autovivification = (($ValPerl[$pos] eq 'no') ? 0 : 1); } elsif($ValClass[$pos+1] eq 'i' && exists $PREDEFINED_PACKAGES{$ValPy[$pos+1]}) { # test_Time_HiRes: # For predefined packages such as Time::HiRes that overload existing functions, # we defer replacing the function in the %Perlscan::keyword_tr hash to only replace # it if they mention the function name in the import. Handle that here and below # where we actually import, too. my $package = $ValPy[$pos+1]; my @desired_imports = (); for(my $i = $pos+2; $i <= $#ValClass; $i++) { if($ValClass[$i] eq '"') { push @desired_imports, $ValPerl[$i]; } elsif($ValClass[$i] eq 'q') { # qw if(index(q('"), substr($ValPy[$i],0,1)) >= 0) { push @desired_imports, unquote_string($ValPy[$i]); } else { push @desired_imports, split(' ', $ValPy[$i]); # qw(...) on use stmt doesn't generate the split } } } for my $desired (@desired_imports) { my $fullname = $package . '::' . $desired; if(exists $Perlscan::keyword_tr{$fullname}) { $Perlscan::keyword_tr{$desired} = $Perlscan::keyword_tr{$fullname}; $Perlscan::TokenType{$desired} = 'f'; # promote it from 'F' (weak function) say STDERR "For builtin: Importing method $fullname as $desired, mapped to $Perlscan::keyword_tr{$desired}" if $debug >= 3; } } } if($pos != 0) { # issue s152 gen_chunk('0'); gen_chunk('1'); # issue s152 } elsif($Pythonizer::CurNest) { output_line('pass',' #SKIPPED: '.$line); # issue 96 } else { output_line('','#SKIPPED: '.$line); } # issue s152: Change the return value to skip all the stuff listed like qw/.../ etc my $limit = $#ValClass; my $opp = next_lower_or_equal_precedent_token('F', $pos, $limit); $limit = $opp-1 if($opp >= $pos); my $close = next_same_level_token(')', $pos, $limit); $limit = $close-1 if($close >= $pos); say STDERR "do_use_require($pos) returns " . ($limit+1) if($debug>=3); return $limit+1; # issue s152 say STDERR "do_use_require($pos) returns " . ($pos+2) if($debug>=3); # issue s152 return $pos+2; } if($ValPerl[$pos] eq 'no') { if($pos != 0) { # issue s152 gen_chunk('0'); gen_chunk('1'); # issue s152 } elsif($Pythonizer::CurNest) { output_line('pass',' #SKIPPED: '.$line); # issue 96 } else { output_line('','#SKIPPED: '.$line); } say STDERR "do_use_require($pos) returns " . ($pos+2) if($debug>=3); return $pos+2; } elsif($ValPerl[$pos] eq 'require' && $implicit_global_my) { logme('W', "'require $ValPerl[$pos+1]' translated with -m flag will not allow global variables to be shared with that script"); } if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'lib') { # use lib LIST # # NOTE: See also handle_use_lib in Perlscan.pm # my @libs = (); my $dir = dirname($Pythonizer::fname); # issue s133 for(my $i=$pos+2; $i<=$#ValClass; $i++) { if($ValClass[$i] eq '"') { # Plain String my $lib = $ValPy[$i]; # issue s133 $lib =~ s/\{_bn\(FindBin\.Bin_v\)\}/$dir/; # issue s133 push @libs, $lib; # issue s133 } elsif($ValClass[$i] eq 'q') { # qw(...) or the like if(index(q('"), substr($ValPy[$i],0,1)) >= 0) { push @libs, $ValPy[$i]; } else { push @libs, map {'"'.$_.'"'} split(' ', $ValPy[$i]); # qw(...) on use stmt doesn't generate the split } } elsif($ValClass[$i] eq 'f') { # Handle dirname($0) only if($ValPerl[$i] eq 'dirname' && $ValPerl[$i+1] eq '$0') { push @libs, '"' . dirname($Pythonizer::fname) . '"'; $i++; } elsif($ValPerl[$i] eq 'dirname' && $ValPerl[$i+1] eq '(' && $ValPerl[$i+2] eq '$0') { push @libs, '"' . dirname($Pythonizer::fname) . '"'; $i += 3; } else { logme('W', "use lib $ValPerl[$i]() not handled!"); } } elsif($ValClass[$i] eq 's' && $ValPerl[$i] eq '$FindBin::Bin') { # issue s133 push @libs, ('"' . $dir . '"'); # issue s133 } } say STDERR "For @ValPerl, using @libs (after stripping the '')" if($debug); unshift @UseLib, map {unquote_string($_)} @libs; if($pos == 0) { my $saved_nest = save_nest(); # issue s18 correct_nest(0, 0); # issue s18 gen_statement('sys.path[0:0] = [' . join(',', @libs) . '] # I_M_P_O_R_T'); # issue s18 restore_nest($saved_nest); # issue s18 } else { $Pyf{_add_path} = 1; gen_chunk('_add_path', '([' . join(',', @libs) . ']'); } say STDERR "do_use_require($pos) returns " . ($#ValClass+1) if($debug>=3); return $#ValClass+1; } elsif($pos+4 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'constant') { # use constant NAME => expr; # use constant {NAME => expr, ...}; my $result; if($ValClass[$pos+2] eq 'i' && $ValClass[$pos+3] eq 'A') { replace($pos+3,'=','=','='); $Constants{$ValPy[$pos+2]} = 2; $ValPy[$pos+2] = escape_keywords($ValPy[$pos+2]); $TrStatus=assignment($pos+2); # issue s152 $result = $pos+4; $result = $#ValClass+1; # issue s152 } elsif($ValClass[$pos+2] eq '(') { my $i; for($i = $pos+3; $i <= $#ValClass; $i++) { last if($ValClass[$i] eq ')' && $ValPerl[$i] eq '}'); $Constants{$ValPy[$i]} = 2; $ValPy[$i] = escape_keywords($ValPy[$i]); replace($i+1,'=','=','='); my $comma = next_same_level_token(',', $i+2, $#ValClass); $comma = $#ValClass if($comma < 0); $TrStatus=assignment($i,$comma-1); gen_statement(); $i = $comma; } $result = $i+1; } else { $TrStatus = -255; } say STDERR "do_use_require($pos) returns " . $result if($debug>=3); return $result; # test overload methods } elsif($pos+4 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'overload') { # issue s3 } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'overload') { # issue s3, test overload methods # use overload {'op' => \sub, ...}; # # From the documentation: # Three arguments are passed to all subroutines specified in the use overload directive (with exceptions - see below, # particularly "nomethod"). The first of these is the operand providing the overloaded operator implementation - # in this case, the object whose minus() method is being called. The second argument is the other operand, or # undef in the case of a unary operator. The third argument is set to TRUE if (and only if) the two operands # have been swapped. Perl may do this to ensure that the first argument ($self) is an object implementing the # overloaded operation, in line with general object calling conventions. my $result = scalar(@ValClass); # test overload methods if($pos+4 > $#ValClass) { # test overload methods say STDERR "do_use_require($pos) returns " . $result if($debug>=3); # test overload methods return $result; # test overload methods } # test overload methods if($ValClass[$pos+2] eq '(') { $pos++; } my %overloads = (); # keep track of what they overload my $i; my $p_escaped = escape_keywords($CurPackage, 1); my $fallback = undef; for($i = $pos+2; $i <= $#ValClass; $i++) { last if($ValClass[$i] eq ')' && $ValPerl[$i] eq '}'); my $comma = next_same_level_token(',', $i+2, $#ValClass); if($comma < 0) { $comma = $#ValClass; $comma++ if($ValClass[$comma] ne ')'); } if(($ValClass[$i] ne 'd' && $ValClass[$i] ne '"' && $ValClass[$i] ne 'i') || !exists $OVERLOAD_MAP{$ValPerl[$i]}) { if($ValPerl[$i] eq '++' || $ValPerl[$i] eq '--') { # issue s331 logme('W', "use overload $ValPerl[$i] is not supported - ignored"); # issue s331 } else { # issue s331 logme('S', "use overload $ValPerl[$i] is not supported"); $TrStatus = -255; } } else { my $ovm = $OVERLOAD_MAP{$ValPerl[$i]}; $overloads{$ValPerl[$i]} = dclone($ovm); my $normal = $ovm->{normal}; # For sqrt and friends, only generate code if their routine has a different name $TrStatus = -255 if($ValClass[$comma-1] ne '"' && $ValClass[$comma-1] ne 'i' && $ValClass[$comma-1] ne 'f' && $ValPerl[$i] ne 'fallback'); # issue s331 # issue s331 my $their_routine = escape_keywords($ValPy[$comma-1]); my $their_routine = escape_keywords(unquote_string($ValPy[$comma-1])); # issue s331 $overloads{$ValPerl[$i]}->{theirs} = $their_routine; if($ValPerl[$i] ne 'fallback') { # issue test overload methods gen_statement("setattr($p_escaped, '($ValPerl[$i]', $their_routine)"); # issue test overload methods } my $cs = ''; my $ce = ''; if(exists $ovm->{converter}) { $cs = $ovm->{converter} . '('; $ce = ')'; } if(!defined $normal) { # treat fallback special # issue s331 $fallback = $ValPy[$comma-1] unless($ValPy[$comma-1] eq 'None'); my $unq = unquote_string($ValPy[$comma-1]); # issue s331 $fallback = $unq unless($unq eq 'None'); # issue s331 } elsif($their_routine ne $normal) { $normal = escape_keywords($normal); if(exists $ovm->{unary}) { gen_statement("def $normal(self): # use overload '$ValPerl[$i]'"); } elsif(exists $ovm->{modulo}) { gen_statement("def $normal(self, other, modulo=None): # use overload '$ValPerl[$i]'"); } else { gen_statement("def $normal(self, other): # use overload '$ValPerl[$i]'"); } correct_nest(1,1); if(exists $ovm->{unary}) { gen_statement("return $cs$their_routine(self, None, False)$ce"); } elsif (exists $ovm->{assign}) { gen_statement("return $cs$their_routine(self, other, None)$ce"); } else { gen_statement("return $cs$their_routine(self, other, False)$ce"); } correct_nest(-1,-1); #gen_statement("$p_escaped.$normal = types.MethodType($normal, $p_escaped)"); gen_statement("$p_escaped.$normal = $normal"); } if(exists $ovm->{reversed}) { my $reversed = $ovm->{reversed}; $reversed = escape_keywords($reversed); if(exists $ovm->{modulo}) { gen_statement("def $reversed(self, other, modulo=None): # reversed overload '$ValPerl[$i]'"); } else { gen_statement("def $reversed(self, other): # reversed overload '$ValPerl[$i]'"); } correct_nest(1,1); gen_statement("return $cs$their_routine(self, other, True)$ce"); correct_nest(-1,-1); #gen_statement("$p_escaped.$reversed = types.MethodType($reversed, $p_escaped)"); gen_statement("$p_escaped.$reversed = $reversed"); } } $i = $comma; } #say STDERR Dumper(\%overloads); if((!defined $fallback || $fallback) && (exists $overloads{'<=>'} || exists $overloads{'cmp'})) { # if we have a spaceship or cmp operator overloaded, but no < <= = != >= >, then define those based on that my $cmp; if(exists $overloads{'<=>'}) { $cmp = $overloads{'<=>'}->{theirs}; } else { $cmp = $overloads{'cmp'}->{theirs}; } for my $op ('<', '<=', '==', '!=', '>=', '>') { if(!exists $overloads{$op}) { my $normal = $OVERLOAD_MAP{$op}->{normal}; gen_statement("def $normal(self, other): # extra overload '$op'"); correct_nest(1,1); gen_statement("return $cmp(self, other, False) $op 0"); correct_nest(-1,-1); #gen_statement("$p_escaped.$normal = types.MethodType($normal, $p_escaped)"); gen_statement("$p_escaped.$normal = $normal"); } } } if((!defined $fallback || $fallback) && exists $overloads{'0+'} && !exists $overloads{'<=>'}) { # if we have a to_num operator overloaded (or not if fallback), but no < <= == != >= >, then define those based on that $Pyf{_num} = 1; my $numify = '_num'; for my $op ('<', '<=', '==', '!=', '>=', '>', '+', '-', '*', '/', '%', '**', '&', '|', '^') { if(!exists $overloads{$op}) { my $normal = $OVERLOAD_MAP{$op}->{normal}; gen_statement("def $normal(self, other): # extra overload '$op'"); correct_nest(1,1); gen_chunk('return', $numify, '(self)', $op, $numify, '(other)'); gen_statement(); correct_nest(-1,-1); #gen_statement("$p_escaped.$normal = types.MethodType($normal, $p_escaped)"); gen_statement("$p_escaped.$normal = $normal"); } } } elsif((!defined $fallback || $fallback) && (exists $overloads{'""'} || $fallback) && !exists $overloads{'cmp'}) { # if we have a stringify operator overloaded (or not if fallback), but no lt le eq ne ge gt, then define those based on that my $stringify = 'str'; my %op_map = (lt=>'<', le=>'<=', eq=>'==', ne=>'!=', ge=>'>=', gt=>'>'); for my $op ('lt', 'le', 'eq', 'ne', 'ge', 'gt') { if(!exists $overloads{$op} && !exists $overloads{$op_map{$op}}) { # issue s251: Don't map __eq__ if we already have it for numberic my $normal = $OVERLOAD_MAP{$op}->{normal}; gen_statement("def $normal(self, other): # extra overload '$op'"); correct_nest(1,1); my $nop = $op_map{$op}; gen_statement("return $stringify(self) $nop $stringify(other)"); correct_nest(-1,-1); #gen_statement("$p_escaped.$normal = types.MethodType($normal, $p_escaped)"); gen_statement("$p_escaped.$normal = $normal"); } } } $result = $i+1; $result = $#ValClass if $result > $#ValClass; say STDERR "do_use_require($pos) returns " . $result if($debug>=3); return $result; } elsif($pos+2 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'open') { # use open IN => ':crlf', OUT => ':raw'; # k i i A " , i A " # use open OUT => ':encoding(UTF-8)'; # use open IO => ':crlf'; # use open ':std', ':encoding(UTF-8)'; # use open ':std', OUT => ':encoding(UTF-8)'; # use open ':std', IN => ':encoding(UTF-8)'; # use open ':std', IO => ':encoding(UTF-8)'; # use open qw/:std :encoding(UTF-8)/; # k i q my $do_std = 0; my $scope = 'IO'; my %scope_map = (IO=>['STDIN', 'STDOUT', 'STDERR'], OUT=>['STDOUT', 'STDERR'], IN=>['STDIN']); my $perllib = ($import_perllib ? "perllib." : ""); for(my $i = $pos+2; $i <= $#ValClass; $i++) { if($ValClass[$i] eq 'i') { $scope = $ValPerl[$i]; } elsif($ValClass[$i] eq '"') { if($do_std) { my $tmp_code = package_tokens(); my $perl = $ValPerl[$i]; my $py = $ValPy[$i]; my $todo = $scope_map{$scope}; for my $std (@$todo) { destroy(0, scalar(@ValClass)); append('f', 'binmode', $Perlscan::keyword_tr{binmode}); append('i', $std, $Perlscan::keyword_tr{$std}); append(',',',',','); append('"', $perl, $py); function(0, $#ValClass); gen_statement(); } unpackage_tokens($tmp_code); } if($ValPerl[$i] eq ':std') { $do_std = 1; } elsif($scope eq 'IO') { $Pyf{_handle_open_pragma} = 1; gen_statement("${perllib}INPUT_LAYERS = $ValPy[$i]"); gen_statement("${perllib}OUTPUT_LAYERS = $ValPy[$i]"); } elsif($scope eq 'IN') { $Pyf{_handle_open_pragma} = 1; gen_statement("${perllib}INPUT_LAYERS = $ValPy[$i]"); } else { $Pyf{_handle_open_pragma} = 1; gen_statement("${perllib}OUTPUT_LAYERS = $ValPy[$i]"); } } elsif($ValClass[$i] eq 'q') { my @values = split(' ', $ValPerl[$i]); my $j = $i; destroy($i, 1); for my $value (@values) { append('"', $value, "'$value'"); $j++; } $i--; # Process it again now that we changed it } } say STDERR "do_use_require($pos) returns " . ($#ValClass+1) if($debug>=3); return $#ValClass+1; # } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'Config') { # $Pyf{_init_Config} = 1; # gen_chunk('_init_Config', '()'); # gen_statement(); # add_package_to_mapped_name('%Config', 'Config', 'Config'); # say STDERR "do_use_require($pos) returns " . ($#ValClass+1) if($debug>=3); # return $#ValClass+1; } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'Switch') { # issue s129 # issue s129: We already handled this in PASS_1 (&Perlscan::handle_use_Switch) say STDERR "do_use_require($pos) returns " . ($#ValClass+1) if($debug>=3); # issue s129 return $#ValClass+1; # issue s129 } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq 'i' && $ValPerl[$pos+1] eq 'parent') { # issue s18 my $norequire = 0; for(my $i = 2; $i <= $#ValClass; $i++) { if($ValClass[$i] eq '-') { $norequire = 1; last; } elsif($ValClass[$i] eq '"' && $ValPerl[$i] eq '-norequire') { $norequire = 1; last; } elsif($ValClass[$i] eq 'i' && $ValPerl[$i] eq '-norequire') { $norequire = 1; last; } } unless($norequire) { my $saved_tokens = package_tokens(); destroy(0); insert(0, 'k', 'use', $Perlscan::keyword_tr{use}); insert(1, 'i', '', ''); insert(2, '(', '(', '('); insert(3, ')', ')', ')'); # Don't call import_(...) for(my $i = 2; $i < scalar(@{$saved_tokens->{class}}); $i++) { my $class = $saved_tokens->{class}->[$i]; next if $class eq ',' || $class eq 'A'; if($class eq 'q') { my $perl = $saved_tokens->{perl}->[$i]; $perl =~ s/\s+/ /g; # Change newlines or multiple spaces to single spaces $perl =~ s/^\s+//; # Remove leading spaces $perl =~ s/\s+$//; # Remove trailing spaces foreach $p (split ' ', $perl) { my $python = $p; $python =~ tr/::/./s; $python =~ tr/'/./s; replace(1, 'i', $p, $python); do_use_require(0); } } elsif($class eq '"' && $saved_tokens->{perl}->[$i] =~ /^[A-Za-z0-9:_]+$/) { my $python = $saved_tokens->{perl}->[$i]; $python =~ tr/::/./s; $python =~ tr/'/./s; replace(1, 'i', $saved_tokens->{perl}->[$i], $python); do_use_require(0); # Handle like a require statement } else { replace(1, $saved_tokens->{class}->[$i], $saved_tokens->{perl}->[$i], $saved_tokens->{py}->[$i]); do_use_require(0); # Handle like a require statement } } unpackage_tokens($saved_tokens); } for(my $i = 2; $i <= $#ValClass; $i++) { next if $ValClass[$i] eq ',' || $ValClass[$i] eq 'A'; if($ValClass[$i] eq '-') { $i++; next; } elsif($ValClass[$i] eq '"' && $ValPerl[$i] eq '-norequire') { ; } elsif($ValClass[$i] eq 'i' && $ValPerl[$i] eq '-norequire') { ; } elsif($ValClass[$i] eq 'q') { # We don't expand qw for use statements, so do that here my $python = $ValPerl[$i]; $python =~ s/\s+/ /g; # Change newlines or multiple spaces to single spaces $python =~ s/^\s+//; # Remove leading spaces $python =~ s/\s+$//; # Remove trailing spaces # append_ISA(&Perlscan::escape_quotes($python) . '.split()'); foreach my $p (split ' ', $python) { push_ISA($p); } } else { push_ISA(unquote_string($ValPy[$i])); } } say STDERR "do_use_require($pos) returns " . ($#ValClass+1) if($debug>=3); # issue s18 return $#ValClass+1; # issue s18 } # Ok - now for the real ones my $limit = $#ValClass; my $opp = next_lower_or_equal_precedent_token('F', $pos, $limit); if($opp != -1 && ($ValClass[$opp] eq ',' || $ValClass[$opp] eq 'A')) { # issue s177: We have a list or an '=>' $opp = next_lower_or_equal_precedent_token('n', $pos, $limit); # issue s177: Not much is lower prec than ',' or '=>' } $limit = $opp-1 if($opp >= $pos); my $close = next_same_level_token(')', $pos, $limit); $limit = $close-1 if($close >= $pos); if($pos == $limit) { # require; gen_variable_import_pre(); gen_chunk($DEFAULT_VAR); #gen_variable_import_post("['*']"); gen_variable_import_post(""); } elsif($pos+1 == $limit && $ValClass[$pos+1] eq 's') { # require $x or use $x gen_variable_import_pre(); gen_chunk($ValPy[$pos+1]); if($ValPerl[$pos] eq 'use') { gen_variable_import_post("['*']") } elsif($ValPerl[$pos] eq 'do') { # issue s231 gen_variable_import_post("", 'is_do=True'); # issue s231 } else { gen_variable_import_post(""); } } elsif($pos+1 == $limit && $ValClass[$pos+1] eq '"') { # require "..." if(substr($ValPy[$pos+1],0,1) eq 'f') { # dynamic 'f' string gen_variable_import_pre(); gen_chunk($ValPy[$pos+1]); #gen_variable_import_post("['*']"); if($ValPerl[$pos] eq 'use') { gen_variable_import_post("['*']") } elsif($ValPerl[$pos] eq 'do') { # issue s231 gen_variable_import_post("", 'is_do=True'); # issue s231 } else { gen_variable_import_post(""); } } else { # Static string my ($path, $exports) = import_it($pos); my $has_var_imports = 0; ($has_var_imports, $exports) = filter_exports($exports); undef $exports if($ValPerl[$pos] ne 'use'); # issue s225, issue s231 $path = '' if($path eq '.'); # issue s360 uninitialized value happens here if($path eq $MODULES_DIR || $path eq "./$MODULES_DIR") { if(!$modules_path_added && $pos == 0) { gen_statement("sys.path[0:0] = ['$path']"); $modules_path_added = 1; } $path = ''; } if(substr($ValPy[$pos+1],-4,3) eq '.pl') { substr($ValPy[$pos+1],-2,1) = 'y'; # change to ".py" } #if($path) { #gen_statement("__import__(os.path.join('$path', $ValPy[1]))"); #} else { #gen_statement("__import__($ValPy[1])"); #} my $file = unquote_string($ValPy[$pos+1]); if($pos == 0 && !$path && $file =~ m'^[A-Za-z._][A-Za-z0-9._]*\.py$' && ($CurSub eq '__main__' || !$exports) && escape_keywords($file, 1) eq $file) { # issue 41, issue s269 $file =~ s'\.py$''; if($exports) { gen_statement("from $file import $exports"); } elsif($has_var_imports) { # NOTE: This is always True now! my $underfile = '_' . $file; $underfile =~ s/\./_/g; gen_statement("import $file as $underfile"); } else { gen_statement("import $file"); } gen_A_B_A_fix($file, ''); # issue s360 } else { gen_variable_import_pre(); if($path) { # issue s152 gen_chunk("os.path.join('$path', $ValPy[1])"); gen_chunk("os.path.join('$path', $ValPy[$pos+1])"); # issue s152 } else { # issue s152 gen_chunk($ValPy[1]); gen_chunk($ValPy[$pos+1]); # issue s152 } if($exports) { $exports = '[' . join(', ', map { "'" . $_ . "'" } split(/, /, $exports)) . ']'; } if($ValPerl[$pos] eq 'do') { # issue s231 gen_variable_import_post("", 'is_do=True'); # issue s231 } else { gen_variable_import_post($exports); } } } } elsif($pos+1 <= $limit && $ValClass[$pos+1] eq 'i') { # use/require bare or use/require A::B my $saved_nest; # issue s18 my $suffix = ''; if($ValPerl[$pos] eq 'use' && scalar(@eval_stack) == 0) { # issue s18, issue s350 $saved_nest = save_nest(); # issue s18 correct_nest(0, 0); # issue s18 $suffix = ' # I_M_P_O_R_T'; # issue s18: This special comment is used to move this code up to the top } my ($path, $exports, $has_import_sub) = import_it($pos); # issue s177 my $has_var_imports = 0; ($has_var_imports, $exports) = filter_exports($exports); undef $exports if($ValPerl[$pos] ne 'use'); # issue s225: Don't import anything if they say "require", issue s231 my $inLib = 0; my @places = @UseLib; push @places, @INC; if($path && @places) { for my $lpath (@places) { if($path eq $lpath) { $inLib = 1; last; } } } $path = '' if($inLib); $path = '' if($path eq '.'); # issue s360 uninitialized value happens here if($path eq $MODULES_DIR || $path eq "./$MODULES_DIR") { if(!$modules_path_added && $pos == 0) { gen_statement("sys.path[0:0] = ['$path']$suffix"); # issue s18 $modules_path_added = 1; } $path = ''; } if($pos == 0 && !$path && $ValPy[$pos+1] =~ /^[A-Za-z._][A-Za-z0-9._]*$/ && ($CurSub eq '__main__' || !$exports) && escape_keywords($ValPy[$pos+1], 1) eq $ValPy[$pos+1]) { # issue 41, issue s269 if($exports) { gen_statement("from $ValPy[$pos+1] import ${exports}$suffix"); # issue s18 } elsif($has_var_imports) { # NOTE: This is always True now my $underfile = '_' . $ValPy[$pos+1]; $underfile =~ s/\./_/g; gen_statement("import $ValPy[$pos+1] as ${underfile}$suffix"); # issue s18 } else { gen_statement("import $ValPy[$pos+1]$suffix"); # issue s18 } gen_A_B_A_fix($ValPy[$pos+1], $suffix); # issue s360 } else { my $module = $ValPy[$pos+1]; $module =~ s'\.'/'g; # issue s258 if($exports) { $pexports = $exports ? ('[' . join(', ', map { "'" . $_ . "'" } split(/, /, $exports)) . ']') : undef; # issue s258 # issue s258 } gen_variable_import_pre(); if($path) { gen_chunk("os.path.join('$path', '$module')"); } else { gen_chunk("'$module'"); } # issue s258 gen_variable_import_post($exports); gen_variable_import_post($pexports); # issue s258 gen_chunk($suffix) if $suffix; # issue s18 } if($ValPerl[$pos] eq 'use' && $has_import_sub && !($ValClass[-1] eq ')' && $ValClass[-2] eq '(') # issue s187: if we have like use Module ();, then we DON'T call import! ) { # issue s177 gen_chunk(',') unless $pos == 0; # issue s18: We generate all import code at the outside nesting level because later we move it all to one spot # We also tag it all using # I_M_P_O_R_T so we can find it later (that comment gets removed) if($pos == 0 && $has_import_sub == 1) { # 1 means it may or may not be there (2 means it's definitely there) gen_statement("if hasattr($ValPy[$pos+1], 'import_'):$suffix"); # issue s258: Note: This line is NOT tagged with the suffix as it needs to be after our _init_package call if($exports) { # issue s258 restore_nest($saved_nest); # issue s258 gen_statement("if not hasattr($ValPy[$pos+1], 'import_'):"); # issue s258 correct_nest(0,0); # issue s258 } correct_nest(1,1); } gen_statement(); # issue s269 gen_statement("builtins.__PACKAGE__ = '$CurPackage'$suffix"); # issue s260, issue s244 # issue s269 gen_chunk($ValPy[$pos+1], '.import_('); my $pescaped = escape_keywords($ValPy[$pos+1], 1); # issue s269 gen_chunk($pescaped, '.import_('); # issue s269 gen_chunk("'$ValPy[$pos+1]'"); # Pass the classname, not the class my $start = $pos+2; if($start <= $limit && ($ValClass[$pos+2] eq 'd' || ($ValClass[$pos+2] eq '"' && $ValPerl[$pos+2] =~ /^v\d+\./))) { $start++; # Skip version } for(my $i = $start; $i <= $limit; $i++) { if($ValClass[$i] eq 'A') { $ValPy[$i] = ','; # Change '=>' from ':' to ',' } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '{') { # issue s244f # issue s244f: handle use Class::Struct Car => {make => '$', ...} last; # issue s244f } elsif($ValClass[$i] eq 'q') { my $python = $ValPerl[$i]; $python =~ s/\s+/ /g; # Change newlines or multiple spaces to single spaces $python =~ s/^\s+//; # Remove leading spaces $python =~ s/\s+$//; # Remove trailing spaces $ValPy[$i]=&Perlscan::escape_quotes($python) . '.split()'; } } if($start > $limit) { ; } elsif($ValClass[$start] eq '(') { gen_chunk(','); $TrStatus = expression($start+1, matching_br($start)-1, 2); # insert splats where appropriate } else { gen_chunk(','); $TrStatus = expression($start, $limit, 2); # insert splats where appropriate } gen_chunk(')'); gen_chunk($suffix); # issue s18 if($has_import_sub == 1) { # Not sure it has def import_ if($pos == 0) { gen_statement(); restore_nest($saved_nest); # issue s258 correct_nest(1,1); # issue s258 my @exp = split(/, /, $exports); # issue s258: Assign local names to package names my $p_escaped = escape_keywords($CurPackage, 1); for (@exp) { # issue s258 gen_chunk($p_escaped, '.', $_, '=', $_); # issue s258 gen_statement(); # issue s258 } # issue s258 correct_nest(-1,-1); } else { gen_chunk("if hasattr($ValPy[$pos+1], 'import_') else None$suffix"); # issue s18 } } elsif($pos == 0 && $exports) { # issue s280 gen_statement(); restore_nest($saved_nest); # issue s280 my @exp = split(/, /, $exports); # issue s280: Assign local names to package names my $p_escaped = escape_keywords($CurPackage, 1); for (@exp) { # issue s280 gen_chunk($p_escaped, '.', $_, '=', $_); # issue s280 gen_statement(); # issue s280 } # issue s280 } } elsif($exports) { # issue s258: Assign local names to package names my @exp = split(/, /, $exports); # issue s258 gen_statement(); # issue s258 restore_nest($saved_nest) unless scalar(@eval_stack) != 0; # issue s258, issue s350 my $p_escaped = escape_keywords($CurPackage, 1); for (@exp) { # issue s258 # issue s258: Note: These lines are NOT tagged with the suffix as they need to be after our _init_package call gen_chunk($p_escaped, '.', $_, '=', $_); # issue s258 gen_statement(); # issue s258 } # issue s258 } # issue s258 if($ValPerl[$pos] eq 'use' && scalar(@eval_stack) == 0) { # issue s18, issue s350 gen_statement(); # issue s265 restore_nest($saved_nest); # issue s18 } # issue s18 } elsif($ValPerl[$pos] ne 'use' && $pos+1 <= $limit) { # require expr; issue s231: do expr gen_variable_import_pre(); $TrStatus = expression($pos+1, $limit, 0); #gen_variable_import_post("['*']"); if($ValPerl[$pos] eq 'do') { # issue s231 gen_variable_import_post("", 'is_do=True'); # issue s231 } else { gen_variable_import_post(""); } } else { $TrStatus = -255; } # issue s18: Generate the '_init_package(...)' lines we deferred waiting for the 'use' lines to be generated if($pos+1 <= $#ValClass && ($ValPerl[$pos] eq 'use' || $ValPerl[$pos] eq 'require') && exists $deferred_init_packages{$ValPy[$pos+1]}) { foreach my $defer (@{$deferred_init_packages{$ValPy[$pos+1]}}) { gen_statement($defer); } delete $deferred_init_packages{$ValPy[$pos+1]}; # Only generate them once even if this package is imported again } say STDERR "do_use_require($pos) returns " . ($limit+1) if($debug>=3); return $limit+1; } sub gen_variable_import_pre # Generate the code to do an import where what we're importing isn't constant # Opening code - before the expression { # $Pyf{_prep_import} = 1; # gen_chunk("[$IMPORT_PATH_TEMP, $IMPORT_MODULE_TEMP] = _prep_import("); $Pyf{_import} = 1; gen_chunk('_import', '(globals(), '); } sub gen_variable_import_post # Generate the code to do an import where what we're importing isn't constant # Closing code - after the expression { my $fromlist = shift; my $extra = scalar(@_) ? $_[0] : ''; #gen_chunk(')'); #gen_statement(); #gen_statement("sys.path.insert(0, $IMPORT_PATH_TEMP)"); if($extra) { gen_chunk(", $extra"); } if($fromlist) { gen_chunk(", fromlist=$fromlist)"); } else { gen_chunk(')'); } #gen_statement("sys.path.pop(0)"); } sub import_it # Part of handling a 'use', 'require', or 'do EXPR' statements - look for the source of the modules, # translate it to python if need be, and do an optional version check and check what we should import. # Returns a list of 3 elements: the path where we import from, the list of what to import, and a flag if the module has a 'sub import' defined. # ValClass[$pos] will tell us if this is a require or use statement # ValClass[$pos+1]/ValPy[$pos+1] is what to import { my $pos = shift; local $.; my $file; my $filepy; my @places = @UseLib; push @places, @INC; if($ValClass[$pos+1] eq '"') { # require '...' - at this point this is at least a constant string! $file = unquote_string($ValPy[$pos+1]); return ('', '', 0) if($file !~ /[A-Za-z0-9_.-]/); # Not a good filename $filepy = $file; $filepy =~ s/\.pl$/.py/; $file =~ s/\.py$/.pl/; # issue s231: &Perlscan::replace_run may have changed it from .pl to .py } elsif($ValClass[$pos+1] eq 'i') { # issue s231 $file = $ValPy[$pos+1]; return ('', '', 0) if($file !~ /[A-Za-z0-9_.]/); # Not a good filename $file =~ s([.])(/)g; $filepy = $file . '.py'; $file .= '.pm'; } # require VERSION # require EXPR # require (uses $_ as EXPR) # # use Module VERSION LIST # use Module VERSION # use Module LIST # use Module # use VERSION my ($desired_version, @desired_imports); for(my $i = $pos+2; $i <= $#ValClass; $i++) { # See what we have next if(($ValClass[$i] eq 'i' || $ValClass[$i] eq '"') && $ValPerl[$i] =~ /^v\d/) { $desired_version .= $ValPerl[$i]; } elsif($ValClass[$i] eq 'd') { $desired_version .= $ValPerl[$i]; } elsif($ValClass[$i] eq '"') { push @desired_imports, $ValPerl[$i]; } elsif($ValClass[$i] eq 'q') { # qw if(index(q('"), substr($ValPy[$i],0,1)) >= 0) { push @desired_imports, unquote_string($ValPy[$i]); } else { push @desired_imports, split(' ', $ValPy[$i]); # qw(...) on use stmt doesn't generate the split } } } $desired_version = substr($desired_version,1) if($desired_version && substr($desired_version,0,1) eq 'v'); my %found_map = (); my $version = undef; my $path; my $fullfile = $file; my $fullpy = $filepy; if(file_name_is_absolute($file)) { $path = dirname($file); } else { for my $place (@places) { $fullfile = catfile($place, $file); if(-f $fullfile) { $path = $place; $fullpy = catfile($place, $filepy); last; } else { $fullfile = $file; $path = '.'; # issue s360 } } } my $stat = 0; if(! -f $fullfile) { # Can't find it my ($fmap, $extras, $version) = expand_extras(\@desired_imports, $fullfile); my @py_export = map { import_perl_to_python($fmap, $_) } @{$extras}; return ('', join(', ', @py_export), 0) } my $rerun_flags = ''; # issue names # issue names: if we need to run it with -Rname,..., to remap names, check if that's already there, and if # not, we have to do a rerun if(exists $UseRequireOptionsDesired{$fullfile}) { if(exists $UseRequireOptionsPassed{$fullfile}) { if(index($UseRequireOptionsPassed{$fullfile}, $UseRequireOptionsDesired{$fullfile}) == -1) { # check if same or superset of -R option $rerun_flags = ' ' . $UseRequireOptionsDesired{$fullfile}; } } else { $rerun_flags = ' ' . $UseRequireOptionsDesired{$fullfile}; } } if(! -f $fullpy) { # See if this package is part of our own standard library (perllib and friends) $package_dir = dirname(__FILE__); for my $fp2 (catfile($package_dir, $filepy), catfile($package_dir, $filepy =~ s'.py$'/__init__.py'r)) { if(-f $fp2) { $fullpy = $fp2; say STDERR "Found $filepy at $fullpy" if($debug); last; } } } if((! -f $fullpy) || (-M $fullpy >= -M $fullfile) || $rerun_flags) { # Copy the perl file to a new "Modules" folder in the same location as our source file if we can't write in # the directory where it lives now. my $dir = dirname($fullfile); my $canwrite = 1; for my $d (@STANDARD_LIBRARY_DIRS) { if($dir =~ /$d/) { $canwrite = 0; last; } } $canwrite = open(TMPF, '>', "$dir/pythonizer.tmp") if($canwrite); if($canwrite) { close(TMPF); unlink "$dir/pythonizer.tmp"; } elsif($pythonize_standard_library) { my $srcdir = dirname($Pythonizer::fname); #if($MODULES_DIR ne substr($srcdir, -length($MODULES_DIR))) { if(index($srcdir, $MODULES_DIR) < 0) { # Append the Modules dir if it's not already there $srcdir = dirname($Pythonizer::fname) . "/$MODULES_DIR"; mkdir $srcdir; } $fullpy = $srcdir . '/' . basename($fullpy); $path = $srcdir; my $mdx = index($srcdir, $MODULES_DIR); $mdx += length($MODULES_DIR); substr($srcdir,$mdx) = ''; # Remove anything past the PyModules dir # Use a subdir if they user said something like "use A::B;", which at this # point means there are one or more '/' in $file: if(index($file, '/') >= 0) { my @subdirs = split m'/', $file; pop @subdirs; # Eat the last one for my $subd (@subdirs) { mkdir "$srcdir/$subd"; $srcdir .= "/$subd"; } $fullpy = $srcdir . '/' . basename($fullpy); } if((! -f $fullpy) || (-M $fullpy >= -M $fullfile)) { say STDERR "-M $fullpy=". (-M $fullpy) . ", -M $fullfile=". (-M $fullfile) if($debug); say STDERR "Copying $fullfile to writable $srcdir/"; `cp -p "$fullfile" "$srcdir"/`; $fullfile = $srcdir . '/' . basename($fullfile); $fullpy = $srcdir . '/' . basename($fullpy); } } if(!$canwrite && !$pythonize_standard_library) { logme('W', "Skipped translating $fullfile to python for use in $ValPerl[$pos] $ValPerl[$pos+1] (use '-s' option to translate it (not recommended))"); my ($fmap, $extras, $version, $has_import_sub) = expand_extras(\@desired_imports, $fullfile); my @py_export = map { import_perl_to_python($fmap, $_) } @{$extras}; import_version_check($desired_version, $version, $pos, $fullfile); return ($path, join(', ', @py_export), $has_import_sub) } if(((! -f $fullpy) || (-M $fullpy >= -M $fullfile) || $rerun_flags) && lock_it($fullpy)){ say STDERR "-M $fullpy=". (-M $fullpy) . ", -M $fullfile=". (-M $fullfile) if($debug); my $subprocess_options = $SUBPROCESS_OPTIONS; $subprocess_options .= ' -P' if(!$import_perllib); $subprocess_options .= ' -s' if($pythonize_standard_library); $subprocess_options .= ' -a' if($gen_author); $subprocess_options .= " -o$output_dir" if($output_dir && $canwrite); # issue s23 $subprocess_options .= $rerun_flags; say STDERR "Running $0 $subprocess_options $fullfile for $ValPerl[$pos] $ValPerl[$pos+1]"; my $interpreter=$^X . ' '; # issue bootstrap if($interpreter =~ /perl/) { # issue bootstrap $interpreter = '' # issue bootstrap } $stat = system "$interpreter$0 $subprocess_options $fullfile"; if($stat) { say STDERR "ERROR running $0 $fullfile for $ValPerl[$pos] $ValPerl[$pos+1]"; } else { say STDERR "Success running $0 $fullfile for $ValPerl[$pos] $ValPerl[$pos+1]"; } my @remaps = unlock_it($fullpy); # for my $remap (@remaps) { # chomp $remap; # say STDERR "remap from $fullpy lockfile: $remap" if($debug); # if($remap =~ m'([@$%*]?)([\w.]+)[.](\w+)=>(\w+)$') { # if(exists $Packages{$2}) { # say STDERR " remap_conflicting_names($3, '&', '')" if($debug); # &Perlscan::remap_conflicting_names($3, '&', ''); # Remap all other names # if($1 ne '') { # say STDERR " remap_conflicting_names($3, $1, '')" if($debug); # &Perlscan::remap_conflicting_names($3, $1, ''); # Remap this name # } # } else { # say STDERR " skipping (not our package: $2)" if($debug); # } # } # } } } if($stat) { logme('W', "$0 failed to translate $fullfile to python for use in $ValPerl[$pos] $ValPerl[$pos+1]!"); my ($fmap, $extras, $version, $has_import_sub) = expand_extras(\@desired_imports, $fullfile); my @py_export = map { import_perl_to_python($fmap, $_) } @{$extras}; import_version_check($desired_version, $version, $pos, $fullfile); return ($path, join(', ', @py_export), $has_import_sub) } # Read in the python file to decide what things to import my ($fmap, $extras, $has_import_sub); ($fmap, $extras, $version, $has_import_sub) = expand_extras(\@desired_imports, $fullfile); # Read the code and gather the import and version information if(!open(PYTHON, '<', $fullpy)) { import_version_check($desired_version, $version, $pos, $fullfile); logme('W', "Could not open $fullpy for use in $ValPerl[$pos] statement!"); my @py_export = map { import_perl_to_python($fmap, $_) } @{$extras}; return ($path, join(', ', @py_export), $has_import_sub) } %found_map = %{$fmap}; # Start with what we gleaned from the perl code %actual_imports = map { $_ => 1 } @{$extras}; # Get it from the perl code my $base_pattern = '[A-Za-z_][A-Za-z0-9_]*'; my $package_name_pattern = '\b(?:[A-Za-z][A-Za-z0-9_]*[.])+'; my @sigil_patterns = ('$',$package_name_pattern.scalar_var_name($base_pattern).'\b', '@',$package_name_pattern.array_var_name($base_pattern).'\b', '%',$package_name_pattern.hash_var_name($base_pattern).'\b', '',$package_name_pattern.$base_pattern.'\b'); #my (@export, @export_ok, %export_tags, @can_export_classes, @can_export_defs, @can_export_vars, @can_export_packages); my (@can_export_classes, @can_export_defs, @can_export_vars, @can_export_packages); my $found_actual_import_sub = -1; # issue s177 my $cursub; # issue s184 my $package = 'main'; # issue s184 while() { # We now pull these from the perl version because they could be computed and expand_extras # actually runs the perl code to compute them. # if(/EXPORT = '([^']*)'\.split()/) { # issue 44: we changed the quotes # @export = split(' ', $1); # } elsif(/EXPORT_OK = '([^']*)'\.split()/) { # issue 44 # @export_ok = split(' ', $1); # } elsif(/EXPORT_TAGS = (?:(?:$PERLLIB\.)?Hash\()?\{/) { # while(/'([^']*)': '([^']*)'\.split()/g) { # issue 44, issue 127 - we removed the '['...']' # my @items = split(' ', $2); # $export_tags{$1} = \@items; # } # } elsif(/VERSION = (.*)$/) { # $version = $1; # my $c; # if(($c = substr($version,0,1)) eq '"' || $c eq "'") { # $version = unquote_string($version); # } # } elsif(/^class ([A-Za-z][A-Za-z0-9_]*)/) { # push @can_export_classes, $1; # } elsif(/^def ([A-Za-z][A-Za-z0-9_]*)/) { # push @can_export_defs, $1; # } elsif(/^(?:[A-Za-z][A-Za-z0-9_]*[.])+([A-Za-z][A-Za-z0-9_]*) = /) { # push @can_export_vars, $1; # } elsif(/init_package\('([\w.]+)'\)/) { # push @can_export_packages, $1; # } if(/^$PERLLIB\.init_package\(['"](.*)['"][,)]/ || /^_init_package\(['"](.*)['"][,)]/) { # issue s184 # We have to do this before eat_strings, else the package name is GONE! $package = $1; # issue s184 } # issue s184 my $comments = $_; # issue s185 $comments =~ s/^.*#/#/; # issue s185 my $line = &Pythonizer::eat_strings($_); # Skip assignments of sub names to their packages like "ExportVars.get_xvar = get_xvar": next if($line =~ /^(?:[A-Za-z][A-Za-z0-9_]*[.])+([A-Za-z][A-Za-z0-9_]*) = ([A-Za-z][A-Za-z0-9_]*)/ && $1 eq $2); next if($line =~ /^\s*#/); # comment line if($line =~ /^def ([A-Za-z_][A-Za-z0-9_]*)\(/) { # issue s184 $cursub = $1; # issue s184 } elsif($line =~ /^[^\s]/) { # issue s184 $cursub = undef; # issue s184 } # issue s184 if($cursub) { # issue s184 my @outs = (); # issue s184 if ($line =~ /\b$PERLLIB\.init_out_parameters\($PERL_ARG_ARRAY\)/ || $line =~ /\b_init_out_parameters\($PERL_ARG_ARRAY\)/) { # issue s184 push @outs, 'var'; # issue s184 } elsif ($line =~ /\b$PERLLIB\.init_out_parameters\($PERL_ARG_ARRAY, ([^)]*)\)/ || $line =~ /\b_init_out_parameters\($PERL_ARG_ARRAY, ([^)]*)\)/) { # issue s184 @outs = split /, /, $1; # issue s184 if($comments =~ /# refs: (.*)$/) { # issue s185 @refs = split /, /, $1; # issue s185 for my $ref (@refs) { # issue s185 for(my $i = 0; $i < scalar(@outs); $i++) { # issue s185 $outs[$i] .= 'r' if($outs[$i] =~ /^\d+$/ && $outs[$i] == $ref); # issue s185 } # issue s185 } # issue s185 } # issue s185 } # issue s184 if(@outs != 0) { # issue s184 my $outs_c = dclone(\@outs); # issue s184 $SubAttributes{'->' . $cursub}{out_parameters} = $outs_c; # issue s184 say STDERR "Setting out_parameters for ->$cursub to @$outs_c based on actual call to _init_out_parameter in the python code" if($debug); $SubAttributes{$package . '.' . $cursub}{out_parameters} = $outs_c; # issue s184 say STDERR "Setting out_parameters for $package.$cursub to @$outs_c based on actual call to _init_out_parameter in the python code" if($debug); if(exists $actual_imports{$cursub}) { $SubAttributes{$cursub}{out_parameters} = $outs_c; # issue s184 say STDERR "Setting out_parameters for $cursub to @$outs_c based on actual call to _init_out_parameter in the python code" if($debug); $SubAttributes{$CurPackage . '.' . $cursub}{out_parameters} = $outs_c; # issue s184 say STDERR "Setting out_parameters for $CurPackage.$cursub to @$outs_c based on actual call to _init_out_parameter in the python code" if($debug); } } } $found_actual_import_sub = 1 if($line =~ /^def import_\(/); # issue s177 for(my $j=0; $j < scalar(@sigil_patterns); $j+=2) { my $sig = $sigil_patterns[$j]; my $pat = $sigil_patterns[$j+1]; if($line =~ /($pat)/) { my $full_name = $1; my $last_dot = rindex($full_name, '.'); my $package_name = substr($full_name,0,$last_dot); my $python_name = substr($full_name,$last_dot+1); if($sig eq '') { my $perl_basename = $python_name; if(substr($python_name,-1,1) eq '_') { my $without_escape = substr($python_name,0,length($python_name)-1); my $esc = escape_keywords($without_escape); $perl_basename = $without_escape if($esc eq $python_name); } for $sig ('$', '@', '%') { my $perl_name = $sig . $perl_basename; $found_map{$perl_name} = escape_keywords($package_name, 1) . '.' . $python_name; #add_package_to_mapped_name($perl_name, $package_name, $python_name); } } else { my $perl_name = $sig . substr($python_name,0,length($python_name)-2); $found_map{$perl_name} = escape_keywords($package_name, 1) . '.' . $python_name; #add_package_to_mapped_name($perl_name, $package_name, $python_name); # # FIXME: If we already generated code that includes any of these names, then # the remap is too late! Plus we are mistaking a reference to main.glob to be a sub ref. # One idea is to always remap using var_v, arr_a, and hash_h unless -m option. if(exists $Packages{$package_name}) { # He mapped one of ours - make it consistent my $pyname = substr($perl_name, 1); say STDERR "remap_conflicting_names($pyname, '&', '')" if($debug); &Perlscan::remap_conflicting_names($pyname, '&', ''); # Remap all other names say STDERR "remap_conflicting_names($pyname, $sig, '')" if($debug); &Perlscan::remap_conflicting_names($pyname, $sig, ''); # Remap this name } } } } } close(PYTHON); if($debug) { $Data::Dumper::Indent=0; $Data::Dumper::Terse = 1; no warnings 'uninitialized'; #say STDERR "For $fullpy, EXPORT=@export, EXPORT_OK=@export_ok, EXPORT_TAGS=" . #Dumper(\%export_tags) . say STDERR "For $fullpy, found_map=@{[%found_map]}, can_export_classes=@can_export_classes, can_export_defs=@can_export_defs, can_export_vars=@can_export_vars, can_export_packages=@can_export_packages, found_actual_import_sub=$found_actual_import_sub" if($debug); } $has_import_sub += $found_actual_import_sub if $has_import_sub; # issue s177: 2 means we know we can call it, else it gets set to 0 and turned off #$version = substr($version,1) if($version && substr($version,0,1) eq 'v'); import_version_check($desired_version, $version, $pos, $fullfile); # if(!@desired_imports) { # if($ValClass[-1] eq ')' && $ValClass[-2] eq '(') { # like use Module (); # say STDERR "For @ValPerl, return ($path, undef)" if($debug); # return ($path, ''); # Import nothing # } # if(@export) { # my @py_export = map { import_perl_to_python(\%found_map, $_) } @export; # say STDERR "For @ValPerl, return ($path, " . join(', ', @py_export) . ")" if($debug); # return ($path, join(', ', @py_export)); # } else { # We have no declared exports # #for my $can (@can_export_defs) { # #$can = substr($can,0,length($can)-1) if(substr($can,-1,1) eq '_'); # Remove potential escape # #if(exists $PotentialSub{$can}) { # #say STDERR "import_it setting LocalSub{$can} = 3" if($debug >= 3); # #$LocalSub{$can} = 3; # Just suppress the message # #} # #} # #return ($path, '*'); # return ($path, ''); # Import nothing # } # } # # [!]name This name only # # [!]:DEFAULT All names in @EXPORT # # [!]:tag All names in $EXPORT_TAGS{tag} anonymous array # # [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match # my %actual_imports; # for my $desired (@desired_imports) { # my $ch = substr($desired,0,1); # if($ch eq '!') { # if($desired eq $desired_imports[0]) { # First one # #push @actual_imports, @export; # for my $e (@export) { # $actual_imports{$e} = 1; # } # } # my $ch2 = substr($desired,1,1); # if($ch2 eq ':') { # $tag = substr($desired,2); # if(exists $export_tags{$tag}) { # for my $e (@{$export_tags{$tag}}) { # delete $actual_imports{$e}; # } # } # } elsif($ch2 eq '/') { # $pat = substr($desired, 2); # substr($pat,-1,1) = ''; # Remove trailing '/' # for my $e (@export, @export_ok) { # if($e =~ /$pat/) { # delete $actual_imports{$e}; # } # } # } else { # delete $actual_imports{substr($desired,1)}; # } # } elsif($ch eq ':') { # $tag = substr($desired,1); # if(exists $export_tags{$tag}) { # for my $e (@{$export_tags{$tag}}) { # $actual_imports{$e} = 1; # } # } elsif($tag eq 'DEFAULT') { # for my $e (@export) { # $actual_imports{$e} = 1; # } # } # } elsif($ch eq '/') { # $pat = substr($desired, 1); # substr($pat,-1,1) = ''; # Remove trailing '/' # for my $e (@export, @export_ok) { # if($e =~ /$pat/) { # $actual_imports{$e} = 1; # } # } # } else { # $actual_imports{$desired} = 1; # } # } my @py_export = map { import_perl_to_python(\%found_map, $_) } keys %actual_imports; say STDERR "For @ValPerl, return ($path, " . join(', ', @py_export) . ", $has_import_sub)" if($debug); return ($path, join(', ', @py_export), $has_import_sub); } sub import_version_check { my ($desired_version, $version, $pos, $fullfile) = @_; if($desired_version && $version) { if($desired_version > $version) { local $.; $. = $Perlscan::statement_starting_lno; logme('S', "For $ValPerl[$pos] $ValPerl[$pos+1], desired version $desired_version > actual version $version at $fullfile"); } } } sub filter_exports # Process the exports and only keep the ones that are subs (they don't have a package name) # For the ones with a package name, we already added that to references of those variables. # issue s3: While we're walking thru them also mark them as subs so we don't suppress mapping functions if # they have the same name, and also remap anything we have that may conflict with these names. # Usage: #($has_var_imports, $exports) = filter_exports($exports); { my $exports = shift; # string sep by ', ' my @result = (); # issue s127 my @arr_exports = split /, /, $exports; my @arr_exports = sort(split /, /, $exports); # issue s127 my $has_var_imports = 0; for my $export (@arr_exports) { if(index($export, '.') < 0) { $Pythonizer::UseSub{$export} = 2; # issue s3 &Perlscan::remap_conflicting_names($export, '&', ''); # issue s3 push @result, $export; } else { $has_var_imports = 1; } } $has_var_imports = 1; # Works better this way (see test_export_vars2.pl) return ($has_var_imports, join(', ', @result)); } sub expand_extras # Given a list of desired exports, work with the perl file to expand it to the full list (if possible) # Returns a hashref of perl names to python fully qualified names plus a listref of actual imports and a flag if the module has a 'sub import' defined # NOTE: this is also called in pass 1 by &Perlscan::handle_import { my $desired_imports = shift; my $fullfile = shift; my @result = (); my @export = (); my @export_ok = (); my %export_tags = (); my %out_parameters = (); # issue s184 my @export_fail = (); # Not currently implemented my $has_export_fail_sub = 0; # Not currently implemented my @global_vars = (); my @overloads = (); # issue s3 my @wantarrays = (); # issue s3 my @specialvarsused = (); # issue s282 my $version = undef; my $package = undef; my %default_map = (); # Default mapping of perl names to python fully qualified names my $errors = ''; my @blesses = (); # issue s236 # eval { # no warnings; # local $SIG{__WARN__} = sub { }; # require $fullfile; # open(SRC, '<', $fullfile); # while() { # if(/\bpackage\s+(.*);/) { # $package = $1; # last; # } # } # return if(!defined $package); # This is just a return from the 'eval', not a real sub return!! # my %pkh = %{"${package}::"}; # #say STDERR keys %pkh; # @export = @{$pkh{EXPORT}} if exists($pkh{EXPORT}); # @export_ok = @{$pkh{EXPORT_OK}} if exists($pkh{EXPORT_OK}); # %export_tags = %{$pkh{EXPORT_TAGS}} if exists($pkh{EXPORT_TAGS}); # $version = ${$pkh{VERSION}} if exists($pkh{VERSION}); # say STDERR "expand_extras: package=$package, version=$version, export=@export, export_ok=@export_ok, export_tags=@{[%export_tags]}" if($debug); # }; my $dir = dirname(__FILE__); my $absfile = $fullfile; $absfile = rel2abs($fullfile) if -f $fullfile; say STDERR "`perl $dir/pythonizer_importer.pl \"$absfile\"`" if($debug); @export_info = `perl $dir/pythonizer_importer.pl \"$absfile\"`; # The eval below works great until we bootstrap and then it falls right apart (python trying to interpret perl defs) # Basically each line is an assignment, and we have to parse them and "manually" do the right thing if we're running in python # The lines look like: # $package='package_name'; # $version='version_string'; (or undef;) # @export=qw/export things/; (or ();) # @export_ok=qw/export ok things/; (or ();) # %export_tags=(key => [qw/tag tag/], ...); (or ();) # $has_export_fail_sub=1; (or 0;) # @global_vars=qw/var var/; (or ();) # -or- # $@="Failed: message"; $py = ($0 =~ /\.py$/); $package='main'; if($py) { $version=undef; @export=@export_ok=@global_vars=(); @overloads=(); # issue s3 @wantarrays = (); # issue s3 %export_tags=(); %out_parameters=(); # issue s184 @specialvarsused = (); # issue s282 # issue s236 $blesses = ''; # issue s18 @blesses = (); # issue s18, issue s236 for my $e (@export_info) { if($e =~ m'^\$package=\'(.*)\';$') { $package = $1; } elsif($e =~ m'^\$version=\'(.*)\';$') { $version = $1; } elsif($e =~ m'^@export=qw/(.*)/;$') { @export = split ' ', $1; } elsif($e =~ m'^@export_ok=qw/(.*)/;$') { @export_ok = split ' ', $1; } elsif($e =~ m'^%export_tags=\((.*)\);$') { %export_tags = parse_export_tags($1); } elsif($e =~ m'^%out_parameters=\((.*)\);$') { # issue s184 %out_parameters = parse_export_tags($1); # issue s184 # issue s236 } elsif($e =~ m'^\$blesses=\'(.*)\';$') { # issue s18 # issue s236 $blesses = $1; # issue s18 } elsif($e =~ m'^@blesses=qw/(.*)/;$') { # issue s236 @blesses = split ' ', $1; # issue s236 } elsif($e =~ m'^@export_fail=qw/(.*)/;$') { @export_fail = split ' ', $1; } elsif($e =~ m'^\$has_export_fail_sub=(.);$') { $has_export_fail_sub = $1; } elsif($e =~ m'^@specialvarsused=qw=(.*)=;$') { # issue s282 @specialvarsused = split ' ', $1; # issue s282 } elsif($e =~ m'^@global_vars=qw/(.*)/;$') { @global_vars = split ' ', $1; } elsif($e =~ m'^@overloads=qw\'(.*)\';$') { # issue s3 @overloads = split ' ', $1; # issue s3 } elsif($e =~ m'^@wantarrays=qw/(.*)/;$') { # issue s3 @wantarrays = split ' ', $1; # issue s3 } elsif($e =~ m'^\$errors="(.*)";$') { $errors = $1; } } } else { for my $e (@export_info) { eval $e; } } { no warnings 'uninitialized'; say STDERR "expand_extras: package=$package, version=$version, export=@export, export_ok=@export_ok, export_tags=" . Dumper(\%export_tags) . ", out_parameters=" . Dumper(\%out_parameters) . ", blesses=@blesses, wantarrays=@wantarrays" if($debug); } say STDERR "expand_extras: $errors" if($errors && $debug); # issue s236 if($blesses && $package) { # issue s18 if(scalar(@blesses) && $package) { # issue s18 my $p = $package; $p =~ tr/::/./s; $p =~ tr/'/./; $SpecialVarsUsed{'bless'}{$p} = 1; } for my $sv (@specialvarsused) { # issue s282 $SpecialVarsUsed{$sv}{$package} = 1; # issue s282 } # issue s282 my $message = ''; my $gen_message = 0; # Can't locate Cisco/SNMP.pm in @INC (you may need to install the Cisco::SNMP module) if($errors =~ /you may need to install the (.*?) module/) { $message = "Module $1 not found in \@INC: Can't process"; } my %potential_imports = map { $_ => 1 } (@export, @export_ok); for my $tag (keys %export_tags) { %potential_imports = (%potential_imports, map { $_ => 1 } @{$export_tags{$tag}}); } # [!]name This name only # [!]:DEFAULT All names in @EXPORT # [!]:tag All names in $EXPORT_TAGS{tag} anonymous array # [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match my %actual_imports; my $default_added = 0; if(!@{$desired_imports}) { if($ValClass[-1] eq ')' && $ValClass[-2] eq '(') { # like use Module (); ; # import nothing } else { push @{$desired_imports}, ':DEFAULT'; $default_added = 1; } } # issue s164 for my $desired (@{$desired_imports}) { my @pending_imports = @{$desired_imports}; # issue s164 while(my $desired = shift(@pending_imports)) { # issue s164 my $ch = substr($desired,0,1); if($ch eq '!') { if($message) { $message .= " $desired"; $gen_message = 1; } if($desired eq $desired_imports->[0]) { # First one for my $e (@export) { $actual_imports{$e} = 1; } } my $ch2 = substr($desired,1,1); if($ch2 eq ':') { my $tag = substr($desired,2); if(exists $export_tags{$tag}) { for my $e (@{$export_tags{$tag}}) { delete $actual_imports{$e}; } } } elsif($ch2 eq '/') { $pat = substr($desired, 2); substr($pat,-1,1) = ''; # Remove trailing '/' for my $e (@export, @export_ok) { if($e =~ /$pat/) { delete $actual_imports{$e}; } } } else { delete $actual_imports{substr($desired,1)}; } } elsif($ch eq ':') { if($message) { $message .= " $desired" unless($default_added); $gen_message = 1; } my $tag = substr($desired,1); if(exists $export_tags{$tag}) { for my $e (@{$export_tags{$tag}}) { if(substr($e,0,1) eq ':') { # issue s164 push @pending_imports, $e; # issue s164 } else { # issue s164 $actual_imports{$e} = 1; } } } elsif($tag eq 'DEFAULT') { for my $e (@export) { $actual_imports{$e} = 1; } } } elsif($ch eq '/') { if($message) { $message .= " $desired"; $gen_message = 1; } $pat = substr($desired, 1); substr($pat,-1,1) = ''; # Remove trailing '/' for my $e (@export, @export_ok) { if($e =~ /$pat/) { $actual_imports{$e} = 1; } } } elsif($ch eq '-' || $desired !~ /^[A-Za-z_][A-Za-z0-9_]*$/) { # issue s164, issue s18 ; # issue s177 logme('W', "Import $desired not handled (ignored)"); # issue s164 } else { # issue s244e: Make sure what we want to import actually exists and isn't just a special # parameter to the class (like for Class:Struct): my $glb = $desired; # issue s244e $glb = ('&' . $glb) if $desired =~ /^[A-Za-z_]/; # issue s244e: No sigil? Make it a &sub if(grep { $_ eq $glb } @global_vars) { # issue s244e $actual_imports{$desired} = 1; } else { # test_Time_HiRes: If this is a predefined function, define it for the imported name my $fullname = $package . '::' . $desired; if(exists $Perlscan::keyword_tr{$fullname}) { $Perlscan::keyword_tr{$desired} = $Perlscan::keyword_tr{$fullname}; $Perlscan::TokenType{$desired} = 'f'; # promote it from 'F' (weak function) say STDERR "Importing method $fullname as $desired, mapped to $Perlscan::keyword_tr{$desired}" if $debug >= 3; } } # issue s244e } } logme('W', $message) if($gen_message && $Pythonizer::PassNo==&Pythonizer::PASS_2); # issue s3: for overloads, import the ones that python doesn't handle even if we don't explicitly import them for my $o (@overloads) { # issue s3 if(exists $OVERLOAD_MAP{$o} && $OVERLOAD_MAP{$o}->{normal} eq $o) { # if we map it to the same name (like 'exp'), then import it $actual_imports{$o} = 2; } # issue s236: This array now contains both the overloaded operators and the functions they map to # e.g. =, Math::Complex::_copy if($o =~ /^([A-Za-z0-9_:]+::)([A-Za-z0-9_]+)$/) { # issue s236: Package::subname $o =~ tr/:/./s; # issue s236 $SubAttributes{$o}{overloads} = 2; # issue s236 $SubAttributes{'->' . $2}{overloads} = 2; # issue s236 $SubAttributes{$2}{overloads} = 2 if(exists $actual_imports{'&'.$2} || exists $actual_imports{$2}); # issue s236 } # issue s236 } if(defined $package) { $package =~ tr/:/./s; # issue s184 $package =~ tr/'/./s; # issue s184 } if($Pythonizer::PassNo==&Pythonizer::PASS_1) { # issue s184: Don't step on local definitions if they have conflicting names for my $w (@wantarrays) { # issue s3 $SubAttributes{$w}{wantarray} = 2 if(exists $actual_imports{'&'.$w} || exists $actual_imports{$w}); # issue s236 $SubAttributes{'->' . $w}{wantarray} = 2; # issue s184: Fixed this too $SubAttributes{$package . '.' . $w}{wantarray} = 2; # issue s184 } for my $w (@blesses) { # issue s236 $SubAttributes{$w}{blesses} = 2 if(exists $actual_imports{'&'.$w} || exists $actual_imports{$w}); # issue s236 $SubAttributes{'->' . $w}{blesses} = 2; # issue s236 $SubAttributes{$package . '.' . $w}{blesses} = 2; # issue s236 } for my $w (keys %out_parameters) { # issue s184 $SubAttributes{'->' . $w}{out_parameters} = $out_parameters{$w}; # issue s184 $SubAttributes{$package . '.' . $w}{out_parameters} = $out_parameters{$w}; # issue s184 if(exists $actual_imports{'&'.$w} || exists $actual_imports{$w}) { # issue s236 $SubAttributes{$w}{out_parameters} = $out_parameters{$w}; # issue s184 } } # issue s184 if(!defined $package || $package eq 'main') { # issue s186: Mark any defined subs as part of the main package so we don't generate warnings when calling them foreach my $perl_name (@global_vars) { my $sig = substr($perl_name,0,1); if($sig eq '&') { my $py_name = escape_keywords(substr($perl_name,1)); $LocalSub{'main'.'.'.$py_name} = 2; # Imported } } } } @result = keys %actual_imports; for my $perl_name (@result) { my $sig = substr($perl_name,0,1); my $basename = substr($perl_name,1); if(index('@$%', $sig) >= 0) { # remap any conflicts - we now assume everything gets mapped because -R:global is now the default $basename = mapped_name($basename, $sig, ''); # if($sig eq '$' && exists $potential_imports{$basename}) { # $basename = scalar_var_name($basename); # } elsif($sig eq '@') { # for my $s ('', '&', '$', '%') { # if(exists $potential_imports{$s.$basename}) { # $basename = array_var_name($basename); # last; # } # } # } elsif($sig eq '%') { # for my $s ('', '&', '$', '@') { # if(exists $potential_imports{$s.$basename}) { # $basename = hash_var_name($basename); # last; # } # } # } } elsif($sig ne '&' && $sig ne '*') { $basename = $sig . $basename; $sig = ''; } my $python_name = escape_keywords($basename); if(index('@$%', $sig) >= 0) { #add_package_to_mapped_name($perl_name, $package, $python_name); if(defined $package) { $python_name = escape_keywords($package, 1) . '.' . $python_name; } } $default_map{$perl_name} = $python_name; } my $has_import_sub = 0; # issue s177 if(grep { $_ eq '&import' } @global_vars) { # issue s177 $has_import_sub = 1; # issue s177 } # issue s177 say STDERR "expand_extras(@{$desired_imports}, $fullfile) = (@{[%default_map]}, " . join(' ', keys %actual_imports) . ", $has_import_sub)" if($debug); $version = substr($version,1) if($version && substr($version,0,1) eq 'v'); return (\%default_map, \@result, $version, $has_import_sub); # issue s177: Add $has_import_sub } sub import_perl_to_python # Given a perl name, return the equivalent python name # Used for the importer. 'mapref' is a map from perl names to python names # as seen in the module to be imported. 'perl_name' is the name to be mapped. # For subs, also marks them in LocalSub. { my $mapref = shift; my $perl_name = shift; my $sig = substr($perl_name,0,1); my $result; if($sig eq '&') { $perl_name = substr($perl_name,1); # remove '&' $result = escape_keywords($perl_name); } elsif(index('@$%', $sig) >= 0) { if(exists $mapref->{$perl_name}) { my $fullname = $mapref->{$perl_name}; my $p_dot = rindex($fullname, '.'); if($p_dot) { my $package = substr($fullname, 0, $p_dot); my $python_name = substr($fullname, $p_dot+1); add_package_to_mapped_name($perl_name, $package, $python_name); } return $fullname; # e.g. @arr -> PackageName.arr_a, if it exists in the generated code } return escape_keywords(substr($perl_name, 1)); } else { $result = escape_keywords($perl_name); } say STDERR "import_perl_to_python: setting LocalSub{$result} = 2" if($debug >= 3); $LocalSub{$perl_name} = 2; # Imported return $result; } sub _lock_file # Create a lock filename based on an existing filename { my $lf = shift; $lf =~ s/\.[a-z]+$/.lock/; return $lf; } sub lock_it # Create an advisory lock on a file # arg = full path to file # Returns 1 if locking is successful { my $fullpath = shift; my $lockfile = $fullpath; $lockfile = _lock_file($lockfile); if(-f $lockfile) { my $days_old = (-M $lockfile); if($days_old > ((5*60) / 86400.0)) { # stale if older than 5 mins unlink $lockfile; } } if(-f $lockfile) { return 0; # Already locked } # "touch" file file to create it say STDERR "Created $lockfile for $fullpath" if($debug); open(LF, '>', $lockfile); close(LF); return 1; } sub unlock_it # Remove an advisory lock on a file # arg = full path to file { my $fullpath = shift; my $lockfile = $fullpath; $lockfile = _lock_file($lockfile); @result = (); if(-s $lockfile) { open(LOCKFILE, '<', $lockfile); @result = ; close(LOCKFILE); } unlink $lockfile; say STDERR "Removed $lockfile for $fullpath" if($debug); return @result; } sub gen_implicit_continue # issue for # For a 'for' loop where the loop counter is modified or we can't use the range(...) # operator, we generate a 'while' loop with an implicit 'continue' block where # we put the increment code. Returns 1 if we generate such a thing. { my $tokens; if(($tokens = &Perlscan::needs_implicit_continue(1))) { unpackage_tokens($tokens); if($TokenStr eq '((s=f(s)+d)-d)' || $TokenStr eq '((s=f(s)-d)+d)' || $TokenStr eq '((s=s+d)-d)' || $TokenStr eq '((s=s-d)+d)') { # Get rid of the extra non-needed reversal of the ++/-- destroy(length($TokenStr)-4, 4); destroy(0, 2); } if( $ValClass[0] eq '^' ) { # issue s136 # ++ expr; statement: change to expr++; my $vpl = $ValPerl[0]; my $vpy = $ValPy[0]; # issue s136 destroy(0, 1); # issue s136 append('^', $vpl, $vpy); # issue s136 } # issue s136 fix_expression_issues(); if($ValClass[0] eq 's' && next_same_level_token(',', 0, $#ValClass) == -1) { my $eq = next_same_level_token('=', 0, $#ValClass); $ValPy[$eq] = '=' if($eq != -1 && $ValPy[$eq] eq ':='); $TrStatus=assignment(0, $#ValClass); } else { $TrStatus=expression(0, $#ValClass, 1); } gen_statement(); return 1; } return 0; } sub gen_extra # issue 116: generate the extra stuff after the statement # extra points to the and/or/, etc token after the statement # orig_limit is where we stop { my $extra = shift; my $orig_limit = shift; return if($extra > $orig_limit); gen_chunk($ValPy[$extra]); my $k = next_lower_or_equal_precedent_token('=', $extra+1, $orig_limit); if($k < 0 || $ValClass[$k] ne '=') { $TrStatus=expression($extra+1, $orig_limit, 0); } else { $TrStatus=assignment($extra+1, $orig_limit); } } sub left_hand_substr # # Perl # substr(text, start, length)=replacement # can be translated into Python: # text = text[:start] + replacement + text[start+length:] # or # text = replacement.join(text[0:start],text[start+length:]) { my $equal_pos=index($TokenStr,'='); my ($replacement,$k); if( $equal_pos == -1 ){ $equal_pos = scalar(@ValClass); # issue 114 } # # issue 70: recode it from scratch # # Potential issue with this code: if text or start contains an expression with # a function call or side effect, it will be run more than once! # my $comma1 = next_same_level_token(',', 2, $equal_pos-1); my $comma2 = next_same_level_token(',', $comma1+1, $equal_pos-1); my $comma3 = next_same_level_token(',', $comma2+1, $equal_pos-1); my $end_pos = $equal_pos-1; my $start = 1; if($ValClass[1] eq '(') { $start = 2; my $close_paren = matching_br(1); if($close_paren != -1) { $end_pos = $close_paren-1; } } my $end_len = $end_pos; $end_len = $comma3-1 if($comma3 != -1); my $end_start = $end_pos; # issue lh substr $end_start = $comma2-1 if($comma2 != -1); say STDERR "left_hand_substr(=|$TokenStr|=): comma1=$comma1, comma2=$comma2, comma3=$comma3, equal_pos=$equal_pos, end_pos=$end_pos, end_len=$end_len, end_start=$end_start" if($debug); if($ValClass[$start] eq 'f' && $ValPy[$start] eq $CONVERTER_MAP{S}) { # issue lh substr # Don't generate _str(xxx) on the LHS $k=expression($start+2, $comma1-2,0); # text w/o _str(...) } else { $k=expression($start, $comma1-1,0); # text } return -255 if($k<0); gen_chunk('='); $k=expression($start, $comma1-1,0); # text gen_chunk('[:'); $k=expression($comma1+1, $end_start,0); # start return -255 if($k<0); gen_chunk("]"); if($comma3 != -1) { # issue 114 - replacement in the substr call if($comma3+1 == $end_pos && $ValClass[$end_pos] eq '"' && $ValPerl[$end_pos] eq '') { ; # don't generate anything for the empty string } else { gen_chunk(' + '); $k=expression($comma3+1, $end_pos, 0); } } else { if($equal_pos+1 == $#ValClass && $ValClass[-1] eq '"' && $ValPerl[-1] eq '') { ; # don't generate anything for the empty string } else { gen_chunk(' + '); $k=expression($equal_pos+1); # parse to the tail of the line first starting from '=' } } return -255 if ($k<0); if($comma2 != -1) { # issue lh substr: Leave out last part if there is no length # issue bootstrap: If the start is negative and the length is positive, and # they sum to a non-negative number, then then we don't want this extra part (because it doesn't exist) # example: substr($val,-1,1) = ''; if($ValClass[$comma1+1] eq '-' && $ValClass[$comma2-1] eq 'd' && ($comma2-1)-($comma1+1)==1 && $ValClass[$comma2+1] eq 'd' && ($end_len-($comma2+1))==0 && (-$ValPy[$comma2-1]) + $ValPy[$comma2+1] >= 0) { ; # Generate no code } else { # FIXME: If at run-time we have that same condition above, we'll have the same issue gen_chunk(" + "); $k=expression($start, $comma1-1,0); # text gen_chunk('['); $k=expression($comma1+1, $comma2-1,0); # start gen_chunk('+'); $k=expression($comma2+1, $end_len,0); # length gen_chunk(':]'); } } return scalar(@ValClass); } #left_hand_substr sub init_has_real_values # issue undef # Return 1 if this initializer has values other than undef { my $pos = shift; for(; $pos <= $#ValClass; $pos++) { if($ValClass[$pos] eq '(' || ($ValClass[$pos] eq 'f' && $ValPerl[$pos] eq 'undef') || $ValClass[$pos] eq ')' || $ValClass[$pos] eq ',') { ; # Ok - keep going } else { return 1; } } return 0; } sub last_subscript # Is this the last subscript? e.g. for $h{k1}{k2}[4], returns 1 on the [4] only { my $sub_s = shift; # Points to start of {...} or [...] my $sub_e = shift; # Points to end of {...} or [...] return 1 if($sub_e == $#ValClass); return 1 if($ValClass[$sub_e+1] ne '('); return 0; } sub expr_type_to_token_type # issue ddts # Given an expression type, what token type should we use for it? { my $type = shift; return 'a' if($type =~ /^a/); return 'h' if($type =~ /^h/); return 's'; } sub in_x_element_call # Given a pointer to a '(' in a hash reference, return 1 if this is part of a x_element call, like set_element { my $pos = shift; $pos = start_of_var($pos-1); return 0 if $pos <= 1; return 0 if $ValClass[$pos-1] ne '('; return 0 if $ValClass[$pos-2] ne 'f'; return 1 if $ValPy[$pos-2] =~ /_element$/; return 0; } sub same_as_lhs # issue s3 # Given a pointer to a ')' in a hash reference, return 1 if the variable reference is the same as on the LHS of the expression # This means that if the key doesn't exist yet, we should make it exist and not use .get() # Issue s90: Don't return 1 if this is a reference to %ENV as the autovivification doesn't work on that { my $endrhs = shift; my $posrhs = start_of_var($endrhs); return 0 if $posrhs <= 1; my $eq = next_matching_token('=', 0, $posrhs); return 0 if($eq < 0); my $poslhs = start_of_var($eq-1); my $endlhs = end_of_variable($poslhs); $endrhs = end_of_variable($posrhs); #say STDERR "same_as_lhs: [$poslhs..$endlhs] [$posrhs..$endrhs]" if($debug >= 3); return 0 if(($endrhs-$posrhs) != ($endlhs-$poslhs)); for(my $i=$poslhs, $j=$posrhs; $i <= $endlhs; $i++, $j++) { return 0 if $ValClass[$i] ne $ValClass[$j]; return 0 if $ValPerl[$i] ne $ValPerl[$j]; } return 0 if($ValClass[$posrhs] eq 's' && $ValPerl[$posrhs] eq '$ENV'); # issue s90 return 1; } sub in_keys_or_values # issue s102 # Given a pointer to a '(' in a hash reference, return 1 if this is part of a keys or values call { my $pos = shift; $pos = start_of_var($pos-1); return 0 if $pos <= 1; return 1 if($ValClass[$pos-1] eq 'f' && ($ValPerl[$pos-1] eq 'keys' || $ValPerl[$pos-1] eq 'values')); return 0 if $ValClass[$pos-1] ne '('; return 0 if $ValClass[$pos-2] ne 'f'; return 1 if($ValPerl[$pos-2] eq 'keys' || $ValPerl[$pos-2] eq 'values'); return 0; } sub is_function_out_parameter # issue s359 # Given a pointer to a '(' in a hash reference, return 1 if this is an out parameter to a function call { my $pos = shift; $pos = start_of_var($pos-1); my ($perl, $py, $argn) = &Pythonizer::arg_from_pos($pos); return 0 unless defined $perl; return 0 unless exists $PYF_OUT_PARAMETERS{$py}; return 1 if $argn+1 == $PYF_OUT_PARAMETERS{$py}; return 0; } sub parse_export_tags # For the bootstrapped version, we must manually parse the "%export_tags" line produced by pythonizer_importer { my $tags = shift; # tag => [qw/name name/], tag2 => ... my %result = (); while($tags =~ m'(\w+)\s*=>\s*\[qw/([^/]*)/\]'g) { my $tag = $1; my @names = split ' ', $2; $result{$tag} = dclone(\@names); } return %result; } sub convert_return_expression # issue s9, issue s3 # issue s9: for return (..., ...) convert the tuple to a list or an Array as appropriate # issue s3: if this is the return of a function that's generated to handle the 'e' flag on a s///e, # then convert the result to a str if need be. # issue s216: if we are in TIEHASH or TIEARRAY, then add the tie methods to the result object # issue s262: if this is the return of a function that's generated to handle a complex 'map' operation, # and the return expression matches $_ => expr, then put it in [...] and change the => to a ','. We need # to change the return value to add a ']' instead of a ')'!! # # Returns a close paren if a close paren needs to be added { my $start = shift; my $end_pos = shift; say STDERR "convert_return_expression($start, $end_pos) =|$TokenStr|=" if($debug >= 3); my $cs = &Perlscan::cur_sub(); # Our $CurSub is '__main__' in the _f142 s///e sub if(exists $nested_subs{$cs} && $nested_subs{$cs} eq $DEFAULT_MATCH && &Pythonizer::expr_type($start, $end_pos, $cs) ne 'S') { # issue s3: handle integer on RHS of s///e gen_chunk($CONVERTER_MAP{S}, '('); return ')'; } elsif(exists $nested_subs{$cs} && $ValClass[$start] eq 's' && $ValPerl[$start] eq '$_' && $start+1 <= $end_pos && $ValClass[$start+1] eq 'A') { # issue s262 $ValPy[$start+1] = ','; # issue s262: Change from ':' to ',' gen_chunk('['); # issue s262 return ']'; # issue s262 } elsif($ValClass[$start] eq '(' && $ValClass[$end_pos] eq ')' && next_same_level_token(',', $start+1, $end_pos-1) != -1 && matching_br($start) eq $end_pos) { # issue s213: We have {...}->{key} if($ValPy[$start] eq '{') { if($autovivification) { $Pyf{Hash} = 1; gen_chunk('Hash', '('); return ')'; } } else { # Change tuple to list $ValPy[$start] = '['; $ValPy[$end_pos] = ']'; if($autovivification) { # Array() will take a tuple no issue $Pyf{Array} = 1; gen_chunk('Array', '('); return ')'; } } } elsif($cs eq 'TIEHASH' || $cs eq 'TIEARRAY' || $cs eq 'TIESCALAR') { # issue s216, issue s301 $Pyf{_add_tie_methods} = 1; # issue s216 gen_chunk('_add_tie_methods', '('); # issue s216 return ')'; # issue s216 } elsif($ValClass[$start] eq '(' && $ValPerl[$start] eq '(' && $ValClass[$start+1] eq ')' && ($start+2 > $#ValClass || $ValClass[$start+2] ne ':')) { # issue s254 insert($start+2, 'f', 'undef', 'None'); # issue s254 insert($start+2, ':', ':', 'else'); # issue s254 insert($start+2, 'd', 'wantarray', 'wantarray'); # issue s254 insert($start+2, ':', '?', 'if'); # issue s254 } return ''; } sub remove_unbalanced_curly_brackets # issue s13 # If we have any unbalanced closing curly brackets, remove them # This is used where we add in a 'return' statement for a pre-incr or pre-decr # and our current code line is like "--$i }" - we need to zap that '}' { my $line = shift; my $result = ''; my $balance = 0; for(my $i = 0; $i < length($line); $i++) { my $ch = substr($line,$i,1); if($ch eq '{') { $balance++; $result .= $ch; } elsif($ch eq '}') { $balance--; $result .= $ch if($balance >= 0); } else { $result .= $ch; } } return $result; } sub ok_to_insert_return # issue s3 # Is it ok to sneak in a "return" before this code? { return 0 if(next_matching_tokens('cCkW', 0, $#ValClass) != -1); my $k = next_matching_tokens('=', 0, $#ValClass); return 0 if($k >= 0 && $ValPy[$k] ne ':='); for my $code (@Perlscan::PythonCode) { return 0 if $code eq '='; } return 0 if(scalar(@Perlscan::PythonCode) == 0); return 0 if(exists $PYTHON_KEYWORD_SET{$Perlscan::PythonCode[0]}); return 1; } sub regenerate_expression # issue substr/incr/decr # We already generated the code for this expression once, but we need the value # again for later in the evaluation - figure out if we need to only generate parts # of the expression or the whole thing. Has the same args as &expression, plus one to # pass in a possible temp variable that already has the expression captured if defined. { my ($start, $end_pos, $mode, $temp) = @_; if(defined $temp) { gen_chunk($temp); return $end_pos; } if($ValClass[$start] eq '(' && $ValPerl[$start] eq '(') { # Could be of interest if(matching_br($start) == $end_pos) { # Could be a --$var, ++$var, $var--, $var++ or an in-expression assignment if($start+2 <= $end_pos && $ValClass[$start+1] eq 's' && $ValClass[$start+2] eq '=' && $ValPy[$start+2] eq ':=') { expression($start+1, $start+1, $mode); # This is pre-incr/decr or assignment - just pick up the variable return $end_pos; } elsif($start+3 <= $end_pos && $ValClass[$start+1] eq '(' && $ValPerl[$start+1] eq '(' && $ValClass[$start+2] eq 's' && $ValClass[$start+3] eq '=' && $ValPy[$start+3] eq ':=' && $ValClass[$end_pos-1] eq 'd' && $ValClass[$end_pos-2] =~ /[+-]/) { # this is post-incr/decr gen_chunk('('); expression($start+2, $start+2, 0); expression($end_pos-2, $end_pos-1, 0); gen_chunk(')'); return $end_pos; } } } return expression($start, $end_pos, $mode); } sub capture_expression_value_if_needed # issue substr/incr/decr # Given an expression, see if we need to capture it's value, and if so, return the temp we used to capture it's value, else undef # If we return something please remember to generate a ')' after the expression you generate! { my ($start, $end_pos) = @_; for(my $i = $start; $i <= $end_pos; $i++) { if($ValClass[$i] eq 'f' || ($ValClass[$i] eq 'i' && $LocalSub{$ValPy[$i]})) { gen_chunk('(', $INDEX_TEMP, ':='); return $INDEX_TEMP; } } return undef; } sub in_boolean_context # issue s36 # Check if this bareword is in a boolean context, and therefore is a subref and not a string { my $pos = shift; return 1 if $pos-2 >= 0 && $ValClass[$pos-2] =~ /[Cc]/ && ($pos+1 > $#ValClass || $ValClass[$pos+1] !~ /[.<,]/); # if(BARE return 1 if $pos-1 >= 0 && $ValClass[$pos-1] =~ /[Cc]/ && ($pos+1 > $#ValClass || $ValClass[$pos+1] !~ /[.<,]/); # if BARE (e.g. as stmt modifier) return 1 if $pos != 0 && $ValClass[$pos-1] =~ /[0o]/ && ($pos+1 > $#ValClass || $ValClass[$pos+1] !~ /[.<,]/); return 1 if $pos+1 < $#ValClass && $ValClass[$pos+1] =~ /[0o]/ && ($pos == 0 || $ValClass[$pos-1] !~ /[.<,]/); return 1 if $pos+1 < $#ValClass && $ValClass[$pos+1] eq ':' && $pos != 0 && $ValPerl[$pos-1] eq '?'; return 0; } sub expression_uses_builtin_types # issue s57 # Check to see if this ref is compared with a built-in type like HASH, ARRAY, SCALAR, etc { my $fpos = shift; # Pointer to function start my $eof = end_of_function($fpos); my $comparator = undef; if($fpos-2 >= 0 && $ValClass[$fpos-1] eq '>') { $comparator = $fpos-2; } elsif($eof+2 <= $#ValClass && $ValClass[$eof+1] eq '>') { $comparator = $eof+2; } if(defined $comparator && $ValClass[$comparator] eq '"' && $ValPerl[$comparator] =~ /^(?:HASH|ARRAY|SCALAR|REGEX)$/) { return 1; } return 0; } sub rhs_has_same_number_of_elements # issue s59 # Does the RHS of this expression have the same # of elements as the LHS? { my ($number_of_elements, $start, $limit) = @_; my $noe = $number_of_elements; $number_of_elements = abs($number_of_elements); # issue s198 return 0 if($number_of_elements == 1); # Else we generate wrong code like [a] = 0 if($start == $limit && $ValClass[$start] eq 'q' && $ValPy[$start] =~ /\.split\(\)$/) { my $words = $ValPy[$start]; $words =~ s/\.split\(\)$//; $words =~ s/'//; my $count = split ' ', $words; return ($count == $number_of_elements); } return 0 if $ValClass[$start] ne '('; my $match = matching_br($start); return 0 if $match != $limit; my $commas = 0; for(my $i=$start+1; $i < $limit; $i++) { if($ValClass[$i] eq ',') { $commas++; } elsif($ValClass[$i] eq '(') { $match = matching_br($i); return 0 if $match < 0; $i = $match; } elsif($ValClass[$i] =~ /[ah]/) { # no arrays or hashes allowed return 0; } elsif($ValClass[$i] eq 'f' && substr(&Pythonizer::func_type($ValPerl[$i], $ValPy[$i]),0,1) eq 'a') { # issue s130 - no array functions allowed return 0; # issue s130 } } return ($number_of_elements <= $commas+1) if($noe < 0); # issue s198 return ($number_of_elements == $commas+1); } sub is_multi # issue s299: Is this a multi-subscript fetch? { my $start = shift; # (f(a -or- s,s)y(d,d...)) # [ _get_element ( array, index ) multi [ sub1, sub2, ... ] ] return 0 if($ValClass[$start] ne '('); return 0 if($ValPerl[$start] ne '['); my $end_pos = matching_br($start); return 0 if($end_pos < 0); return 0 if($ValPerl[$end_pos-1] ne ']'); return 0 if(next_same_level_token('y', $start+1, $end_pos-1) < 0); return 0 if($ValClass[$start+1] ne 'f'); return 0 if($ValPerl[$start+1] ne '_get_element'); return 1; } sub in_outer_list # issue s315: Is this token in a list { my $pos = shift; return 0 if $pos > $#ValClass; my $close = next_same_level_token(')', $pos, $#ValClass); return 0 if $close < 0; my $start = reverse_matching_br($close); return 0 if $start < 0; return is_list($start); } sub is_list # issue s75: is this a list of items? # issue s255: If so, return the position of the comma, else return 0 { my $start = shift; my $end_pos = scalar(@_) ? $_[0] : $#ValClass; # issue s252 return 0 if($start > $#ValClass); # issue s290 return is_list($start+1) if($ValPerl[$start] eq '('); my $comma; # issue s299: This first solution is not a good idea because it will say that ((a,b)+d) is a list # issue s299 if($ValPerl[$start] eq '(' && ($comma = is_list($start+1))) { # issue s299 # issue s299 return $comma; # issue s299 if($ValPerl[$start] eq '(') { # issue s299 $start++; # issue s299 $end_pos--; # issue s299 } # issue s299 # It's not quite as easy as looking for a same-level comma because we could have an unparenthesized # function call here. for(my $pos = $start; $pos <= $end_pos; $pos++) { # issue s327: handle a=fa,d,s - which is NOT a list! if($ValClass[$pos] eq 'f') { $pos = end_of_function($pos); return $pos+1 if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq ','); # issue s327 return is_list($pos+1); } elsif($ValClass[$pos] eq 'i' && $LocalSub{$ValPy[$pos]} && ($pos+1 > $#ValClass || $ValClass[$pos+1] ne '(')) { return 0; # unparenthesized local sub call is not a list # issue s252 } elsif(next_same_level_token(',', $start, $#ValClass) >= 0) { # issue s327 } elsif(($comma = next_same_level_token(',', $pos, $end_pos)) >= 0) { # issue s327 return $comma; } elsif($ValClass[$pos] eq '(') { # issue s327 my $close = matching_br($pos); # issue s327 $pos = $close if $close != -1; # issue s327 } elsif($ValClass[$pos] eq ',') { # issue s327 return $pos; # issue s327 } } return 0; } sub is_immutable_list # issue s252: Is this a list of immutable items? { my $start = shift; my $end_pos = scalar(@_) ? $_[0] : $#ValClass; # issue s252 return 0 if($start > $#ValClass); return is_immutable_list($start+1, matching_br($start)) if($ValPerl[$start] eq '('); for(my $pos = $start; $pos <= $end_pos; $pos++) { if($ValClass[$pos] eq 'f') { $pos = end_of_function($pos); } elsif($ValClass[$pos] eq 'i' && $LocalSub{$ValPy[$pos]} && ($pos+1 > $#ValClass || $ValPerl[$pos+1] ne '(')) { return 1; # unparenthesized local sub call is immutable } elsif($ValClass[$pos] eq 'i' && $pos+1 <= $#ValClass && $ValPerl[$pos+1] eq '(') { $pos = matching_br($pos+1); } elsif($ValClass[$pos] =~ /[ahsG]/) { return 0; # A mutable item } } return 1; } sub default_var_string # issue s104: Is the default variable a string type? { return (exists $VarType{$DEFAULT_VAR}{$CurSub} && $VarType{$DEFAULT_VAR}{$CurSub} eq 'S'); } sub is_string # issue s116: Is the variable at this position definitely a string? { my $i = shift; if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{$CurSub}) { return $VarType{$ValPy[$i]}{$CurSub} eq 'S'; } return 0; } sub subref_call # issue s109: Is this a subref call? { my $pos = shift; return 0 if $pos < 0; $pos = start_of_var($pos); return 0 if $pos < 0; return 1 if $ValClass[$pos] eq 's'; return 0; } sub fix_boolean_expressions # issue s124 # Convert boolean expressions that return True or False to instead return 1 or '', where needed { my $start = $_[0]; my $limit = $_[1]; my $skip = $_[2]; return 0 if index(substr($TokenStr, $start, $limit+1-$start), '>') == -1; # No boolean expressions here return 0 if($start == 0 && $limit >= 2 && $ValClass[0] eq 'k' && $ValPerl[0] eq 'use' && $ValPerl[1] eq 'constant'); return 0 if($start == 0 && $limit >= 2 && $ValClass[0] eq 'k' && $ValPerl[0] eq 'no' && $ValPerl[1] eq 'if'); say STDERR "fix_boolean_expressions($start, $limit, $skip) for |$TokenStr| on line $. ValPerl=@ValPerl" if($debug); my $adjust = 0; my $a = 0; for(my $cur = $start; $cur <= $limit; $cur++) { if($ValClass[$cur] eq 's') { while($cur+1 <= $limit && $ValClass[$cur+1] eq '(') { # Array subscripts or hash keys my $end = matching_br($cur+1); last if $end < 0; $a = fix_boolean_expressions($cur+2, $end-1, $ValPerl[$cur+1] eq '['); # Recurse but skip if array index $cur = $end + $a; $limit += $a; $adjust += $a; } } elsif($ValClass[$cur] eq 'k' && $ValPerl[$cur] eq 'return') { return fix_boolean_expressions($cur+1, $limit, $skip); } elsif($ValClass[$cur] eq 'C' && $ValPerl[$cur] eq 'eval') { $adjust += fix_boolean_expressions($cur+1, $limit, 1); return $adjust; } elsif($ValClass[$cur] eq '*' && $ValPerl[$cur] eq 'x') { # replicator if($cur+1 <= $limit && $ValClass[$cur+1] eq '(') { my $end = matching_br($cur+1); next if $end < 0; $a = fix_boolean_expressions($cur+2, $end-1, 1); # Skip what's in the parens of the replicator $cur = $end + $a; $limit += $a; $adjust += $a; } } elsif($ValClass[$cur] eq '(' && $ValPerl[$cur] eq '(') { # Real parens my $end = matching_br($cur); next if $end < 0; my $ocur = $cur; while(1) { my $comma = next_same_level_token(',', $cur+1, $end-1); $comma = $end if $comma < 0; $a = 0; if($cur+1 <= $comma-1) { my $s = 0; $s = 1 if($skip && $cur == 1); # propagate skip if these are the initial brackets on a control stmt $s = 1 if($skip && $ocur > 0 && $ValClass[$ocur-1] !~ /[fi]/ && $comma == $end); # propagate skip if internal parens are used on a control stmt and this is not a sub or function call $s = 1 if($skip && $ocur > 0 && $ValClass[$ocur-1] eq ':' && $comma == $end); # propagate skip on brackets on ? : operation $a = fix_boolean_expressions($cur+1, $comma-1, $s); # Handle each item in a comma separated list } $adjust += $a; $cur = $comma + $a; $end += $a; $limit += $a; last if $comma >= $end; } } elsif($ValClass[$cur] eq '(' && $ValPerl[$cur] eq '{') { # Brackets like in grep { expr } my $end = matching_br($cur); next if $end < 0; $a = fix_boolean_expressions($cur+1, $end-1, 1); # Skip insertion on grep/map expr $adjust += $a; $cur = $end + $a; $limit += $a; } elsif($ValClass[$cur] eq '=' && $ValPy[$cur] ne ':=') { $adjust += fix_boolean_expressions($cur+1, $limit, $skip); # Handle RHS of assignment return $adjust; } elsif($ValClass[$cur] eq 'f' && $cur+1 <= $limit && $ValClass[$cur+1] eq '(' && $ValPy[$cur] =~ /^(?:_int|_num)$/) { my $end = matching_br($cur+1); next if $end < 0; $a = fix_boolean_expressions($cur+2, $end-1, 1); $cur = $end + $a; $adjust += $a; $limit += $a; } elsif($ValClass[$cur] eq ':') { # Should be the first ':' in a ? : operator my $colon = next_same_level_token(':', $cur+1, $limit-1); next if $colon < 0; $a = fix_boolean_expressions($cur+1, $colon-1, 1); # Handle the 'if' part with skip on $colon += $a; $a += fix_boolean_expressions($colon+1, $limit, 0); # Handle the 'else' part $adjust += $a; return $adjust; } elsif($ValClass[$cur] eq ';') { # Should be a for loop my $semi = next_same_level_token(';', $cur+1, $limit-1); next if $semi < 0; $a = fix_boolean_expressions($cur+1, $semi-1, 1); # Handle the condition part with skip on $semi += $a; $a += fix_boolean_expressions($semi+1, $limit, 0); # Handle the rest $adjust += $a; return $adjust; } elsif($ValClass[$cur] eq '>' && !$skip) { # Case of interest next if($ValPerl[$cur] eq '<=>' || $ValPerl[$cur] eq 'cmp'); my $lower = next_lower_or_equal_precedent_token('>', $cur+1, $limit); if($lower > 0) { $a = fix_boolean_expressions($start, $lower-1, 0); $cur = $lower + $a; $start = $cur+1; $limit += $a; $adjust += $a; } else { insert($limit+1,')',')',')'); insert($start,'(','(','('); insert($start,'f',$CONVERTER_MAP{B},$CONVERTER_MAP{B}); say STDERR "fix_boolean_expressions($start, $limit, $skip): Inserting converter, now |$TokenStr| ValPerl=@ValPerl" if($debug); $limit += 3; $cur += 2; $start += 2; $adjust += 3; } } } return $adjust; } #sub gen_list # issue s130, issue s308: Replaces flatten_lists ## Generate code for lists on RHS, splatting items as needed ## Arg1: Start pos (at the '(' on the RHS) ## Arg2: True if single element lists should always be stripped of their parens #{ # my $start = $_[0]; # my $strip_parens = $_[1]; # # my $elements = 0; # my $end_pos = matching_br($start); # my $p; # issue s307 # return 0 if($end_pos < 0); # if($strip_parens) { # if(!is_list($start+1)) { # # In the case of (gmtime)[0..5], we can't remove the parens around gmtime or else we generate bad code # if($end_pos+1 < $#ValClass && $ValPerl[$end_pos+1] eq '[') { # return expression($start, $end_pos); # } else { # return expression($start+1, $end_pos-1); # } # } # } # if($autovivification) { # $Pyf{Array} = 1; # gen_chunk('Array', '('); # } # gen_chunk('['); # for(my $i=$start+1; $i<$end_pos; $i++) { # my $comma = next_same_level_tokens(',A)', $i, $end_pos); # if($comma == $i) { # $comma = next_same_level_tokens(',A)', $i+1, $end_pos); # } # my $expr_end = $end_pos-1; # $expr_end = $comma-1 if $comma != -1; # if($ValClass[$i] eq 'a') { # gen_chunk('*'); # gen_chunk($ValPy[$i]); # }elsif($ValClass[$i] eq 'h') { # gen_chunk('*'); # gen_chunk("itertools.chain.from_iterable($ValPy[$i].items())"); # } elsif($ValClass[$i] eq 'f') { # if(substr(&Pythonizer::func_type($ValPerl[$i], $ValPy[$i]),0,1) =~ /^a/) { # gen_chunk('*'); # } # $i = function($i)-1; # } elsif($ValClass[$i] eq 'i' && $LocalSub{$ValPy[$i]}) { # # *(_s if not isinstance(_s := list_sub(), str) and hasattr(_s, '__iter__') else [_s]) # my $wa = get_sub_attribute($ValPy[$i], 'wantarray'); # if(!defined $wa) { # gen_chunk('*', '(', $SUBSCRIPT_TEMP, 'if', 'not', 'isinstance', '(', $SUBSCRIPT_TEMP, ':='); # } # $i = expression($i, end_of_call($i))-1; # if(!defined $wa) { # gen_chunk(',', 'str', ')', 'and', 'hasattr', '(', $SUBSCRIPT_TEMP, ',', "'__iter__'", ')', 'else', '[', $SUBSCRIPT_TEMP, ']', ')'); # } # } elsif($i+2 <= $end_pos && ($ValClass[$i] eq 's' || $ValClass[$i] eq '"') && $ValClass[$i+1] eq 'p' && $ValClass[$i+2] eq 'q' && substr($ValPy[$i+1],0,1) ne '.') { # see test_regex, issue s74, issue s151 # gen_chunk('*'); # $i = expression($i, $i+2)-1; # # FIXME: Handle ? : operator - splat the result, not each piece # } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '(' && $i != 0 && $ValClass[$i-1] !~ /[if]/) { # # Look for another list inside this list, but not in a function or sub call # my $e = matching_br($i); # my $p = next_same_level_token(',', $i+1, $e-1); # if($p != -1) { # gen_chunk('*'); # } elsif(&Pythonizer::expr_type($i, $e, $CurSub) =~ /^a/) { # gen_chunk('*'); # } # $i = expression($i, $expr_end)-1; # } elsif(next_same_level_token('r', $i, $expr_end) >= 0) { # gen_chunk('*'); # gen_chunk('('); # $i = expression($i, $expr_end)-1; # gen_chunk(')'); # } elsif($ValClass[$i] eq ',' || $ValClass[$i] eq 'A') { # gen_chunk(','); # } elsif($i >= $expr_end) { # $i = expression($i, $expr_end)-1; # } # } # gen_chunk(']'); # if($autovivification) { # gen_chunk(')'); # } # return $end_pos; #} sub flatten_lists # issue s130 # Flatten lists if needed # Arg1: Start pos (at the '(' on the RHS) # Arg2: True if single element lists should always be stripped of their parens # Returns: The # of elements added (or deleted) # # issue s308: This routine is now gutted and replaced with insert_splat_lists and a smarter need_splat function # Flattening messed up lists that contained arrrefs and hashrefs. { my $start = $_[0]; my $strip_parens = $_[1]; my $need_flatten = 0; my $elements = 0; my $end_pos = matching_br($start); my $p; # issue s307 return 0 if($end_pos < 0); for(my $i=$start+1; $i<$end_pos; $i++) { $elements++; if($ValClass[$i] =~ /[ah]/) { $need_flatten = 1; last if($elements>1); # issue s307 } elsif($ValClass[$i] eq 'f' && substr(&Pythonizer::func_type($ValPerl[$i], $ValPy[$i]),0,1) eq 'a') { } elsif($ValClass[$i] eq 'f' && substr(&Pythonizer::func_type($ValPerl[$i], $ValPy[$i]),0,1) =~ /^a/) { # issue s307 $need_flatten = 1; last if($elements>1); $i = end_of_function($i); # issue s24 # issue s151 } elsif($i+2 <= $end_pos && ($ValClass[$i] eq 's' || $ValClass[$i] eq '"') && $ValClass[$i+1] eq '~' && $ValClass[$i+2] eq 'q' && substr($ValPy[$i+1],0,1) ne '.') { # see test_regex, issue s74 } elsif($i+2 <= $end_pos && ($ValClass[$i] eq 's' || $ValClass[$i] eq '"') && $ValClass[$i+1] eq 'p' && $ValClass[$i+2] eq 'q' && substr($ValPy[$i+1],0,1) ne '.') { # see test_regex, issue s74, issue s151 $need_flatten = 1; last if($elements>1); } elsif($ValClass[$i] eq '(' && $ValPerl[$i] eq '(' && $i != 0 && $ValClass[$i-1] !~ /[if]/) { # Look for another list inside this list, but not in a function or sub call my $e = matching_br($i); my $p = next_same_level_token(',', $i+1, $e-1); if($p != -1) { $need_flatten = 1; } elsif(&Pythonizer::expr_type($i, $e, $CurSub) =~ /^a/) { $need_flatten = 1; } } elsif(($p = next_same_level_tokens('r,', $i, $end_pos-1)) >= 0 && $ValClass[$p] eq 'r') { # issue s307 $need_flatten = 1; # issue s307 last if($elements>1); # issue s307 } $i++ if $ValClass[$i] eq ')'; # issue s307 my $pos = next_same_level_token(',', $i, $end_pos-1); $pos = $end_pos if($pos == -1); $i = $pos; } my $adjust = 0; if($need_flatten && $elements==1 && ($strip_parens || $ValClass[$start+1] =~ /[ahf]/)) { # In the case of (gmtime)[0..5], we can't remove the parens around gmtime or else we generate bad code return 0 if($end_pos+1 < $#ValClass && $ValPerl[$end_pos+1] eq '['); destroy($end_pos, 1); destroy($start,1); $adjust = -2; } elsif($need_flatten && $elements != 1) { # issue s308: This is the WRONG solution to the issue!! We need to splat the list elements instead, which we do elsewhere, and also # add the new _sl lambda for where we're not sure if we have a list or not. # issue s308 $Pyf{'_flatten'} = 1; # issue s308 insert($end_pos, ')', ')', ')'); # add an extra close paren # issue s308 insert($start, '(', '(', '('); # and an extra open paren (flatten only takes one arg) # issue s308 insert($start, 'f', '_flatten', '_flatten'); # issue s308 $adjust = 3; } say STDERR "flatten_lists: need_flatten=$need_flatten, elements=$elements, |$TokenStr|, @ValPerl" if($::debug && $adjust); return $adjust; } sub fix_singular_foreach # issue s137 # If we have a for (each) that iterates over one scalar, then make it a list of 1 item instead, else # we will wind up iterating over each char of a string - which is not what perl does!! { return if($#ValClass < 1); return if($ValClass[0] ne 'c'); return if($ValPy[0] ne 'for'); return if(index($TokenStr, ';') != -1); # is a for, not a foreach my($expr_start, $expr_end); # issue s235 my $loop_ctr_ndx; # issue s252 if(for_loop_uses_default_var(0)) { # issue s235: $selected{$_}++ for $self->param($name); # We may not have a (...), or at least not one that defines the items being looped on, so handle that properly $expr_start = 0; $expr_end = scalar(@ValClass); if($ValPerl[1] eq '(') { $expr_start = 1; $expr_end = matching_br(1); return if $expr_end < 0; } } else { $expr_start = next_same_level_token('(', 1, $#ValClass); return if $expr_start < 0; $expr_end = matching_br($expr_start); return if $expr_end < 0; $loop_ctr_ndx = 1; $loop_ctr_ndx = 2 if $ValClass[1] eq 't'; } if(exists $Perlscan::line_contains_for_loop_with_modified_counter{$.} && (is_multi($expr_start+1) || # issue s299 (is_list($expr_start) && !is_immutable_list($expr_start)))) { # issue s252 fix_aliased_foreach_with_list($loop_ctr_ndx, $expr_start, $expr_end); # issue s252 return; } # issue s224 return if exists $Perlscan::line_contained_array_conversion{$Perlscan::statement_starting_lno}; # was like @$ar my $do_over = 0; if($ValClass[$expr_start+1] eq 's' && end_of_variable($expr_start+1) == $expr_end-1 && (!defined $ValType[$expr_start+1] || $ValType[$expr_start+1] ne '@s')) { # '@s' means this was a @$arrayref ; # We got an easy one } else { # Issue s224 - it could be a complex expression returning a scalar: handle either a ?: or a || && or and while((my $pq = next_same_level_tokens('?:0o', $expr_start+1, $expr_end-1)) != -1) { # issue s224 if($ValClass[$pq] eq '?') { # Skip the first thing as that's the value being tested $expr_start = $pq; next; } #my $nq = next_same_level_tokens('?:0o', $pq+1, $expr_end-1); if($ValClass[$expr_start+1] eq 's' && end_of_variable($expr_start+1) == $pq-1 && (!defined $ValType[$expr_start+1] || $ValType[$expr_start+1] ne '@s')) { $expr_end = $pq; $do_over = 1; last; } else { $expr_start = $pq; next; } } if(!$do_over && $ValClass[$expr_start+1] eq 's' && end_of_variable($expr_start+1) == $expr_end-1 && (!defined $ValType[$expr_start+1] || $ValType[$expr_start+1] ne '@s')) { # issue s224 $do_over = 1; } return if !$do_over; # issue s224 } if($ValClass[$expr_start+2] eq 'D') { # OO call - we're not sure what it's gonna return, so make it in a list, then flatten it $Pyf{'_flatten'} = 1; insert($expr_end, ')', ')', ')'); insert($expr_end, ')', ']', ']'); insert($expr_start+1, '(', '[', '['); insert($expr_start+1, '(', '(', '('); # and an extra open paren (flatten only takes one arg) insert($expr_start+1, 'f', '_flatten', '_flatten'); } else { insert($expr_end, ')', ']', ']'); insert($expr_start+1, '(', '[', '['); } fix_singular_foreach() if $do_over; # issue s224 say STDERR "fix_singular_foreach =|$TokenStr|=, ValPy = @ValPy" if($debug); } sub fix_aliased_foreach_with_list # issue s252 { my ($loop_ctr_ndx, $expr_start, $expr_end) = @_; my ($loop_ctr_py, $loop_ctr_perl); if(defined $loop_ctr_ndx) { $loop_ctr_py = $ValPy[$loop_ctr_ndx]; $loop_ctr_perl = $ValPerl[$loop_ctr_ndx]; } else { $loop_ctr_py = $DEFAULT_VAR; $loop_ctr_perl = '$_'; } my $was_stacked = &Perlscan::clear_foreach_try_block(); my $subname = new_anonymous_sub(); $aliased_foreach_return{$subname} = $loop_ctr_py; $loop_ctr_py = '' if($was_stacked); $nested_subs{$subname} = $loop_ctr_py; $aliased_foreach_subs{$subname} = $loop_ctr_perl; push @saved_sub_tokens_stack, $saved_sub_tokens; # issue s311 push @saved_sub_tokens_level, $nested_sub_at_level; # issue s311 $saved_sub_tokens = package_tokens(); p_replace($saved_sub_tokens, 0, 'c', 'aliased_foreach', $subname); if(!defined $loop_ctr_ndx) { # Normalize it always to have a loop ctr and parens p_insert($saved_sub_tokens, 1, 's', '$_', $DEFAULT_VAR); if($ValPerl[$expr_start] ne '(') { p_append($saved_sub_tokens,')',')',')'); p_insert($saved_sub_tokens, 2, '(','(','('); } } destroy(0, $#ValClass); replace(0,'k','sub','def'); append('i', $subname, $subname); if(scalar(@Perlscan::nesting_stack) == 0 || $Perlscan::nesting_stack[-1]->{type} ne 'foreach') { $deferred_nesting_top = $subname; return; } # Since we already processed the '{' after the 'for', adjust the nesting_info at the top of the stack $top = $Perlscan::nesting_stack[-1]; $top->{is_sub} = 1; $top->{in_sub} = 1; $top->{cur_sub} = $subname; $top->{type} = 'sub'; $top->{in_loop} = 0; $top->{is_loop} = 0; $top->{was_foreach} = 1; # Now we go and generate the code for the nested sub } sub gen_complex_chop_chomp # issue s148 { my $start = shift; my $end_pos = shift; my $is_chomp = shift; my $tokens = package_tokens(); while($#ValClass > $end_pos) { destroy($#ValClass, 1); } while($start != 0) { destroy($start-1, 1); $start--; $end_pos--; } # At this point, we just have the thing we need to chop/chomp # If there is a converter on it, remove it as we will put it back only on the RHS later if($ValClass[0] eq 'f' && $ValPy[0] eq $CONVERTER_MAP{S} && matching_br(1) == $#ValClass) { destroy($#ValClass, 1); destroy(0, 2); } my $perl = ($is_chomp ? "chomp_" : "chop_"); my $py = ($is_chomp ? $Perlscan::keyword_tr{chomp} : $Perlscan::keyword_tr{chop}) . '__'; # We add the '__' so PyFuncType is not found my $type = $ValClass[0]; # s, a, or h if($type eq '(' && $ValPy[0] eq '[') { # check for f((f(a,s)y(d,d))): chomp ( [ _get_element ( @a , _i ) multi [ 0 , 2 ] ] ) my $y = next_same_level_token('y', 1, $#ValClass); # We want it to be [_set_element(@a, _i, _get_element(@a, _i).chomp_) for _i in [0, 2]] my $array_end = $y-4; my $array_start = 3; insert($y, ')', ')', ')'); $y++; insert($y-1, 'f', $perl, $py); $y++; insert(1, ',', ',', ','); $y++; insert(1, 's', $ValPerl[$y-4], $ValPy[$y-4]); insert(1, ',', ',', ','); $array_start += 3; $array_end += 3; for(my $i = $array_start; $i <= $array_end; $i++) { insert(1, $ValClass[$i], $ValPerl[$i], $ValPy[$i]); $i++; $array_end++; } insert(1, '(', '(', '('); $Pyf{_set_element} = 1; insert(1, 'f', '_set_element', '_set_element'); say STDERR "gen_complex_chop_chomp - adjusted _get_element =|$TokenStr|= ValPy = @ValPy" if($debug); expression(0, $#ValClass, 0); gen_statement(); unpackage_tokens($tokens); # put it back like it was return; } append('=','.=','+='); append('f', $perl, $py); replace(0, 's', $ValPerl[0], $ValPy[0]); # make it an 's' for now expand_augmented_assignment(0, $#ValClass-1, $#ValClass, ($type eq 'a' || $type eq 'h')); fix_type_issues(0, $#ValClass, undef); # Now we have ... = ... . chop_/chomp_ - just need to remove the '.' and generate the code my $dot = next_same_level_token('.', 0, $#ValClass); destroy($dot, 1); say STDERR "gen_complex_chop_chomp($start, $end_pos, $is_chomp) gives =|$TokenStr|= @ValPy" if($debug); if($type eq 'a' || $type eq 'h') { # Handle array or hash chomp my $eq = next_same_level_token('=', 0, $#ValClass); my $temp; if($type eq 'a') { $temp = $INDEX_TEMP; gen_chunk("for $temp in range(len("); expression(0, $eq-1, 0); gen_chunk(')):'); } else { $temp = $KEY_TEMP; gen_chunk("for $temp in "); expression(0, $eq-1, 0); gen_chunk(':'); } gen_statement(); correct_nest(1,1); #gen_chunk($ValPy[$start]."[$temp] = ".$CONVERTER_MAP{S}.'('.$ValPy[$start]."[$temp])".$py_name); # SNOOPYJC, issue s148 $TrStatus = expression(0, $eq-1, 0); gen_chunk("[$temp] = "); if($ValClass[$#ValClass-1] eq ')') { insert($#ValClass-1, 'y', '', "[$temp]"); $TrStatus = expression($eq+1, $#ValClass-1, 0); } else { $TrStatus = expression($eq+1, $#ValClass-1, 0); gen_chunk("[$temp]"); } function($#ValClass); # Tack on the function gen_statement(); correct_nest(-1,-1); } else { $TrStatus=assignment(0); # Generate the code } unpackage_tokens($tokens); # put it back like it was } sub generate_tie_class_methods # issue s154 # If this package defines the perl tie methods, then generate the associated python class methods # issue s216: NOTE: This sub isn't used anymore and just returns!! { return; # issue s216: We do this at runtime on the class instance now my $found_one = 0; foreach (values %TIE_CONSTRUCTORS) { if(exists $LocalSub{$_} && $LocalSub{$_} == 1) { $found_one = 1; } } return if !$found_one; my $p_escaped = escape_keywords($CurPackage, 1); foreach (keys %LocalSub) { next if $LocalSub{$_} != 1; # Not local next unless exists($TIE_MAP{$_}); my $py = $TIE_MAP{$_}; #gen_statement("$py = $_"); #gen_statement("$py = lambda *_args: $_(_args[0].__dict__, *_args[1:])"); #gen_statement("$p_escaped.$py = $_"); gen_statement("$p_escaped.$py = $p_escaped.$_"); } # Always generate an __untie__ method unless we generated it above if(!exists $LocalSub{UNTIE} || $LocalSub{UNTIE} != 1) { my $py = $TIE_MAP{UNTIE}; #gen_statement("$py = lambda self: None"); #gen_statement("$p_escaped.$py = $_"); gen_statement("$p_escaped.$py = lambda self: None"); } # In case we test the result of 'tie', make it always True unless the tie constructor explicitly returns 0 # Otherwise it will return False for an empty hash or array, not what we want #gen_statement("__bool__ = lambda self: True"); #gen_statement("$p_escaped.__bool__ = __bool__"); gen_statement("$p_escaped.__bool__ = lambda self: True"); # Generate some extra functions for arrays here if(exists $LocalSub{TIEARRAY}) { if(exists $LocalSub{POP} && exists $LocalSub{SHIFT}) { gen_statement("pop = lambda *_args: POP(_args[0].__dict__) if len(_args) == 1 else SHIFT(_args[0].__dict__)"); gen_statement("$p_escaped.pop = pop"); } elsif(exists $LocalSub{DELETE}) { gen_statement("def pop(self, ndx=-1):"); correct_nest(1,1); gen_statement("result = FETCH(self.__dict__, ndx)"); gen_statement("DELETE(self.__dict__, ndx)"); gen_statement("return result"); correct_nest(-1,-1); gen_statement("$p_escaped.pop = pop"); } else { logme('S', "Tied Array must have POP/SHIFT and/or DELETE to implement pop operations"); } gen_statement("extend = lambda self, lst: [PUSH(self.__dict__, l) for l in lst]"); gen_statement("$p_escaped.extend = extend"); } # Generate some extra functions for hashes here if(exists $LocalSub{TIEHASH}) { gen_statement("def __iter__(self):"); correct_nest(1,1); gen_statement("self.iterfirst = True"); gen_statement("return self"); correct_nest(-1,-1); gen_statement("$p_escaped.__iter__ = __iter__"); gen_statement("def __next__(self):"); correct_nest(1,1); gen_statement("if self.iterfirst:"); correct_nest(1,1); gen_statement("self.iterfirst = False"); gen_statement("result = FIRSTKEY(self.__dict__)"); correct_nest(-1,-1); gen_statement("else:"); correct_nest(1,1); gen_statement("result = NEXTKEY(self.__dict__)"); correct_nest(-1,-1); gen_statement("if result is None:"); correct_nest(1,1); gen_statement("raise StopIteration"); correct_nest(-1,-1); gen_statement("return result"); correct_nest(-1,-1); gen_statement("$p_escaped.__next__ = __next__"); gen_statement("def pop(self, key, default=None):"); correct_nest(1,1); gen_statement("if not EXISTS(self.__dict__, key):"); correct_nest(1,1); gen_statement("return default"); correct_nest(-1,-1); gen_statement("return DELETE(self.__dict__, key)"); correct_nest(-1,-1); gen_statement("$p_escaped.pop = pop"); gen_statement("$p_escaped.keys = lambda self: [k for k in self]"); gen_statement("$p_escaped.values = lambda self: [self[k] for k in self]"); gen_statement("$p_escaped.items = lambda self: [(k, self[k]) for k in self]"); gen_statement("update = lambda self, items: {STORE(self.__dict__, i, items[i]) for i in items}"); gen_statement("$p_escaped.update = update"); } } sub handle_open_dup # issue s166 # Handle 'dup' with file handle in open - bust it out to a separate argument # Arg: Points to the position of the open function # Returns the adjustment factor - how many tokens we added { my $pos = shift; my $start = $pos+1; return 0 if $start > $#ValClass; my $end_pos; if($ValClass[$start] eq '(') { $end_pos = matching_br($start)-1; $start++; } else { $end_pos = end_of_function($pos); } my $comma = next_same_level_token(',', $start, $end_pos); return 0 if $comma < 0; my $arg2 = $comma + 1; return 0 if $ValClass[$arg2] ne '"'; my $mode = unquote_string($ValPy[$arg2]); return 0 unless($mode =~ /^([<>+]+[&]=?)\s*([A-Za-z_][A-Za-z0-9_]*)$/); my $new_mode = $1; my $handle = $2; return 0 if next_same_level_token(',', $arg2, $end_pos) != -1; # Must only have 2 args $ValPerl[$arg2] = $new_mode; $ValPy[$arg2] = "'$new_mode'"; $handle_py = $handle; $handle_py = $Perlscan::keyword_tr{$handle} if exists $Perlscan::keyword_tr{$handle}; # e.g. STDOUT -> sys.stdout insert($end_pos+1, 'i', $handle, $handle_py); &Perlscan::add_package_name_fh($end_pos+1); insert($end_pos+1, ',', ',', ','); return 2; } sub is_hash # issue s175: Is this a hash? This type can be set if it's referenced as %$href somewhere { my $i = $_[0]; if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{$CurSub}) { return $VarType{$ValPy[$i]}{$CurSub} =~ /^h/; } return 0; } sub sub_returns_array # issue s308 # Does this sub return an array if called in list context? # returns 1 if it definitely returns an array, returns 0 if it does not return an array, # return -1 if we're not sure { my $i = $_[0]; if(defined get_sub_attribute($ValPy[$i], 'wantarray')) { say STDERR "sub_returns_array($ValPy[$i]) = 1 (wantarray)" if $debug >= 5; return 1; } if(exists $VarType{$ValPy[$i]} && exists $VarType{$ValPy[$i]}{__main__}) { my $typ = $VarType{$ValPy[$i]}{__main__}; if($typ =~ /^a/) { say STDERR "sub_returns_array($ValPy[$i]) = 1 (typ = $typ)" if $debug >= 5; return 1; } if($typ =~ /^[sIFBSmu]$/) { say STDERR "sub_returns_array($ValPy[$i]) = 0 (typ = $typ)" if $debug >= 5; return 0; } say STDERR "sub_returns_array($ValPy[$i]) = -1 (typ = $typ)" if $debug >= 5; return -1; } say STDERR "sub_returns_array($ValPy[$i]) = -1" if $debug >= 5; return -1; } sub gen_init_outps # issue s184 # If needed, generate the call to _init_outps for this sub, just after we copy the arguments from a tuple to a list { my $cs = shift; # issue s241 if(exists $SubAttributes{$cs}{out_parameters}) { # issue s241 my @outs = @{$SubAttributes{$cs}{out_parameters}}; if(defined get_sub_attribute($cs, 'out_parameters')) { my @outs = @{get_sub_attribute($cs, 'out_parameters')}; no warnings 'numeric'; # issue s185: handle 1r, etc my @refs; # issue s185 foreach (@outs) { # issue s185 if(/r/ && !/^var$/) { # issue s185 push @refs, int($_); # issue s185: Keep track of which args are references } # issue s185 } # issue s185 if($outs[0] ne 'var') { # issue s185 @outs = map(int, @outs); # issue s185: remove any 'r' (for 'reference') } my $outstr = ', ' . join(', ', @outs); $outstr = '' if $outstr eq ", var"; $Pyf{_init_out_parameters} = 1; my $init = '_init_out_parameters'; $init = "$PERLLIB.init_out_parameters" if $import_perllib; my $refstr = ''; # issue s185 if(scalar(@refs)) { # issue s185 $refstr = "\t# refs: " . join(', ', @refs); # issue s185: Generate a comment that we look at when reading the code for import } output_line("$init($PERL_ARG_ARRAY$outstr)$refstr"); } } sub fix_out_parameters # issue s184 # Run thru this line and make any needed changes for handing output parameters { # First see if we have a call to a sub that has out parameters my $change = 0; for(my $pos = 0; $pos <= $#ValClass; $pos++) { if($ValClass[$pos] eq 'i' && ($pos == 0 || ($ValPerl[$pos-1] ne 'sub' && $ValClass[$pos-1] ne '\\' && $ValPerl[$pos-1] ne 'goto')) && call_has_out_parameters($pos)) { # Sub call with out params, not sub def, not ref to sub, issue s241 if(($pos == 0 || $ValPerl[$pos-1] eq 'return') && $pos+3 <= $#ValClass && $ValClass[$pos+1] eq '(' && $ValPerl[$pos+2] eq '@_' && $ValClass[$pos+3] eq ')') { # issue s241: return ⊂ (the arg list gets inserted during lexing) next; # issue s241 } # issue s241 my $start = $pos; my $attr_sub_name = $ValPy[$pos]; my $adj = 0; if($pos-2 >= 0 && $ValClass[$pos-1] eq 'D') { $start = start_of_expr($pos-2); $attr_sub_name = "->$attr_sub_name"; # This is where we store the subname for methods $adj = 1; } my $end_pos = end_of_call($pos); #insert($end_pos+1, 'y', '', '[0]') unless($start == 0); insert($end_pos+1, 'y', '', '[0]'); # We may sneak in a 'return' so always put in this subscript insert($end_pos+1, ')', ')', ')'); my $var_args = 0; if($SubAttributes{$attr_sub_name}{out_parameters}->[0] eq 'var') { # Do up to 256 args to support var # Temporarily change it to list the arg numbers for var_args $SubAttributes{$attr_sub_name}{out_parameters} = []; my $commas = ($TokenStr =~ tr/,//); # How many commas are in the TokenStr = rough max of # of args my $max_args = $commas+1; $var_args = 1; for(my $i = 0; $i < $max_args; $i++) { push @{$SubAttributes{$attr_sub_name}{out_parameters}}, ($i+$adj); } } my $did_one = 0; no warnings 'numeric'; # handle 1r, etc my $composite = 0; my $composite_arg; my ($s, $e) = get_arg_start_end($pos, $end_pos, 1-$adj); if(defined $s && ($ValClass[$s] eq 'a' || $ValClass[$s] eq 'h')) { # We start with a composite, so track that in case we miss it $composite_arg = 0; } for my $arg_copy (reverse sort { $a <=> $b } @{$SubAttributes{$attr_sub_name}{out_parameters}}) { my $arg = $arg_copy; # we want a copy, not an alias to it, because we change it say STDERR "fix_out_parameters: Processing out parameter $arg for $ValPy[$pos]" if($debug >= 5); my $which = $arg; $which = $composite_arg if defined $composite_arg; ($s, $e) = get_arg_start_end($pos, $end_pos, $which+1-$adj); next unless defined $s; $did_one = 1; my ($val, $valclass, $valperl); if($arg =~ /r/ && $ValClass[$s] ne '\\' && $ValPerl[$s] ne '$_') { logme('W', "Argument " . ($arg+1) . " to $ValPy[$pos] is not a reference but is modified as a reference by the sub") unless $var_args; } elsif($arg !~ /r/ && $ValClass[$s] eq '\\') { logme('W', "Argument " . ($arg+1) . " to $ValPy[$pos] is a reference but it's value is modified by the sub") unless $var_args; } if($ValClass[$s] eq 'a' || $ValClass[$s] eq 'h') { $composite = 1; $composite_arg = $arg unless defined($composite_arg); } else { $composite = 0; } $s++ if($ValClass[$s] eq '\\'); # issue s185 $arg = int($arg); # issue s185: Remove the 'r' flag for 'reference' if(end_of_variable($s) != $e || $ValClass[$s] =~ /["df+!~(-]/) { logme('W', "Argument " . ($arg+1) . " to $ValPy[$pos] is not an lvalue and cannot be modified by calling the sub") unless $var_args; # Generate a Die if the value got changed by the sub, just like perl does if($e == $s && $ValClass[$s] =~ /["d]/) { $val = $ValPy[$s]; $valclass = $ValClass[$s]; $valperl = $ValPerl[$s]; } else { $val = $SUBSCRIPT_TEMP . $arg; $valclass = 's'; $valperl = "\$$val"; insert($e+1, ')', ')', ')'); insert($s, '=', '=', ':='); insert($s, 's', $valperl, $val); insert($s, '(', '(', '('); $end_pos += 4; } } insert($end_pos+1, ')', ')', ')'); if(defined $val) { # issue s241: could be 0!! insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, '"', 'Modification of a read-only value attempted', "'Modification of a read-only value attempted'"); insert($end_pos+1, '(', '(', '('); insert($end_pos+1, 'y', 'Die', 'Die'); $Pyf{_raise} = 1; insert($end_pos+1, 'f', '_raise', '_raise'); insert($end_pos+1, ':', ':', 'else'); } insert($end_pos+1, ')', ')', ')'); my $function = "_fetch_out_parameter"; if($composite) { $function = "_fetch_out_parameters"; if($composite_arg != 0) { insert($end_pos+1, 'd', $composite_arg, $composite_arg); insert($end_pos+1, ',', ',', ','); } undef $composite_arg; # We only fetch each array/hash once for(my $p = $e; $p >= $s; $p--) { insert($end_pos+1, $ValClass[$p], $ValPerl[$p], $ValPy[$p]); } } else { insert($end_pos+1, 'd', $arg, $arg); } insert($end_pos+1, '(', '(', '('); $Pyf{$function} = 1; insert($end_pos+1, 'f', $function, $function); if(defined $val) { # issue s241: could be 0!! insert($end_pos+1, '>', '==', '=='); insert($end_pos+1, $valclass, $valperl, $val); insert($end_pos+1, ':', 'if', 'if'); insert($end_pos+1, 'f', 'undef', 'None'); } elsif(!$composite) { insert($end_pos+1, '=', '=', ':='); for(my $p = $e; $p >= $s; $p--) { insert($end_pos+1, $ValClass[$p], $ValPerl[$p], $ValPy[$p]); } } insert($end_pos+1, '(', '(', '('); insert($end_pos+1, ',', ',', ','); } # insert($end_pos+1, ',', ',', ',') if(!$did_one && $start != 0); # Make it a tuple if it's not already and we put in [0] above insert($end_pos+1, ',', ',', ',') if(!$did_one); # Make it a tuple if it's not already since we put in [0] above $SubAttributes{$attr_sub_name}{out_parameters} = ['var'] if $var_args; # put it back insert($start, '(', '(', '('); $pos = matching_br($start); $change++; } my $p; my $arg; # issue s241 if(exists $SubAttributes{$CurSub} && exists $SubAttributes{$CurSub}{out_parameters}) { if(defined get_sub_attribute($CurSub, 'out_parameters')) { # issue s241 # Check for an assignment to an out parameter. Out parameters modified by functions like open/read are handled in sub function # See the similar code in Pythonizer.pm that's run during pass 1 if(($ValClass[$pos] eq 's' && $ValPerl[$pos] eq '$_' && (($pos-1 >= 0 && $ValClass[$pos-1] eq '^') || # handle ++$_[N] / --$_[N] ($pos+3 <= $#ValClass && $ValClass[$pos+1] eq '(' && ($p = matching_br($pos+1)) != -1 && # vararg $p+1 <= $#ValClass && ($ValClass[$p+1] eq '=' || $ValClass[$p+1] eq '^' || ($ValClass[$p+1] eq 'p' && $ValClass[$p+2] eq 'f' && $ValPerl[$p+2] =~ /^(?:re|tr)$/))) || ($pos+1 <= $#ValClass && ($ValClass[$pos+1] eq '=' || $ValClass[$pos+1] eq '^' || # handle $_[N]++ / $_[N]-- ($ValClass[$pos+1] eq 'p' && $ValClass[$pos+2] eq 'f' && $ValPerl[$pos+2] =~ /^(?:re|tr)$/)) # issue ddts, issue s151 ))) || ($ValClass[$pos] eq 's' && $ValType[$pos] eq 'ss' && ($ValPy[$pos] =~ /\[\d+\]$/ || # issue s241 (exists $SubAttributes{$CurSub} && exists $SubAttributes{$CurSub}{arg_copies} && # issue s241 exists $SubAttributes{$CurSub}{arg_copies}{$ValPerl[$pos]} && # issue s241 ($arg = $SubAttributes{$CurSub}{arg_copies}{$ValPerl[$pos]}) >= 0)) && # should always be true, but sets $arg (defined get_sub_attribute($CurSub, 'arg_copies') && exists ${get_sub_attribute($CurSub, 'arg_copies')}{$ValPerl[$pos]} && ($arg = ${get_sub_attribute($CurSub, 'arg_copies')}{$ValPerl[$pos]}) >= 0)) && # should always be true, but sets $arg (($pos-1 >= 0 && $ValClass[$pos-1] eq '^') || ($pos+1 <= $#ValClass && ($ValClass[$pos+1] eq '=' || $ValClass[$pos+1] eq '^' || # issue s184: handle $_[N]++ / $_[N]-- ($ValClass[$pos+1] eq 'p' && $ValClass[$pos+2] eq 'f' && $ValPerl[$pos+2] =~ /^(?:re|tr)$/)) ))) # issue s185: case 2 - $$i where $i is a copy of an argument, or $$_[N] (converted from ${$_[N]} by remove_dereferences) ) { # First split up any ++/--, and if we found any, we start over if($pos-1 >= 0 && $ValClass[$pos-1] eq '^') { handle_incr_decr(0, $pos-1, $#ValClass, 1); $pos = -1; $change++; next; } elsif($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '^') { handle_incr_decr(0, $pos+1, $#ValClass, 1); $pos = -1; $change++; next; } elsif($pos+3 <= $#ValClass && $ValClass[$pos+1] eq '(' && $ValClass[$p+1] eq '^') { handle_incr_decr(0, $p+1, $#ValClass, 1); $pos = -1; $change++; next; } if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '=') { if($ValPerl[$pos+1] ne '=') { # e.g. it's a +=, etc expand_augmented_assignment($pos, $pos+1, $#ValClass, 0); $change++; $pos = -1; next; } my $perl_arg_array = '@_'; # issue s185 my $python_arg_array = $PERL_ARG_ARRAY; # issue s185 if($ValPy[$pos] =~ /^$PERL_ARG_ARRAY\[(\d+)\]/ || defined $arg) { my $which_arg; if(defined $arg) { $which_arg = $arg; $perl_arg_array = 'undef'; # issue s185 $python_arg_array = 'None'; # issue s185 } else { $which_arg = $1; } $Pyf{_store_out_parameter} = 1; my $end_pos = end_of_assignment($pos, $pos+1); my $als = 0; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 $als = 0 if defined $arg; # arg does not need relocation insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', '', ", shifts=$als") if($als && !defined $arg); # issue s185 my $adj = 0; if(defined $arg) { # issue s185: If we have $$i = value, we still need to set i insert($end_pos+1, ')', ')', ')'); # issue s185 insert($pos+2, '=', '=', ':='); # issue s185 insert($pos+2, $ValClass[$pos], $ValPerl[$pos], $ValPy[$pos]); # issue s185 # issue s248: If we copy the $ValType, then we put in yet another _store_out_parameter in # handle_assignment_in_expression: though it doesn't hurt, it's not needed!! # issue s248: $ValType[$pos+2] = $ValType[$pos]; # issue s185 $ValType[$pos] = ''; # issue s248: it's gonna be replaced with a 'd' below insert($pos+2, '(', '(', '('); # issue s185 $adj = 3; } replace($pos+1, ',', ',', ','); replace($pos, 'd', $which_arg, $which_arg); insert($pos, ',', ',', ','); # issue s185 insert($pos, 'y', '@_', $PERL_ARG_ARRAY); # Make it 'y' so we don't try to splat it insert($pos, 'y', $perl_arg_array, $python_arg_array); # Make it 'y' so we don't try to splat it, issue s185 insert($pos, '(', '(', '('); insert($pos, 'f', '_store_out_parameter', '_store_out_parameter'); $pos += 4 + $adj; $change++; } } elsif($pos+3 <= $#ValClass && $ValClass[$pos+1] eq '(' && $ValClass[$p+1] eq '=') { if($ValPerl[$p+1] ne '=') { # e.g. it's a +=, etc expand_augmented_assignment($pos, $p+1, $#ValClass, 0); $change++; $pos = -1; next; } $Pyf{_store_out_parameter} = 1; my $end_pos = end_of_assignment($pos, $p+1); my $als = 0; # issue s184 # issue s241 $als = $SubAttributes{$CurSub}{arglist_shifts} if exists $SubAttributes{$CurSub}{arglist_shifts}; # issue s184 $als = get_sub_attribute($CurSub, 'arglist_shifts',0,0); # issue s241 insert($end_pos+1, ')', ')', ')'); insert($end_pos+1, 'y', '', ", shifts=$als") if($als); replace($p+1, ',', ',', ','); destroy($p, 1); # Remove the ']' replace($pos+1, ',', ',', ','); replace($pos, 'y', '@_', $PERL_ARG_ARRAY); insert($pos, '(', '(', '('); insert($pos, 'f', '_store_out_parameter', '_store_out_parameter'); # Handle the case of _args[_s0] = _args[_s0:=expr]... because we just changed the expression such # that _s0 is now referenced before it's set my $s = $pos+1; my $e = matching_br($s); my $eq = next_matching_token('=', $s+1, $e-1); if($eq != -1) { my $set = $eq-1; my $ref = $s+3; if($ValPy[$set] eq $ValPy[$ref]) { # Houston we have a problem! my $cl = $ValClass[$ref]; my $pr = $ValPerl[$ref]; my $py = $ValPy[$ref]; my $xb = $set-1; my $xe = matching_br($xb); say STDERR "fix_out_parameters: moving RHS assignment to second arg set=$set, ref=$ref, xb=$xb, xe=$xe for =|$TokenStr|= @ValPerl" if($debug >= 5); destroy($ref, 1); $xb--; $xe--; for(my $p=$xe; $p>=$xb; ) { # Move the expression over to the second arg insert($ref, $ValClass[$p], $ValPerl[$p], $ValPy[$p]); $xb++; $xe++; } replace($xb, $cl, $pr, $py); destroy($xb+1, ($xe-$xb)); } } $pos += 2; $change++; } # The pf case is handled in regex_and_translate } } } say STDERR "After fix_out_parameters =|$TokenStr|= ValPerl = @ValPerl, ValPy = @ValPy" if($change && $debug); return $change; } sub end_of_call # issue s184 # Given the pos of a sub call, return where the call ends # If this call doesn't have parens, this will insert them! # If called in list context, will return both where the call ends and the adjustment factor (if any) { my $pos = shift; if($pos+2 <= $#ValClass && $ValClass[$pos+1] eq 'D' && $ValClass[$pos+2] eq 'i') { # issue s248 $pos += 2; } if($pos+1 <= $#ValClass && $ValClass[$pos+1] eq '(' && $ValPerl[$pos+1] eq '(') { # Easy case my $end = matching_br($pos+1); return $pos if $end < 0; return $end; } # Hard case - non-parenthesized sub call my $end_pos = $#ValClass; if($pos != 0 && $ValClass[$pos-1] eq '(') { $end_pos = matching_br($pos-1)-1; $end_pos = $#ValClass if $end_pos < 0; } my $p; if($pos+1 <= $#ValClass && index('HI=?:./*>0o,', $ValClass[$pos+1]) != -1) { # issue s244 $p = $pos; # issue s244 } else { # issue s244 for($p = $pos+1; $p <= $end_pos; $p++) { if($ValClass[$p] eq 'f') { $p = end_of_function($p); } elsif($ValClass[$p] eq ',') { ; # next argument } elsif($ValClass[$p] eq ')') { $p--; last; } elsif($ValClass[$p] eq ';') { $p--; last; } else { $p = end_of_variable($p); } } $p = $#ValClass if $p > $#ValClass; # issue s244 } # issue s244 insert($p+1, ')', ')', ')'); # issue s244 insert($pos+1, '(', '(', '('); # issue s244 return $p+2; return $p; # issue s244 } sub get_arg_start_end # issue s184 # Given the pos of a sub call and the argument number (counting from 1), # return where that argument starts and ends in the sub call { my $pos = shift; my $limit = shift; my $arg = shift; my $start = $pos+1; my $end_pos = $limit; if($ValClass[$start] eq '(' && $ValPerl[$start] eq '(') { $start++; $end_pos--; } my $cur_arg = 1; my ($result_s, $result_e); for(my $p = $start; $p <= $end_pos; $p++) { $result_s = $p if($cur_arg == $arg && !$result_s); if($ValClass[$p] eq 'f') { $p = end_of_function($p); } elsif($ValClass[$p] eq ',') { $cur_arg++; if($result_s) { $result_e = $p-1; last; } } else { $p = end_of_variable($p); } } $result_e = $end_pos unless $result_e; if($debug) { no warnings 'uninitialized'; say STDERR "get_arg_start_end($pos, $limit, $arg) = ($result_s, $result_e)"; } return ($result_s, $result_e); } sub call_has_out_parameters # issue s184 { my $pos = shift; # Point to the 'i' of the call # issue s241 if($pos != 0 && $ValClass[$pos-1] eq 'D') { # Method call # We set the '->' prefix in expand_extras above for potential method definitions - NOTE we don't disambiguate them if several packages # define the same methods (but we should try to) # issue s241 return 1 if exists $SubAttributes{'->'.$ValPy[$pos]} && exists $SubAttributes{'->'.$ValPy[$pos]}{out_parameters}; # issue s241 } else { # issue s241 return 1 if exists $SubAttributes{$ValPy[$pos]} && exists $SubAttributes{$ValPy[$pos]}{out_parameters}; # issue s241 } return 1 if defined get_sub_attribute_at($pos, 'out_parameters'); return 0; } sub end_of_assignment # issue s184 # Return the end of this assignment expression { my $start = shift; my $eq = shift; my $end_pos = $#ValClass; if($start-1 >= 0 && $ValClass[$start-1] eq '(') { # if the whole assignment is wrapped in parens, stop at the end of the parens $end_pos = matching_br($start-1); } my $pos; my $adj; # issue s248 for($pos = $eq+1; $pos <= $end_pos; $pos++) { if(index(',Ano', $ValClass[$pos]) != -1) { # Lower precedence return $pos-1; } elsif($ValClass[$pos] eq 'f') { $pos = end_of_function($pos); } elsif($ValClass[$pos] eq 'i') { $pos = end_of_call($pos); # issue s248 } elsif($ValClass[$pos] eq ')') { return $pos-1; } elsif($ValClass[$pos] eq ';') { return $pos-1; } else { $pos = end_of_variable($pos); } } return $pos-1; } sub array_or_array_func { # issue s202 # Return 1 if this is an array or a function returning an array my $pos = shift; return 1 if $ValClass[$pos] eq 'a'; return 1 if $ValClass[$pos] eq 's' && defined $ValType[$pos] && $ValType[$pos] eq '@s'; # issue s321 if($ValClass[$pos] eq 'f') { return 1 if &Pythonizer::func_type($ValPerl[$pos], $ValPy[$pos]) eq 'a'; } return 0; } sub expand_range { # issue s206 # If this range can be expanded, then return an array with it (minus the first and last elements), else return an empty array my $cur_pos = shift; my @result = (); my $pre; if($cur_pos != 0 && $cur_pos+1 <= $#ValClass && $ValClass[$cur_pos-1] eq '"' && $ValClass[$cur_pos+1] eq '"' && length($ValPy[$cur_pos-1]) == length($ValPy[$cur_pos+1]) && substr($ValPy[$cur_pos-1],0,1) ne 'f' && substr($ValPy[$cur_pos+1],0,1) ne 'f' && ($pre = substr($ValPy[$cur_pos-1],0,length($ValPy[$cur_pos-1])-2)) eq substr($ValPy[$cur_pos+1],0,length($ValPy[$cur_pos+1])-2) && (ord(substr($ValPy[$cur_pos+1],-2,1)) - ord(substr($ValPy[$cur_pos-1],-2,1))) < 256) { my $ch0 = substr($ValPy[$cur_pos-1],0,1); for(my $i = ord(substr($ValPy[$cur_pos-1],-2,1))+1; $i < ord(substr($ValPy[$cur_pos+1],-2,1)); $i++) { my $ch = chr($i); $ch = "\\$ch" if($ch eq $ch0); # escape it push @result, ($pre . $ch . $ch0); } } return @result; } sub is_scalar_out_parameter # issue scalar ref # Is the given token a scalar out parameter? { my $pos = shift; return 0 if $ValClass[$pos] ne 's'; return 0 if $ValType[$pos] eq 'ss'; # Can't be $$scalar_out_param my $cs = &Perlscan::cur_sub(); # Our $CurSub is '__main__' in the _f142 s///e sub # issue s241 return 0 unless exists $SubAttributes{$cs}; # issue s241 return 0 unless exists $SubAttributes{$cs}{arg_copies}; # issue s241 return 0 unless exists $SubAttributes{$cs}{out_parameters}; # issue s241 return 0 unless exists $SubAttributes{$cs}{arg_copies}{$ValPerl[$pos]}; # issue s241 my $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$pos]}; # issue s241 return 1 if grep {$_ eq ($arg.'r') || $_ eq 'var'} @{$SubAttributes{$cs}{out_parameters}}; return 0 unless defined get_sub_attribute($cs, 'arg_copies'); return 0 unless defined get_sub_attribute($cs, 'out_parameters'); return 0 unless exists ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$pos]}; my $arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$pos]}; return 1 if grep {$_ eq ($arg.'r') || $_ eq 'var'} @{get_sub_attribute($cs, 'out_parameters')}; return 0; } sub parent_is_class # issue s18 # Is any parent of this package a class? { my $package = shift; my $key = $package . '.ISA'; # issue s18 if(exists $SpecialVarsUsed{$key}) { # issue s18 my $parents = $SpecialVarsUsed{$key}{__main__}; $parents =~ s/\.split\(\)$//; $parents = unquote_string($parents); foreach my $parent (split ' ', $parents) { $parent =~ tr/:/./s; $parent =~ tr/'/./s; return 1 if exists $SpecialVarsUsed{'bless'}{$parent}; return 1 if parent_is_class($parent); } } return 0; } sub push_ISA # issue s18 # Push a value to the @ISA { my $unquoted_value = shift; $package = escape_keywords($CurPackage, 1); gen_statement("$package.ISA_a.append('$unquoted_value')"); } sub in_sub_in_eval_at # issue s243 # Are we in an anonymous sub that's defined in the current eval? # (If so, we need to use a normal "return", not an eval return.) { my $eval_level = shift; return 0 if scalar(@Perlscan::nesting_stack) == 0; for my $ndx (reverse 0 .. $#Perlscan::nesting_stack) { my $top = $Perlscan::nesting_stack[$ndx]; return 1 if(exists $top->{in_eval_at_stack_level} && $top->{in_eval_at_stack_level} == $eval_level); } return 0; } sub add_outer_loops_to_assignment_map_if_need_be # issue s252 # If we have outer foreach loops and we are implicitly modifying their loop counters, add in that code # to $foreach_modified_counter_assignment_map{$.} { $foreach_modified_counter_assignment_map{$.} =~ /^([A-Za-z0-9_]+)\[$INDEX_TEMP\d+\]/; my $inner_array = $1; for(my $i = $#Perlscan::nesting_stack-1; $i >= 0; $i--) { if($Perlscan::nesting_stack[$i]->{type} eq 'foreach' && $Perlscan::line_contains_for_loop_with_modified_counter{$Perlscan::nesting_stack[$i]->{lno}} && exists $foreach_modified_counter_assignment_map{$Perlscan::nesting_stack[$i]->{lno}}) { my $outer_assign = $foreach_modified_counter_assignment_map{$Perlscan::nesting_stack[$i]->{lno}}; $outer_assign =~ /^([A-Za-z0-9_]+)(\[$INDEX_TEMP\d+\]) = ([A-Za-z0-9_]+)$/m; my $outer_scalar = $3; if($outer_scalar eq $inner_array) { $foreach_modified_counter_assignment_map{$.} .= "\n$1$2 = $3"; } else { last; } $inner_array = $1; } } } sub interpolate_hashrefs # issue s316 # Interpolate all the hashrefs in this expression by inserting appropriate double-splat '**' operators where they need be { for(my $pos = 0; $pos <= $#ValClass; $pos++) { if($ValClass[$pos] eq '(' && $ValPerl[$pos] eq '{') { my $close = matching_br($pos); next if $close < 0; next if $pos != 0 && index('DfsahG)', $ValClass[$pos-1]) != -1; # Skip if a hash{key} -or- map{block} -or- array[ndx]{key} -or- hashref->{key} my $adjust = interpolate_hashref($pos, $close); $pos = $close + $adjust; } } } sub interpolate_hashref # issue s316 # Interpolate a hashref by inserting appropriate double-splat '**' operators where they need be # Argument - position of the '{' # Returns the adjustment factor { my $pos = shift; my $close = shift; my $adjust = 0; debug_start_end ">interpolate_hashref($pos, $close) =|%|= ValPy = @ValPy", $pos, $close; my $did_something = 0; for( my $i=$pos+1; $i<$close; $i++ ){ my $sep = next_same_level_tokens(',)', $i, $close); if($ValClass[$sep] eq ',' && $ValClass[$i] eq 'f') { # Make sure the comma doesn't belong to the function my $eof = end_of_function($i); if($eof > $sep) { $sep = next_same_level_tokens(',)', $eof+1, $close); # if it does, then find the next one } } if($sep-$i <= 1) { if($ValClass[$i] eq 'a') { # We hit an array replace($i, 'y', $ValPerl[$i], "**{$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)}"); $did_something = 1; } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '@s') { # We hit an arrayref if(&Pythonizer::vartype($i, $CurSub) =~ /^a/) { replace($i, 'y', $ValPerl[$i], "**{$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)}"); } else { replace($i, 'y', $ValPerl[$i], "**({$ValPy[$i]"."[$INDEX_TEMP]:".$ValPy[$i]."[$INDEX_TEMP+1] for $INDEX_TEMP in range(0,len(".$ValPy[$i]."),2)} if $ValPy[$i] is not None else {})"); } $did_something = 1; } elsif($ValClass[$i] eq 'h') { # We got a hash $ValPy[$i] = '**' . $ValPy[$i]; # Double splat it $did_something = 1; } elsif($ValClass[$i] eq 's' && defined $ValType[$i] && $ValType[$i] eq '%s') { # We got a hashref if(&Pythonizer::vartype($i, $CurSub) =~ /^h/) { $ValPy[$i] = '**' . $ValPy[$i]; # Double splat it } else { $ValPy[$i] = "**($ValPy[$i] if $ValPy[$i] is not None else {})"; # Double splat it } $did_something = 1; } } elsif($i+1 <= $#ValClass && $ValClass[$i+1] eq 'A') { # key => ; } else { # issue 126: have expression my $add_right_paren = 0; my $t = &Pythonizer::expr_type($i, $sep-1, $CurSub); if($t =~ /^a/) { # Handle array function like map, and do ** _list_to_hash(expr) $Pyf{_list_to_hash} = 1; insert($i, '(', '(', '('); insert($i, 'f', '_list_to_hash', '_list_to_hash'); insert($i, '*', '**', '**'); $i += 3; $sep += 3; $close += 3; $adjust += 3; $add_right_paren = 1; } elsif($t =~ /^h/) { # Generate **({key=>val}) or **({key=>val} if Condition else {}) insert($i, '*', '**', '**'); $i++; $sep++; $close++; $adjust++; if($ValPerl[$i] eq '(' && $ValClass[$i+1] eq '(') { # If we have 2 parens, the first of which being an actual '(' $ValPy[$i+1] = '{'; # Force the second one to be a hash my $m = matching_br($i+1); $ValPy[$m] = '}'; if($m+1 < $#ValClass && $ValPerl[$m+1] eq '?') { # If we have a ? : operation, change both potential results to a hash my $colon = next_same_level_token(':', $m+2, $#ValClass); if($colon != -1 && $ValClass[$colon+1] eq '(') { $ValPy[$colon+1] = '{'; $m = matching_br($colon+1); $ValPy[$m] = '}'; } } } else { if($ValPerl[$i] eq '(') { $ValPy[$i] = '{'; my $m = matching_br($i); $ValPy[$m] = '}'; } # Handle ? : without extra parens my $qm = next_same_level_token(':', $i, $sep-1); my $colon = next_same_level_token(':', $qm+1, $sep-1); if($qm != -1 && $colon != -1 && $ValClass[$colon+1] eq '(') { $ValPy[$colon+1] = '{'; $ValPy[matching_br($colon+1)] = '}'; } insert($i, '(', '(', '('); $i++; $sep++; $close++; $adjust++; $add_right_paren = 1; } } else { # issue s327 # If we have a mixed expression that includes a ? :, handle each term # of the ? : separately and do the combined right thing # At this point we have expr1 if cond else expr2 my $colon1 = next_same_level_token(':', $i, $sep-1); if($colon1 != -1 && $ValPerl[$colon1] eq '?') { my $colon2 = next_same_level_token(':', $colon1+1, $sep-1); if($colon2 != -1) { my $typ1 = &Pythonizer::expr_type($i, $colon1-1, $CurSub); my $typ2 = &Pythonizer::expr_type($colon2+1, $sep-1, $CurSub); if($typ1 =~ /^a/ || $typ2 =~ /^a/) { if($typ1 =~ /^h/) { insert($colon1, ')', ']', ']'); insert($i, '(', '[', '['); $sep += 2; $close += 2; $adjust += 2; } elsif($typ2 =~ /^h/) { insert($sep, ')', ']', ']'); insert($colon2+1, '(', '[', '['); $sep += 2; $close += 2; $adjust += 2; } $Pyf{_list_to_hash} = 1; insert($i, '(', '(', '('); insert($i, 'f', '_list_to_hash', '_list_to_hash'); insert($i, '*', '**', '**'); $sep += 3; $close += 3; $adjust += 3; $add_right_paren = 1; } } } } if($add_right_paren) { insert($sep, ')', ')', ')'); $sep++; $close++; $adjust++; } $i = $sep; } } if($did_something || $adjust) { # Make sure we generate the proper type of brackets $ValPy[$pos] = '{'; $ValPy[$close] = '}'; } say STDERR " $#ValClass; return 1 if $ValClass[$eov+1] eq '='; return 1 if $ValClass[$eov+1] eq 'p'; return 0; } sub gen_A_B_A_fix # issue s360 # If we are importing from a package name like A.B.A, or A.A, then python creates a global variable A # which steps on our ability to reference builtins.A, leading to a run-time crash. We mitigate this # problem by deleting the global variable A in this case only. { my $package = shift; my $suffix = shift; my $ldot = index($package, '.'); return if $ldot < 0; my $rdot = rindex($package, '.'); my $left = substr($package, 0, $ldot); my $right = substr($package, $rdot+1); return if $left ne $right; my $parent = substr($package, 0, $rdot); # This doesn't fix it for Date.Manip.Date!! gen_chunk("(globals()).pop('$left', None)$suffix"); gen_statement("if '$parent' in sys.modules and hasattr(sys.modules['$parent'], '$right'):$suffix"); correct_nest(1,1); gen_statement("delattr(sys.modules['$parent'], '$right')$suffix"); correct_nest(-1,-1); } __DATA__ def PostIncr(name, local={}): #Equivalent to name++ if name in local: local[name]+=1 return local[name]-1 globals()[name]+=1 return globals()[name]-1 def PostDecr(name, local={}): #Equivalent to name-- if name in local: local[name]-=1 return local[name]-1 globals()[name]-=1 return globals()[name]-1