forked from softpano/pythonizer
-
Notifications
You must be signed in to change notification settings - Fork 1
Expand file tree
/
Copy pathPythonizer.pm
More file actions
5179 lines (5000 loc) · 267 KB
/
Pythonizer.pm
File metadata and controls
5179 lines (5000 loc) · 267 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
package Pythonizer;
#
## ABSTRACT: Supplementary subroutines for pythonizer
## Includes logging subroutine: logme, abend, out, getopts and helpme
## Copyright Nikolai Bezroukov, 2019-2020.
## Licensed under Perl Artistic license
# Ver Date Who Modification
# ===== ========== ======== ==============================================================
# 00.00 2019/10/10 BEZROUN Initial implementation. Limited by the rule "one statement-one line"
# 00.10 2019/11/19 BEZROUN The prototype is able to process the minimal test (with multiple errors) but still
# 00.11 2019/11/19 BEZROUN autocommit now allow to save multiple modules in addition to the main program
# 00.12 2019/12/27 BEZROUN Notions of ValType was introduced in preparation of introduction of pre_processor.pl version 0.2
# 00.20 2020/02/03 BEZROUN getline was moved from pythonyzer.
# 00.30 2020/08/05 BEZROUN preprocess_line was folded into getline.
# 00.40 2020/08/17 BEZROUN getops is now implemented in Softpano.pm to allow the repretion of option letter to set the value of options ( -ddd)
# 00.50 2020/08/24 BEZROUN Option -p added
# 00.60 2020/08/25 BEZROUN __DATA__ and __END__ processing added
# 00.61 2020/08/25 BEZROUN POD processing added Option - r (refactor) added
# 00.70 2020/09/03 BEZROUN Stack manipulation defined more completly and moved from main script to Pythonizer.om
# 00.80 2020/09/17 BEZROUN Basic global varibles detection added. Global statement now is generated for each subroutine
# 00.90 2020/10/12 BEZROUN Option -l added. Output format improved. Many small fixes
use v5.10.1;
use warnings;
use strict 'subs';
use feature 'state';
use Perlscan qw(tokenize $TokenStr @ValClass @ValPerl @ValPy @ValType %token_precedence %SPECIAL_FUNCTION_MAPPINGS destroy insert append replace %FuncType %PyFuncType %UseRequireVars %UseRequireOptionsPassed %UseRequireOptionsDesired special_code_block_name); # SNOOPYJC
use Softpano qw(abend logme out getopts standard_options);
use Pyconfig; # issue 32
use Pass0 qw(pass_0); # SNOOPYJC
use Data::Dumper; # SNOOPYJC
# issue s70 use open ':std', IN=>':crlf', IO=>':utf8'; # SNOOPYJC
use open ':std', IN=>':crlf'; # issue s70
use File::Path qw(make_path); # issue s23
use File::Basename; # issue s23
use File::Spec::Functions qw(catfile); # issue s23
require Exporter;
use Storable qw(dclone); # issue s18
use FixLatin qw(fix_latin); # issue s70
use Encode qw/decode find_encoding/; # issue s70
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@ISA = qw(Exporter);
@EXPORT = qw(preprocess_line correct_nest getline prolog output_line %LocalSub %PotentialSub %UseSub %GlobalVar %InitVar %VarType 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 %PackageDef 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
our ($IntactLine, $output_file, $NextNest,$CurNest, $line, $fname, @orig_ARGV);
our ($f_encoding, $f_encodobj, $f_decodobj, $e_option); # issue s70
$IntactLno = 0; # issue s6
$IntactEndLno = 0; # issue s6
$TraceIntactLine = 0; # issue s6
# issue 32 $::TabSize=3;
$::TabSize=$TABSIZE; # issue 32
$::breakpoint=0;
$breakpoint=99999; # SNOOPYJC: for -B (first pass breakpoint)
$NextNest=$CurNest=0;
# issue 32 $MAXNESTING=9;
$VERSION = '0.80';
$refactor=0; # option -r flag (invocation of pre-pythonizer)
sub PASS_0 { 0 } # SNOOPYJC: Pre-pass to determine -m or -M
sub PASS_1 { 1 } # SNOOPYJC: The first pass: determining global/local/my vars and variable types
sub PASS_2 { 2 } # SNOOPYJC: The second pass: Code generation
$PassNo=PASS_1; # SNOOPYJC: EXTERNAL VAR: Current pass
$InLineNo=0; # counter, pointing to the current like in InputTextA during the first pass
%LocalSub=(); # list of local subs
%UseSub=(); # SNOOPYJC: list of subs declared on "use subs", issue s3: also imported subs are added here
%UsePackage=(); # issue s209: list of all packages mentioned in use XXX::YYY with their line numbers
%RequirePackage=(); # issue s18: list of all packages mentioned in require XXX::YYY with their line numbers
%PotentialSub=(); # SNOOPYJC: List of potential sub calls
%GlobalVar=(); # generated "external" declaration with the list of global variables.
%InitVar=(); # SNOOPYJC: generated initialization
%SubAttributes=(); # SNOOPYJC: Map of sub to set of attributes. Current ones: modifies_arglist, blesses, overloads
# issue 32 $maxlinelen=188;
$maxlinelen=$MAXLINELEN;
$GeneratedCode=0; # issue 96: used to see if we generated any real code between { and }
%Packages = (); # SNOOPYJC: Set of all python names of packages defined in this file (determined on the first pass)
%PackageDef = (); # issue s18: Set of all python names of packages defined in this file (determined on the first pass) with the line they are defined on
@Packages = (); # SNOOPYJC: List of all python names of packages defined in this file in the order declared
$CurPackage = undef; # SNOOPYJC
$mFlag = 0; # SNOOPYJC
$MFlag = 0; # SNOOPYJC
%anonymous_subs_used = (); # issue s26
$pass_0_ran = 0; # issue s63: set to 1 if we ran pass_0
$deferred_nesting_top = undef; # issue s252
$StartingBeginLno = undef; # issue s325
#
#::prolog -- Decode parameter for the pythonizer. all parameters are exported
#
sub prolog
{
my $dir = shift; # issue 55
my $log_dir = shift; # issue 64
my $script_name = shift; # issue 64
my $banner_msg = shift; # issue 64
my $log_retention = shift; # issue 64
# SNOOPYJC getopts("AThd:v:r:b:t:l:",\%options);
@orig_ARGV = @ARGV; # SNOOPYJC
# NOTE: Remember to add new flags to Pass0.PM (# pragma pythonizer), the help with ## at the start of pythonizer, and the readme/documentation!
getopts("fFNyYauUkKnmMAVThsSpPd:v:r:b:B:t:l:R:o:e:",\%options); # SNOOPYJC, issue s23, issue s19, issue s87, issue s132, issue s70, issue s284
#
# Three standard options -h, -v and -d
#
standard_options(\%options);
Softpano::banner($log_dir, $script_name, $banner_msg, $log_retention); # issue 64
#
# Custom options specific for the application
#
if( exists $options{'r'} ){
if( $options{'r'} eq ''){
# issue 55 $refactor='./pre_pythonizer.pl';
$refactor="$dir/pre_pythonizer.pl"; # issue 55
}else{
if( -f $options{'r'} ){
$refactor=$options{'r'};
}else{
logme('S',"The Script $options{'r'} does not exist (may be you need to specify path to the file)\n");
exit 255;
}
}
unless (-x $refactor ){
logme('S',"File $options{'r'} specifed in option -r is not executable\n");
exit 255;
}
}
if( exists $options{'b'} ){
unless ($options{'b'}){
logme('S',"Option -b should have a numeric value. There is no default.");
exit 255;
}
if( $options{'b'}>0 && $options{'b'}<9000 ){
$::breakpoint=$options{'b'};
($::debug) && logme('W',"Breakpoint set to line $::breakpoint");
}else{
logme('S',"Wrong value of option -b ( breakpoint): $options('b')\n");
exit 255;
}
}
if( exists $options{'B'} ){ # SNOOPYJC
unless ($options{'B'}){
logme('S',"Option -B should have a numeric value. There is no default.");
exit 255;
}
if( $options{'B'}>0 && $options{'B'}<9000 ){
$breakpoint=$options{'B'};
($::debug) && logme('W',"Breakpoint set to line $breakpoint");
}else{
logme('S',"Wrong value of option -B ( breakpoint): $options('B')\n");
exit 255;
}
}
if( exists $options{'t'} ){
$options{'t'}=1 if $options{'t'} eq '';
if( $options{'t'}>1 && $options{'t'}<=10 ){
$::TabSize=$options{'t'};
}else{
logme('S',"Range for options -t (tab size) is 2-10. You specified: $options('t')\n");
exit 255;
}
}
if( exists $options{'w'} ){
if($options{'w'}>=100 && $options{'w'}<=256 ){
$maxlinelen=$options{'w'};
if( $maxlinelen//2==1 ){
$maxlinelen-=1;
}
}else{
logme('W',"Incorrect value for length of the line in protocol of tranlation: $options{'w'}\n Minimum is 100. Max is 256. Default value 188 is assumed \n");
}
}
# SNOOPYJC - add more options
if( exists $options{'R'} ) {
if($options{R} eq ':all') {
$::remap_all = 1;
} elsif($options{R} eq ':global') {
$::remap_global = 1;
} elsif($options{R} eq ':none') {
$::remap_global = 0;
$::remap_all = 0;
} else {
my @remaps = split /,/, $options{R};
%::remap_requests = map { $_ => 1 } @remaps;
$::remap_global = 0;
$::remap_all = 0;
}
}
if( exists $options{'l'} ){
if($options{'l'}>=48 && $options{'l'}<=1000 ){
$::black_line_length=int($options{'l'});
}else{
logme('W',"Incorrect value for length of the line generated by the black formatter $options{'l'}\n Minimum is 48. Max is 1000. Default value $::black_line_length is assumed \n");
}
}
if( exists $options{'T'} ) {
$::traceback = 1;
}
if( exists $options{'n'} ) {
$::trace_run = 1;
}
if( exists $options{'A'} ) {
$::autodie = 1;
}
if( exists $options{'m'} ) {
$mFlag = 1;
$::implicit_global_my = 1;
}
if( exists $options{'M'} ) {
$MFlag = 1;
}
if( exists $options{'s'} ) {
$::pythonize_standard_library = 1;
}
if( exists $options{'S'} ) {
$::pythonize_standard_library = 0;
}
if( exists $options{'p'} ) {
$::import_perllib = 1;
}
if( exists $options{'P'} ) {
$::import_perllib = 0;
}
if( exists $options{'V'} ) { # issue s132
print ucfirst($::SCRIPT_NAME) . " $::VERSION\n";
exit(0);
}
if( exists $options{'N'} ) {
$::autovivification = 0;
}
if( exists $options{'k'} ) {
$::black = 1;
}
if( exists $options{'K'} ) {
$::black = 0;
}
if( exists $options{'u'} ) {
$::replace_usage = 1;
}
if( exists $options{'U'} ) {
$::replace_usage = 0;
}
if( exists $options{'o'} ) { # issue s23
$::output_dir = $options{'o'}; # issue s23
} # issue s23
if( exists $options{'a'} ) { # issue s19
$::gen_author = 1; # issue s19
} # issue s19
if( exists $options{'y'} ) { # issue s87
$::replace_run = 1;
}
if( exists $options{'Y'} ) { # issue s87
$::replace_run = 0;
}
if( exists $options{'e'} ) { # issue s70
$e_option = $options{'e'}; # issue s70
} # issue s70
if( exists $options{'f'} ) { # issue s284
$::fully_qualify_calls = 1;
}
if( exists $options{'F'} ) { # issue s274
$::fully_qualify_calls = 0;
}
#
# Application arguments
#
if( scalar(@ARGV)==1 ){
$fname=$ARGV[0];
unless( -f $fname ){
abend("Input file $fname does not exist");
}
# issue s245 $source_file=substr($ARGV[0],0,rindex($ARGV[0],'.'));
my $p = rindex($ARGV[0], '.'); # issue s245
$source_file = ($p < 0 ? $ARGV[0] : substr($ARGV[0],0,$p)); # issue s245
if(defined $::output_dir) { # issue s23
make_path($::output_dir); # issue s23
$source_file = catfile($::output_dir, basename($source_file)); # issue s23 - also used for the .data file
} # issue s23
$output_file=$source_file.'.py';
out("Results of transcription are written to the file $output_file");
if( $refactor ){
unless( -f "$fname.bak" ){
`cp -p "$fname" "$fname.bak" && tr -d "\r" < "$fname.bak" > "$fname"`; # just in case
}
out("Option -r (refactor) was specified. file refactored using $refactor as the first pass over the source code");
`pre_pythonizer -v 0 $fname`;
}
#$fsize=-s $fname;
#if ($fsize<10){
#abend("The size of the file is $fsize. Nothing to do. Exiting");
#}
unless( -r $fname ){
abend("File does not have read permissions for the user");
}
# issue stdin open (STDIN, '<',$fname) || die("Can't open $fname for reading $!");
open (SYSIN, '<',$fname) || die("Can't open $fname for reading $!"); # issue stdin
$. = 0;
}else{
abend("Input file should be supplied as the first argument");
}
if( $debug){
print STDERR "ATTENTION!!! Working in debugging mode debug=$debug\n";
}
shift @ARGV; # SNOOPYJC: Don't read from both the file and STDIN if we hit the end
$PassNo=PASS_0;
$pass_0_ran = 0; # issue s63
if(!$mFlag && !$MFlag) {
my $pass_0_result;
if($fname =~ /\.pm$/) {
$pass_0_result = 0; # use -M for perl modules
} else {
&Perlscan::initialize();
$pass_0_result = pass_0();
correct_nest(0,0);
$pass_0_ran = 1; # issue s63
}
if(defined $pass_0_result) {
if($pass_0_result) { # -m
$::implicit_global_my = 1;
}
}
# issue stdin close STDIN;
# issue stdin open (STDIN, '<',$fname) || die("Can't open $fname for reading");
open (SYSIN, '<',$fname) || die("Can't open $fname for reading"); # issue stdin
$. = 0;
}
$PassNo=PASS_1;
if($::implicit_global_my == 0) {
$MAIN_MODULE = $DEFAULT_PACKAGE;
}
if($::import_perllib) {
&Perlscan::init_perllib();
}
out("=" x 121,"\n");
out(" LNO|NST|ERR|Python code... Perl original...");
&Perlscan::initialize();
get_globals();
# issue stdin close STDIN;
# issue stdin open (STDIN, '<',$fname) || die("Can't open $fname for reading");
open (SYSIN, '<',$fname) || die("Can't open $fname for reading"); # issue stdin
$. = 0;
$PassNo=PASS_2;
$IntactLno = $IntactEndLno = 0; # issue s6
$IntactLine = ''; # issue s6
open(SYSOUT,'>',$output_file) || die("Can't open $output_file for writing");
if(!defined $::fully_qualify_calls) { # issue s284
if($::implicit_global_my) { # issue s284
$::fully_qualify_calls = 0; # issue s284
} else { # issue s284
$::fully_qualify_calls = 1; # issue s284
} # issue s284
}
return;
} # prolog
%VarType = ('sys.argv'=>{__main__=>'a of m'}, # issue 41, issue s359: with bad index it could be None
'sys.argv[1:]'=>{__main__=>'a of m'}, # issue s359: this is @ARGV
'os.name'=>{__main__=>'S'},
EVAL_ERROR=>{__main__=>'S'},
"${PERL_SORT_}a"=>{__main__=>'s'},
"${PERL_SORT_}b"=>{__main__=>'s'},
# issue s90 'os.environ'=>{__main__=>'h of s'}); # SNOOPYJC: {varname}{sub} = type (a, h, s, I, S, F, N, u, m)
'os.environ'=>{__main__=>'h of m'}); # SNOOPYJC: {varname}{sub} = type (a, h, s, I, S, F, N, u, m), issue s90: with a bad key, it could be None
%NeedsInitializing = (); # SNOOPYJC: {sub}{varname} = type
# SNOOPYJC: initialized means it is set before it's being used
%initialized = (__main__=>{'sys.argv'=>'a of m', # issue s359: bad index, it could be None
'sys.argv[1:]'=>'a of m', # issue s359
'os.name'=>'S',
EVAL_ERROR=>'S',
'__dict__'=>'h',
# issue s90 'os.environ'=>'h of s'}); # {sub}{varname} = type
'os.environ'=>'h of m'}); # {sub}{varname} = type, issue s90: with a bad key, it could be None
%VarSubMap=(); # issue 108: matrix var/sub that allows to create list of global for each sub
sub get_globals
#
# This suroutine creates two hashes
# 1. hash $GlobalVar with declations of global variables used in particula surtutine
# 2. %LocalSub; -- list of subs in the program
#
{
#
# Arrays and hashes for varible analyses
#
my ( $varname, $subname, $CurSubName,$i,$k,$var_usage_in_subs);
my %DeclaredVarH=(); # list of my varibles in the current subroute
# issue 108 my %VarSubMap=(); # matrix var/sub that allows to create list of global for each sub
$CurSubName='__main__';
$LocalSub{'__main__'}=1;
$VarSubMap{"${PERL_SORT_}a"}{$CurSubName}='+'; # SNOOPYJC
$VarSubMap{"${PERL_SORT_}b"}{$CurSubName}='+'; # SNOOPYJC
foreach my $g (keys %GLOBALS) { # SNOOPYJC
$VarSubMap{$g}{$CurSubName}='+'; # SNOOPYJC
} # SNOOPYJC
for my $g (keys %GLOBAL_TYPES) { # SNOOPYJC
my $t = $GLOBAL_TYPES{$g};
$initialized{__main__}{$g} = $t;
$VarType{$g}{__main__} = $t;
if($::import_perllib) {
$initialized{__main__}{$PERLLIB.'.'.$g} = $t;
$VarType{$PERLLIB.'.'.$g}{__main__} = $t;
}
}
my $PriorExprType = undef; # SNOOPYJC: used to type the function result
my $got_first_line = 0; # issue s63
while(1){
if( scalar(@Perlscan::BufferValClass)==0 ){
$line=getline(); # get the first meaningful line, skipping commenets and POD
if(!defined $line && $::saved_eval_tokens) { # issue 42: done scanning the eval string
$::saved_eval_tokens = undef;
$. = $::saved_eval_lno;
for my $t (@::saved_eval_buffer) {
getline($t);
}
@::saved_eval_buffer = (); # issue s240
next;
}
last unless(defined($line));
if( $::debug==2 && $.== $::breakpoint ){
say STDERR "\n\n === Line $. Perl source: $line ===\n";
$DB::single = 1;
}
say STDERR "\n === Pass1: Line_$. Perl source:".$line."===" if($::debug);
if( $.>=$breakpoint ){
logme('S', "First pass breakpoint was triggered at line $. in Pythonizer.pm");
$DB::single = 1;
}
# issue s311 if(defined $::saved_sub_tokens && $::nested_sub_at_level < 0) { # SNOOPYJC
if(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); # issue s252
} else { # issue s252
say STDERR "Continuing to scan tokens after handling sub with line=$line" if($::debug >= 3);
&Perlscan::tokenize($line, 1); # continue where we left off
}
} else {
Perlscan::tokenize($line);
}
}else{
#process token buffer -- Oct 9, 2020 --NNB
@ValClass=@Perlscan::BufferValClass;
$TokenStr=join('',@ValClass);
@ValPerl=@Perlscan::BufferValPerl;
@ValPy=@Perlscan::BufferValPy;
}
unless(defined($ValClass[0])){
next;
}
my $pragma_pythonizer_line = 0; # issue s325
if((!$pass_0_ran) && $#ValClass >= 3 && $ValClass[0] eq 'i' && $ValPerl[0] eq 'pragma' && $ValPerl[1] eq 'pythonizer') { # issue s63
if($got_first_line == 0 || ($ValPerl[2] eq 'no' && $ValPerl[3] eq 'convert')) { # issue s64
my $uim = &Pass0::handle_pragma_pythonizer();
$::implicit_global_my = $uim if(defined $uim);
$pragma_pythonizer_line = 1; # issue s325
} else {
logme('W',"# pragma pythonizer is only supported at start of source file if -m or -M are passed")
}
}
if($got_first_line == 0 && $ValClass[0] eq 'k' &&
$#ValClass == 1 && $ValClass[1] eq 'i' && $ValPerl[1] =~ /^__BEGIN__/) { # issue s325
$StartingBeginLno = $.; # issue s325
say STDERR "StartingBeginLno = $." if $::debug; # issue s325
} # issue s325
if(!defined $CurPackage && ($ValClass[0] ne 'c' || $ValPerl[0] ne 'package')) { # SNOOPYJC: Set the default package unless
# we start the file with a "package" stmt
if(!$implicit_global_my) {
push @Packages, $DEFAULT_PACKAGE unless(exists $Packages{$DEFAULT_PACKAGE});
$Packages{$DEFAULT_PACKAGE} = 1;
$CurPackage = $DEFAULT_PACKAGE;
}
}
fix_scalar_context(); # issue 37
if( $ValClass[0] eq 't' && ($ValPerl[0] eq 'my' || $ValPerl[0] eq 'state') ){ # issue s306: Treat 'state' like 'my' in a sub
for($i=1; $i<=$#ValClass; $i++ ){
last if( $ValClass[$i] eq '=' );
if( $ValClass[$i] =~/[sah]/ ){
check_ref($CurSubName, $i); # SNOOPYJC
# issue s155 $DeclaredVarH{$ValPy[$i]}=1; # this hash is need only for particular sub
$DeclaredVarH{$ValPy[$i]}=1 # this hash is need only for particular sub
unless($CurSubName eq '__main__' || special_code_block_name($CurSubName)); # issue s155: 'my' is like 'myfile' in BEGIN, etc subs, issue s306
}
}
my $possible_parameter = 0; # issue s185
if( $i<$#ValClass ){
for( $k=$i+1; $k<@ValClass; $k++ ){
if( $ValClass[$k]=~/[sah]/ ){
$possible_parameter = 1 if $ValPerl[$k] eq '@_'; # issue s185
$possible_parameter = 1 if $ValPerl[$k] eq '$_' && $ValPy[$k] =~ /\[\d+\]$/; # issue s185
check_ref($CurSubName, $k); # SNOOPYJC
next if exists($DeclaredVarH{$ValPy[$k]});
next if( defined($ValType[$k]) && $ValType[$k] eq 'X' && !exists($GLOBALS{$ValPy[$k]})); # SNOOPYJC
$VarSubMap{$ValPy[$k]}{$CurSubName}='+';
} elsif($ValClass[$k] eq 'f' && ($ValPerl[$k] eq 'shift' || $ValPerl[$k] eq 'pop') && # SNOOPYJC
($k == $#ValClass || $ValPerl[$k+1] eq '@_' || $ValClass[$k+1] !~ /[ahfi]/)) { # SNOOPYJC
# issue s84 $SubAttributes{$CurSubName}{modifies_arglist} = 1; # SNOOPYJC: This sub shifts it's args
my $cs = &Perlscan::cur_sub(); # issue s184
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1; # SNOOPYJC: This sub shifts it's args, issue s84
set_sub_attribute($cs, 'modifies_arglist', 1); # SNOOPYJC: This sub shifts it's args, issue s84
if($ValPerl[$k] eq 'shift') { # issue s184
# issue s241 $SubAttributes{$cs}{arglist_shifts}++; # issue s184
set_sub_attribute($cs, 'arglist_shifts', get_sub_attribute($cs, 'arglist_shifts',0,0) + 1); # issue s184, issue s241
} # issue s184
$possible_parameter = 1; # issue s185
}
} # for
if($possible_parameter && $we_are_in_sub_body) { # issue s185
track_potential_sub_parameter_copies(); # issue s185
} # issue s185
}
# SNOOPYJC }elsif( $ValPerl[0] eq 'sub' && $#ValClass==1 ){
}elsif($ValPerl[0] eq 'sub' && 1 <= $#ValClass && exists $::nested_subs{$ValPerl[1]}) { # issue 78: don't switch to nested sub
$LocalSub{$ValPy[1]}=1;
$::nested_sub_at_level = $Perlscan::nesting_level;
push @::nested_sub_at_levels, $::nested_sub_at_level; # issue s241
}elsif( $ValPerl[0] eq 'sub' && $#ValClass >= 1) { # SNOOPYJC: handle sub xxx() (with parens)
$CurSubName=$ValPy[1];
my $dx = rindex($CurSubName, '.'); # issue s320
if($dx != -1) { # issue s320
$LocalSub{$CurSubName}=1; # issue s320
my $packname = &Perlscan::unescape_keywords(substr($CurSubName,0,$dx)); # issue s320
$CurSubName = substr($CurSubName, $dx+1); # issue s320
if(!exists $UsePackage{$packname} && !exists $RequirePackage{$packname} && !exists $PYTHON_PACKAGES_SET{$packname} && !exists $Packages{$packname}) { # issue s320
$Packages{$packname} = 2; # issue s320: 2 means we reference it but don't define it here
}
}
$initialized{$CurSubName}{$PERL_ARG_ARRAY} = 'a'; # SNOOPYJC
$LocalSub{$CurSubName}=1;
$LocalSub{"$CurPackage.$CurSubName"}=1 if $ValPy[1] eq $CurSubName; # issue s3, issue s320
%DeclaredVarH=(); # this is the list of my varible for given sub; does not needed for any other sub
$we_are_in_sub_body=1; # issue 45
if($::debug > 3) {
say STDERR "get_globals: switching to '$CurSubName' at line $.";
}
# issue s155: can have sub nested in BEGIN: correct_nest(0,0); # issue 45
} elsif($ValClass[0] eq 'c' && $ValPerl[0] eq 'package' && $#ValClass >= 1) { # SNOOPYJC: Keep track of packages
$Packages{$ValPy[1]} = 1; # SNOOPYJC
$PackageDef{$ValPy[1]} = $. unless exists $PackageDef{$ValPy[1]}; # SNOOPYJC, issue s18
push @Packages, $ValPy[1]; # SNOOPYJC
$CurPackage = $ValPy[1]; # SNOOPYJC
}elsif( $ValClass[0] eq '{') { # issue 45
correct_nest(1); # issue 45
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;
$deferred_nesting_top = undef;
}
}elsif( $ValClass[0] eq '}' && $#ValClass == 0) { # issue 45
correct_nest(-1); # issue 45
if($we_are_in_sub_body && $NextNest == 0) { # issue 45
# SNOOPYJC: At the end of the function, if we are going to insert a "return N" statement
# in ::finish(), then set the type of the function, else set it to 'm' for mixed.
if($::debug > 3) {
say STDERR "get_globals: switching back to 'main' at line $.";
}
my $typ = 'm';
$typ = $PriorExprType if(defined $PriorExprType);
$VarType{$CurSubName}{__main__} = merge_types($CurSubName, '__main__', $typ, undef, 'a'); # issue s356
my $pkg = 'sys.modules["__main__"]';
$pkg = $CurPackage if(defined $CurPackage);
$VarType{"$pkg.$CurSubName"}{__main__} = $VarType{$CurSubName}{__main__};
$we_are_in_sub_body = 0; # issue 45
$CurSubName='__main__'; # issue 45
} # issue 45
}else{
my $p; # issue s184
my $cs = &Perlscan::cur_sub(); # issue s184, issue s185
for( $k=0; $k<@ValClass; $k++ ){
if( $ValClass[$k]=~/[sahG]/ ){ # issue s248: add 'G' to handle *db_connect::new = sub {...};
check_ref($CurSubName, $k); # SNOOPYJC
if($k != 0 && $ValClass[$k-1] eq 't' && $ValPerl[$k-1] eq 'my') { # SNOOPYJC e.g. for(my $i=...)
$DeclaredVarH{$ValPy[$k]} = 1;
}
next if exists($DeclaredVarH{$ValPy[$k]});
next if( defined($ValType[$k]) && $ValType[$k] eq 'X' && !exists($GLOBALS{$ValPy[$k]})); # SNOOPYJC
next if($ValPy[$k] eq ''); # Undefined special var
$VarSubMap{$ValPy[$k]}{$CurSubName}='+';
if( $ValPy[$k] =~/[\[\(]/ && $ValPy[$k] !~ /^len\(/ && $ValPy[$k] ne 'globals()' &&
$ValPy[$k] !~ /\.__dict__$/ &&
substr($ValPy[$k],0,5) ne '(len(' && # issue 14: $#x => (len(x)-1)
$ValType[$k] ne 'ss' && # issue s185
$ValType[$k] ne '%s' && # issue s215
$ValType[$k] ne '@s' && # issue s243
substr($ValPy[$k],0,4) ne 'sys.'){ # Issue 13
$InLineNo = $.;
say "=== Pass 1 INTERNAL ERROR in processing line $InLineNo Special variable is $ValPerl[$k] as $ValPy[$k], k=$k, our ValType=$ValType[$k]";
$DB::single = 1;
}
} elsif($ValClass[$k] eq 'k' && $ValPerl[$k] eq 'use' && $k+1 <= $#ValClass && $ValPerl[$k+1] eq 'parent') { # issue s18
my $t = 'a of S';
my $pyISA = &Perlscan::escape_keywords($CurPackage,1) . '.' . &Perlscan::remap_conflicting_names('ISA', '@', '', 1);
$t = merge_types($pyISA, '__main__', $t, undef, 'a'); # issue s356
$VarType{$pyISA}{__main__} = $t;
$VarSubMap{$pyISA}{__main__}='+';
$NeedsInitializing{__main__}{$pyISA} = $t if(!exists $initialized{__main__}{$pyISA});
} elsif($ValClass[$k] eq 'f' && ($ValPerl[$k] eq 'shift' || $ValPerl[$k] eq 'pop') && # SNOOPYJC
($k == $#ValClass || $ValPerl[$k+1] eq '@_' || $ValClass[$k+1] !~ /[ahfi]/)) { # SNOOPYJC
# issue s84 $SubAttributes{$CurSubName}{modifies_arglist} = 1; # SNOOPYJC: This sub shifts it's args
my $cs = &Perlscan::cur_sub();
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1; # SNOOPYJC: This sub shifts it's args, issue s84
set_sub_attribute($cs, 'modifies_arglist', 1); # SNOOPYJC: This sub shifts it's args, issue s84
if($ValPerl[$k] eq 'shift') { # issue s184
# issue s241 $SubAttributes{$cs}{arglist_shifts}++; # issue s184
set_sub_attribute($cs, 'arglist_shifts', get_sub_attribute($cs, 'arglist_shifts',0,0) + 1); # issue s184, issue s241
} # issue s184
} elsif($ValClass[$k] eq 'f' && ($ValPerl[$k] eq 'push' || $ValPerl[$k] eq 'unshift') &&
(($#ValClass >= $k+1 && $ValPerl[$k+1] eq '@_') ||
($k+2 <= $#ValClass && $ValPerl[$k+1] eq '(' && $ValPerl[$k+2] eq '@_'))) { # issue s53, issue s220
# issue s84 $SubAttributes{$CurSubName}{modifies_arglist} = 1; # issue s53
my $cs = &Perlscan::cur_sub();
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1; # issue s53, issue s84
set_sub_attribute($cs, 'modifies_arglist', 1); # SNOOPYJC: This sub shifts it's args, issue s84
if($ValPerl[$k] eq 'unshift') { # issue s184
# issue s241 $SubAttributes{$cs}{arglist_shifts}--; # issue s184
set_sub_attribute($cs, 'arglist_shifts', get_sub_attribute($cs, 'arglist_shifts',0,0) - 1); # issue s184, issue s241
} # issue s184
} elsif((($ValClass[$k] eq 'q' && $ValPy[$k] =~ /\b$DEFAULT_VAR\b/)) || # issue s151
($ValClass[$k] eq 'f' && ($ValPerl[$k] eq 're' &&
($ValPy[$k] =~ /\b$DEFAULT_VAR\b/ || $ValPy[$k] =~ /^\.replace/)) ||
# issue s151 ($ValPerl[$k] eq 'tr' && ($k == 0 || $ValClass[$k-1] ne '~'))) { # issue s8: sets the $DEFAULT_VAR
($ValPerl[$k] eq 'tr' && ($k == 0 || $ValClass[$k-1] ne 'p')))) { # issue s8: sets the $DEFAULT_VAR, issue s151
my $t = merge_types($DEFAULT_VAR, $CurSubName, 'S'); # issue s104
$VarType{$DEFAULT_VAR}{$CurSubName} = $t; # issue s8, issue s104
$VarSubMap{$DEFAULT_VAR}{$CurSubName}='+'; # issue s103
$NeedsInitializing{$CurSubName}{$DEFAULT_VAR} = $t if(!exists $initialized{$CurSubName}{$DEFAULT_VAR}); # issue s8, issue s104
if(($ValPy[$k] =~ /^re\.sub/ ||
$ValPy[$k] =~ /^\.replace/) && # issue s344
&Perlscan::is_loop_ctr('$_')) { # issue s252
&Perlscan::set_loop_ctr_mod('$_'); # issue s252
} # issue s252
} elsif($ValClass[$k] eq 'f' && arg_type($ValPerl[$k], $ValPy[$k], 0, 0) eq 'H' && $#ValClass > $k) { # issue s101: handle file handles across subs
my $h = $k+1;
$h++ if($ValClass[$h] eq '(');
if($ValClass[$h] eq 'i' && index($ValPy[$h],'.') < 0) { # Do this for bareword file handles, but not STDxx
$VarSubMap{$ValPy[$h]}{$CurSubName}='+';
}
if($ValPerl[$k] eq 'open') { # issue s285: Handle open as dup - reference the FH being duped
if($h+2 < $#ValClass && $ValClass[$h+2] eq '"' && $ValPerl[$h+2] =~ /^\>\&(\w+)/) {
my $name = $1; # e.g. open(STDERR, ">&SAVERR")
$VarSubMap{$name}{$CurSubName}='+' unless exists $Perlscan::keyword_tr{$name};
} elsif($h+4 < $#ValClass && $ValClass[$h+4] eq 'i' && index($ValPy[$h+4],'.') < 0) { # e.g. open(STDERR, ">&", SAVERR)
$VarSubMap{$ValPy[$h+4]}{$CurSubName}='+';
}
}
} elsif($ValClass[$k] eq 'f' &&
((($ValPerl[$k] eq 'chomp' || $ValPerl[$k] eq 'chop' || $ValPerl[$k] eq 'eval' || $ValPerl[$k] eq 'split' ||
$ValPerl[$k] eq 'defined' || $ValPerl[$k] eq 'mkdir' || $ValPerl[$k] eq 'ord' || $ValPerl[$k] eq 'chr' ||
$ValPerl[$k] eq 'quotemeta' || $ValPerl[$k] eq 'oct' || $ValPerl[$k] eq 'hex' || $ValPerl[$k] eq 'require' ||
$ValPerl[$k] eq 'stat' || $ValPerl[$k] eq 'lstat' || $ValPerl[$k] eq 'reverse') && ($#ValClass == $k || end_of_function($k) == $k)) ||
($ValPerl[$k] eq 'split' && $#ValClass == $k+1) ||
(($ValPerl[$k] eq 'print' || $ValPerl[$k] eq 'printf') && ($#ValClass == $k || ($#ValClass == $k+1 && $ValClass[$k+1] eq 'i'))))) { # issue s103
my $t = 'S'; # issue s104
$t = 'm' if $ValPerl[$k] eq 'defined'; # issue s104
$t = merge_types($DEFAULT_VAR, $CurSubName, $t); # issue s104
$VarType{$DEFAULT_VAR}{$CurSubName} = $t; # issue s104
$VarSubMap{$DEFAULT_VAR}{$CurSubName}='+'; # issue s103
$NeedsInitializing{$CurSubName}{$DEFAULT_VAR} = $t if(!exists $initialized{$CurSubName}{$DEFAULT_VAR}); # issue s103, issue s104
if($ValPerl[$k] eq 'chomp' || $ValPerl[$k] eq 'chop') { # issue s252: They modify $_
if(&Perlscan::is_loop_ctr('$_')) { # issue s252
&Perlscan::set_loop_ctr_mod('$_'); # issue s252
} # issue s252
} # issue s252
}
if($ValClass[$k] eq '(' && $k+1 <= $#ValClass && $ValClass[$k+1] eq ')' && $ValPerl[$k] eq '(' &&
($k == 0 || ($ValClass[$k-1] eq 'k' && $ValPerl[$k-1] eq 'return'))) { # issue s254
# Here we are (potentially) returning () - make this an implicit wantarray, since we
# need to return either an empty array or None, based on the calling context
my $cs = &Perlscan::cur_sub(); # issue s254
if($cs ne '__main__') { # issue s254
$Perlscan::SpecialVarsUsed{'wantarray'}{$cs} = 2; # issue s254
set_sub_attribute($cs, 'wantarray', 2); # issue s254
say STDERR "Setting 'wantarray' on $cs based on return of ()" if $::debug;
} # issue s254
} # issue s254
if($ValClass[$k] eq 'i' && ($k == 0 || $ValPerl[$k-1] eq 'return' || $ValPerl[$k-1] eq 'goto') && $we_are_in_sub_body && $k+3 <= $#ValClass &&
$ValClass[$k+1] eq '(' && $ValPerl[$k+2] eq '@_' && $ValClass[$k+3] eq ')' &&
defined get_sub_attribute_at($k,'wantarray')) { # issue s241: goto &mysub; -or- return &mysub;
my $cs = &Perlscan::cur_sub(); # issue s241
set_sub_attribute($cs, 'wantarray', 1); # issue s241
set_sub_attribute($cs, 'wantarray_inherited_from', $ValPy[$k]); # issue s241
# issue s282 } elsif($ValClass[$k] eq 'i' && $k == 3 && $ValClass[0] eq 'G' && $ValClass[1] eq '=' && $ValClass[2] eq '\\' &&
# issue s282 (defined get_sub_attribute_at($k, 'wantarray') || defined get_sub_attribute_at($k, 'out_parameters'))) { # issue s241: *x = \&mysub;
# issue s282 clone_sub_attributes($ValPy[$k], $ValPy[0]); # issue s241
# issue s282 if(exists $LocalSub{$ValPy[$k]}) {
# issue s282 $LocalSub{$cs} = $LocalSub{$ValPy[$k]};
# issue s282 }
} elsif($ValClass[$k] eq 'i' && $ValClass[0] eq 'G' && $ValClass[1] eq '=' && $ValClass[$k-1] eq '\\') { # issue s241: *x = \&mysub; -or- *x = *y = \&mysub
for(my $j = 0; $j < $k; $j++) { # issue s282 - see also test issue 115
if($ValClass[$j] eq 'G' && $ValClass[$j+1] eq '=') {
clone_sub_attributes($ValPy[$k], $ValPy[$j]);
if(exists $LocalSub{$ValPy[$k]}) {
$LocalSub{$ValPy[$j]} = $LocalSub{$ValPy[$k]};
}
}
}
}
my $outs; # issue s252
if($ValClass[$k] eq 'f' && exists $PYF_OUT_PARAMETERS{$ValPy[$k]}) { # issue s252
$p = get_function_out_parameter($k); # issue s252
if(defined $p && &Perlscan::is_loop_ctr($ValPerl[$p])) { # issue s252
&Perlscan::set_loop_ctr_mod($ValPerl[$p]); # issue s252
} # issue s252
if(defined $p) {
my $typ = arg_type_from_pos($p); # issue s252
my $t = merge_types($ValPy[$p], $CurSubName, $typ, $p); # issue s252, issue s256
$VarType{$ValPy[$p]}{$CurSubName} = $t; # issue s252
if(exists $NeedsInitializing{$CurSubName}{$ValPy[$p]}) { # issue s252
$NeedsInitializing{$CurSubName}{$ValPy[$p]} = $t; # issue s252
} # issue s252
}
} elsif($ValClass[$k] eq 'i' && ($k == 0 || $ValPerl[$k-1] ne 'sub') && exists $LocalSub{$ValPy[$k]}) { # issue s252
# Is this a sub call that can change the loop counter?
my $lc = &Perlscan::get_loop_ctr();
if(defined $lc) {
my @lcs = split(/,/, $lc);
for $lc (@lcs) {
if($lc eq '$_') {
# VarSubMap isn't set for the default var because it has ValType==X - the
# default variable isn't global in Pythonizer, so we don't assume it's changed
# over a sub call.
#if(exists $VarSubMap{$DEFAULT_VAR}{$ValPy[$k]}) {
# &Perlscan::set_loop_ctr_mod('$_');
#}
} else {
my $py = &Perlscan::perl_name_to_py($lc);
if(exists $VarSubMap{$py}{$ValPy[$k]} && &Perlscan::loop_ctr_type($lc, $py) ne 'my') {
&Perlscan::set_loop_ctr_mod($lc);
}
}
}
}
}
if($ValClass[$k] eq 'i' && ($k == 0 || $ValPerl[$k-1] ne 'sub') && $#ValClass != $k &&
defined ($outs = get_sub_attribute_at($k, 'out_parameters'))) { # issue s252
my $adj = 0;
if($k == 0 || $ValClass[$k-1] ne 'D') {
;
} else {
$adj = 1; # Allow for the first arg being $self
}
my $ep = &::end_of_call($k);
foreach my $arg (@$outs) {
no warnings 'numeric'; # handle 1r, etc
my ($s, $e) = &::get_arg_start_end($k, $ep, $arg+1-$adj);
my $r = '';
$r = 'r' if($arg =~ /r/);
if($s && ($s == $e || ($r eq 'r' && $ValClass[$s] eq '\\' && $e-$s == 1))) {
if(&Perlscan::is_loop_ctr($ValPerl[$e])) {
&Perlscan::set_loop_ctr_mod($ValPerl[$e]); # issue s252
}
}
}
} # issue s252
if($ValClass[$k] eq 'f' && $we_are_in_sub_body && $#ValClass != $k && exists $PYF_OUT_PARAMETERS{$ValPy[$k]} &&
($p = function_modifies_sub_arg($k))) { # issue s183
my $cs = &Perlscan::cur_sub();
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1 if $ValPerl[$p] eq '$_' || $ValPerl[$p] eq '@_'; # issue s183: function modifies argument, issue s185
set_sub_attribute($cs, 'modifies_arglist', 1) if $ValPerl[$p] eq '$_' || $ValPerl[$p] eq '@_'; # issue s183: function modifies argument, issue s185
my $arg;
if($ValPy[$p] =~ /\[(\d+)\]/) { # issue s184
my $als = 0; # issue s184
# issue s241 $als = $SubAttributes{$cs}{arglist_shifts} if exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arglist_shifts}; # issue s184
$arg = $1; # issue s241
$als = get_sub_attribute($cs, 'arglist_shifts',0,0); # issue s241
# issue s241 $arg = $1 + $als; # issue s185
$arg += $als; # issue s241
$arg .= 'r' if($ValType[$p] eq 'ss'); # issue s185
} elsif($ValType[$p] eq 'ss') { # issue s185: 'ss' means it's a '$$'
# issue s241 $arg = $SubAttributes{$cs}{arg_copies}{$ValPerl[$p]};
$arg = ${get_sub_attribute($cs, 'arg_copies')}{$ValPerl[$p]}; # issue s241
$arg .= 'r'; # Reference
} else { # issue s184: varargs
$arg = 'var'; # issue s185
}
set_out_parameter($cs, $arg); # issue s184, issue s185
# issue s184 logme('W', "Sub arg modified by this $ValPerl[$k] call will not change the argument passed in python");
} elsif($ValClass[$k] eq 'i' && ($k == 0 || $ValPerl[$k-1] ne 'sub') && $we_are_in_sub_body && $#ValClass != $k &&
# issue s241 ((($k == 0 || $ValClass[$k-1] ne 'D') && exists $SubAttributes{$ValPy[$k]}{out_parameters}) ||
# issue s241 ($k != 0 && $ValClass[$k-1] eq 'D' && exists $SubAttributes{'->'.$ValPy[$k]}{out_parameters}))) { # issue s184
defined get_sub_attribute_at($k, 'out_parameters')) { # issue s184, issue s241
# This is a call to a sub that modified it's arguments - propagate that up to this sub if appropriate
my $adj = 0;
if($k == 0 || $ValClass[$k-1] ne 'D') {
# issue s241 $outs = $SubAttributes{$ValPy[$k]}{out_parameters};
$outs = get_sub_attribute($ValPy[$k], 'out_parameters'); # issue s241
} else {
# issue s241 $outs = $SubAttributes{'->'.$ValPy[$k]}{out_parameters};
$outs = get_sub_attribute($ValPy[$k], 'out_parameters', 1); # issue s241: method call
$adj = 1; # Allow for the first arg being $self
}
my $cs = &Perlscan::cur_sub();
my $als = 0; # issue s184
# issue s241 $als = $SubAttributes{$cs}{arglist_shifts} if exists $SubAttributes{$cs} && exists $SubAttributes{$cs}{arglist_shifts}; # issue s184
$als = get_sub_attribute($cs, 'arglist_shifts',0,0); # issue s241
my $ep = &::end_of_call($k);
foreach my $arg (@$outs) {
no warnings 'numeric'; # handle 1r, etc
my ($s, $e) = &::get_arg_start_end($k, $ep, $arg+1-$adj);
if($s && $s == $e) {
my $r = ''; # issue s185
$r = 'r' if($arg =~ /r/); # issue s185
if($ValClass[$s] eq 's' && $ValPerl[$s] eq '$_' && $ValPy[$s] =~ /^$PERL_ARG_ARRAY/) { # issue s184
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1; # SNOOPYJC: This sub mods it's args, issue s84
set_sub_attribute($cs, 'modifies_arglist', 1); # SNOOPYJC: This sub mods it's args, issue s84, issue s241
if($ValPy[$s] =~ /\[(\d+)\]/) { # issue s184
set_out_parameter($cs, ($1+$als).$r); # issue s184, issue s185
} else { # issue s184: varargs
set_out_parameter($cs, 'var'); # issue s184
}
} elsif($ValClass[$s] eq 'a' && $ValPerl[$s] eq '@_') { # issue s241
# issue s241 $SubAttributes{$cs}{modifies_arglist} = 1; # issue s241 This sub mods it's args, issue s84
# issue s241 $SubAttributes{$cs}{out_parameters} = dclone($outs); # issue s241
set_sub_attribute($cs, 'modifies_arglist', 1); # SNOOPYJC: This sub mods it's args, issue s84, issue s241
set_sub_attribute($cs, 'out_parameters', dclone($outs)); # issue s241
set_out_parameter($cs, $arg); # issue s241: This is just used to set the -> and the package:: entries
last; # We copied the whole thing so we don't need to do anything else
}
}
}
} elsif($k != 0 && $ValClass[$k] eq 'c' && $k+2 <= $#ValClass &&
((($ValPerl[$k] eq 'while' || $ValPerl[$k] eq 'until') && $ValClass[$k+1] eq '(' && ($ValClass[$k+2] eq 'j' || $ValClass[$k+2] eq 'g')) ||
($ValPy[$k] eq 'for' && for_loop_uses_default_var($k)))) { # issue s235: Handle while/until/for loop as stmt modifier
$VarSubMap{$DEFAULT_VAR}{$CurSubName}='+'; # issue s235
my $t = merge_types($DEFAULT_VAR, $CurSubName, 'm'); # issue s235 it's a string but it could also be undef at EOF
$VarType{$DEFAULT_VAR}{$CurSubName} = $t; # issue s235
$initialized{$CurSubName}{$DEFAULT_VAR} = $t unless $NeedsInitializing{$CurSubName}{$DEFAULT_VAR}; # issue s103, issue s104
} elsif($ValClass[$k] eq 'f' && $ValPerl[$k] eq 'bless') { # issue s317
# If we bless an object into a named package, make sure that package is marked as a class
# so we pass is_class=True to _init_package
my $lst = $k+1;
my $end = $#ValClass;
if($ValPerl[$lst] eq '(') {
$end = matching_br($lst);
$lst++;
}
my $comma = next_same_level_token(',', $lst, $end);
if($comma != -1 && $comma+1 <= $end && ($ValClass[$comma+1] eq '"' || $ValClass[$comma+1] eq 'i')) {
$Perlscan::SpecialVarsUsed{'bless'}{$ValPerl[$comma+1]} = 1;
}
}
if($ValClass[$k] eq 'q' && $ValPy[$k] =~ /\b$DEFAULT_MATCH:=/) { # issue s323
$VarSubMap{$DEFAULT_MATCH}{$CurSubName}='+'; # issue s323
}
} # for
if(scalar(@ValClass) > 0 && $ValClass[0] eq 'k' && $ValPerl[0] eq 'return') { # SNOOPYJC: return statement
$typ = 'm';
if(scalar(@ValClass) > 1) {
my $end = $#ValClass;
my $c; # Look for return N if(...);
$end = $c-1 if(($c = next_same_level_token('c', 1, $end)) != -1);
$typ = expr_type(1, $end, $CurSubName);
}
$VarType{$CurSubName}{__main__} = merge_types($CurSubName, '__main__', $typ, undef, 'a'); # issue s356
} elsif(($#ValClass >= 2 && ($ValPerl[0] eq 'while' || $ValPerl[0] eq 'until') && $ValClass[1] eq '(' && ($ValClass[2] eq 'j' || $ValClass[2] eq 'g')) ||
($#ValClass >= 2 && $ValPy[0] eq 'for' && for_loop_uses_default_var(0))) { # issue s103, issue s235
$VarSubMap{$DEFAULT_VAR}{$CurSubName}='+'; # issue s103
my $t = merge_types($DEFAULT_VAR, $CurSubName, 'm'); # issue s104: it's a string but it could also be undef at EOF
$VarType{$DEFAULT_VAR}{$CurSubName} = $t; # issue s104
$initialized{$CurSubName}{$DEFAULT_VAR} = $t unless $NeedsInitializing{$CurSubName}{$DEFAULT_VAR}; # issue s103, issue s104
}
} # statements
# SNOOPYJC: Capture the prior expr type in case of implicit function return (as done by pythonizer::finish())
# If we determine it's a mixed type ('m'), then stop checking
if(scalar(@ValClass) == 0) { # SNOOPYJC
$PriorExprType = 'm'; # We couldn't have inserted a "return" here
} elsif(exists $VarType{$CurSubName} && exists $VarType{$CurSubName}{__main__} && $VarType{$CurSubName}{__main__} eq 'm') { # SNOOPYJC: not worth checking
$PriorExprType = 'm';
} else {
$typ = 'm'; # mixed by default
if((index('"(dsahf-', $ValClass[0]) >= 0)) { # Expression
$typ = expr_type(0, $#ValClass, $CurSubName);
} elsif(($p = index($TokenStr, '=')) > 0 && $ValClass[0] ne 't') { # Assignment
$typ = expr_type($p+1, $#ValClass, $CurSubName);
} elsif($ValClass[0] eq 'k' && scalar(@ValClass) > 1) { # Return value
$typ = expr_type(1, $#ValClass, $CurSubName);
}
$PriorExprType = $typ; # SNOOPYJC
}
# SNOOPYJC: Capture some potential sub calls for use/require statement support
# The code here mirrors that of pythonizer main pass where it checks for $LocalSub{...}.
if($TokenStr =~ m'^t[ahsG]=i$') {
$PotentialSub{$ValPy[3]} = 1;
trash_global_types($ValPy[3]) if !exists $LocalSub{$ValPy[3]}; # issue bootstrap
} elsif($TokenStr =~ m'^h=\(') {
my $comma_flip = 0;
for(my $i=3; $i<$#ValPy; $i++) {
if($comma_flip == 1 && $ValClass[$i] eq 'i') {
$PotentialSub{$ValPy[$i]} = 1;
trash_global_types($ValPy[$i]) if !exists $LocalSub{$ValPy[$i]}; # issue bootstrap
} elsif($ValPy[$i] eq ',') {
$comma_flip = 1-$comma_flip;
}
}
} elsif($TokenStr eq 'c(i)') {
$PotentialSub{$ValPy[2]} = 1;
trash_global_types($ValPy[2]) if !exists $LocalSub{$ValPy[2]}; # issue bootstrap
} elsif($ValPerl[0] ne 'use' && $ValPerl[0] ne 'require' && $ValPerl[0] ne 'no') {
for(my $i=0; $i <= $#ValClass; $i++) {
if($ValClass[$i] eq 'i') {
next if($i+1 <= $#ValClass && $ValClass[$i+1] =~ /[AD]/); # key=>, method->
if(($i+1 > $#ValClass || $ValPerl[$i+1] eq '(') || # f(...
($i == 0 || ($ValPerl[$i-1] ne '{' && $ValClass[$i-1] ne 'D'))) { # not {key..., not ->method
$PotentialSub{$ValPy[$i]} = 1;
trash_global_types($ValPy[$i]) if !exists $LocalSub{$ValPy[$i]}; # issue bootstrap
}
}
}
} elsif($#ValClass >= 2 && $ValPerl[0] eq 'use' && $ValPerl[1] eq 'subs') {
my @subs = ();
for(my $i=2; $i<=$#ValClass; $i++) {
if($ValClass[$i] eq '"') { # Plain String
push @subs, $ValPy[$i];
} elsif($ValClass[2] eq 'q') {
if(index(q('"), substr($ValPy[$i],0,1)) >= 0) {
push @subs, $ValPy[$i];
} else {
push @subs, map {'"'.$_.'"'} split(' ', $ValPy[$i]); # qw(...) on use stmt doesn't generate the split
}
}
}
for my $sub (@subs) {
$UseSub{&::unquote_string($sub)} = 1;
}
} elsif($#ValClass >= 1 && $ValPerl[0] eq 'use' && $ValClass[1] eq 'i') { # issue s209
$UsePackage{$ValPy[1]} = $. unless exists $UsePackage{$ValPy[1]}; # issue s209, issue s18
} elsif($#ValClass >= 1 && $ValPerl[0] eq 'require' && $ValClass[1] eq 'i') { # issue s18: Distinguish require from use as require is dynamic
$RequirePackage{$ValPy[1]} = $. unless exists $RequirePackage{$ValPy[1]}; # issue s18
}
if($TokenStr =~ m'C"' && !$::saved_eval_tokens) { # issue 42 eval '...'
# Parse the eval string into tokens
my $pos = $-[0];
my $ch0;
if($ValPerl[$pos] eq 'eval' && (($ch0 = substr($ValPy[$pos+1],0,1)) eq "'" || $ch0 eq '"')) {
$::saved_eval_tokens = 1; # We don't need to actually save the code, just set a flag for getline
$::saved_eval_lno = $.;
my $t;
while(($t = getline())) {
push @::saved_eval_buffer, $t;
}
my $text;
if(substr($ValPy[$pos+1],0,3) eq '"""') {
$text = substr($ValPy[$pos+1],3,length($ValPy[$pos+1])-6);
} else {
$text = substr($ValPy[$pos+1], 1, length($ValPy[$pos+1])-2);
}
my @lines = split(/^/m, $text);
say STDERR "On line $., pushing " . scalar(@lines) . " lines + { }" if($::debug);
getline('{'); # Push this one to the regular buffer (to help us count lines easier)
for my $ln (@lines) {
getline($ln, 1); # Push to special_buffer
}
getline('}', 1); # Push to special_buffer
}
} elsif(!$::saved_eval_tokens) { # issue 78: e flag on regex
for(my $i = 0; $i <= $#ValClass; $i++) {
if($ValClass[$i] eq 'f' && $ValPerl[$i] eq 're' && $ValPy[$i] =~ /re\.E/) {
if($ValPy[$i] =~ /re\.E\|re\.E/) {
logme('W',"Regex substitute 'ee' flag is not supported");
}
$ValPy[$i] =~ /,e'''(.*)'''/s;
my $expr = $1;
# issue s26 my $subname = "$ANONYMOUS_SUB$.";
$VarSubMap{$DEFAULT_MATCH}{$CurSubName}='+'; # issue s323
$VarSubMap{$DEFAULT_MATCH}{__main__}='+'; # issue s323
my $subname = new_anonymous_sub(); # issue s26
$::nested_subs{$subname} = "$DEFAULT_MATCH";
$::saved_eval_tokens = 1;
$::saved_eval_lno = $.;
my $t;
while(($t = getline())) {
push @::saved_eval_buffer, $t;
}
my @lines = split(/^/m, $expr);
say STDERR "On line $., pushing " . scalar(@lines) . " lines + sub $subname { }" if($::debug);
getline("sub $subname {");
for my $ln (@lines) {
getline($ln, 1);
}
getline('}', 1);
last;
#} elsif($ValClass[$i] eq 'k' && $ValPerl[$i] eq 'no' && $ValPerl[$i+1] eq 'warnings') {
#$::saved_eval_tokens = 1;