Skip to content

Commit 4f4a7fb

Browse files
softpanosoftpano
authored
Add files via upload
1 parent b9d015b commit 4f4a7fb

1 file changed

Lines changed: 286 additions & 0 deletions

File tree

‎Pythonizer.pm‎

Lines changed: 286 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,286 @@
1+
package Pythonizer;
2+
#
3+
## ABSTRACT: Supplementary subroutines for pythonizer
4+
## Includes logging subroutine(logme), autocommit, banner, abend, out and helpme
5+
## Copyright Nikolai Bezroukov, 2019-2020.
6+
## Licensed under Perl Artistic license
7+
# Ver Date Who Modification
8+
# ===== ========== ======== ==============================================================
9+
# 00.00 2019/10/10 BEZROUN Initial implementation. Limited by the rule "one statement-one line"
10+
# 00.10 2019/11/19 BEZROUN The prototype is able to process the minimal test (with multiple errors) but still
11+
# 00.11 2019/11/19 BEZROUN autocommit now allow to save multiple modules in addition to the main program
12+
# 00.12 2019/12/27 BEZROUN Notions of ValCom was introduced in preparation of introduction of pre_processor.pl version 0.2
13+
# 00.20 2020/02/03 BEZROUN getline was moved from pythonyzer.
14+
# 00.30 2020/08/05 BEZROUN preprocess_line was folded into getline.
15+
# 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)
16+
17+
use v5.10;
18+
use warnings;
19+
use strict 'subs';
20+
use feature 'state';
21+
use Softpano qw(autocommit helpme abend banner logme out);
22+
23+
require Exporter;
24+
25+
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
26+
@ISA = qw(Exporter);
27+
#@EXPORT = qw(correct_nest getline output_open get_params prolog epilog output_line $IntactLine $::debug $::breakpoint $::TabSize $::TailComment);
28+
@EXPORT = qw(preprocess_line correct_nest getline prolog epilog output_line);
29+
our ($IntactLine, $output_file, $NextNest,$CurNest, $line);
30+
$::TabSize=3;
31+
$::breakpoint=0;
32+
$NextNest=$CurNest=0;
33+
$MAXNESTING=9;
34+
$VERSION = '1.10';
35+
36+
#
37+
#::prolog -- Decode parameter for the pythonizer. all parameters are exported
38+
#
39+
sub prolog
40+
{
41+
Softpano::getopts("hp:b:t:v:d:",\%options);
42+
if( exists $options{'h'} ){
43+
helpme();
44+
}
45+
46+
if( exists $options{'d'} ){
47+
if( $options{'d'} =~/^\d$/ ){
48+
$::debug=$options{'d'};
49+
}else{
50+
logme('S',"Wrong value of option -d. If can be iether set of d letters like -ddd or an integer like -d 3 . You supplied the value $options{'d'}\n");
51+
exit 255;
52+
}
53+
($::debug) && logme('W',"Debug flag is set to $::debug ::PyV");
54+
}
55+
if( exists $options{'p'} ){
56+
if( $options{'p'}==2 || $options{'p'}==3 ){
57+
$::PyV=$options{'p'};
58+
($::debug) && logme('W',"Python version set to $::PyV");
59+
}else{
60+
logme('S',"Wrong value of option -p. Only values 2 and 3 are valid. You provided the value : $options('b')\n");
61+
exit 255;
62+
}
63+
}
64+
65+
if( exists $options{'b'} ){
66+
if( $options{'b'}>=0 && $options{'b'}<900 ){
67+
$::breakpoint=$options{'b'};
68+
($::debug) && logme('W',"Breakpoint set to line $::breakpoint");
69+
}else{
70+
logme('S',"Wrong value of option -b (line for debugger breakpoint): $options('b')\n");
71+
exit 255;
72+
}
73+
}
74+
75+
if( exists $options{'v'} ){
76+
if( $options{'v'} =~/\d/ && $options{'v'}<3 && $options{'v'}>0 ){
77+
$::verbosity=$options{'v'};
78+
}else{
79+
logme('D',3,3); # add warnings
80+
}
81+
}
82+
83+
if( exists $options{'t'} ){
84+
if( $options{'t'}>1 && $options{'t'}<10 ){
85+
$::TabSize=$options{'t'};
86+
}else{
87+
logme('S',"Range for options -t (tab size) is 1-10. You specified: $options('t')\n");
88+
exit 255;
89+
}
90+
}
91+
92+
if (scalar(@ARGV)==1) {
93+
$fname=$ARGV[0];
94+
unless( -f $fname) {
95+
abend("Input file $fname does not exist");
96+
}
97+
$output_file=substr($ARGV[0],0,rindex($ARGV[0],'.')).'.py';
98+
out("Results of transcription are written to the file $output_file");
99+
open (STDIN, "<-",) || die("Can't open $fname for reading");
100+
open(SYSOUT,'>',$output_file) || die("Can't open $output_file for writing");
101+
}else{
102+
open(SYSOUT,'>-') || die("Can't open $STDOUT for writing");
103+
}
104+
if($debug){
105+
print STDERR "ATTENTION!!! Working in debugging mode debug=$debug\n";
106+
}
107+
out("=" x 90,"\n\n");
108+
return;
109+
} # prolog
110+
111+
#::epilig -- close file and produce generated code, if in debug mode
112+
sub epilog
113+
{
114+
close STDIN;
115+
close SYSOUT;
116+
if( $::debug>1 ){
117+
say STDERR "==GENERATED OUTPUT FOR INPECTION==";
118+
print STDERR `cat -n $output_file`;
119+
}
120+
} # epilog
121+
122+
#
123+
#::get_here -- Extract here string with delimiter specified as the first argument
124+
#
125+
sub get_here
126+
{
127+
my $here_str;
128+
while (substr($line,0,length($_[0])) ne $_[0]) {
129+
$here_str.=$line;
130+
$line=getline();
131+
}
132+
return '""""'."\n".$here_str."\n".'"""""'."\n";
133+
} # get_here
134+
135+
#
136+
#::getline -- get input line. It has now ability to buffer line, which will be scanned by tokeniser next.
137+
#
138+
sub getline
139+
{
140+
state @buffer; # buffer to "postponed lines. Used for translation of postfix conditinals among other things.
141+
142+
if( scalar(@_)>0 ){
143+
push(@buffer,@_); # buffer line for processing in the next call;
144+
return
145+
}
146+
while(1) {
147+
#
148+
# firs we perform debufferization
149+
#
150+
if (scalar(@buffer)) {
151+
$line=shift(@buffer);
152+
}else{
153+
$line=<>;
154+
}
155+
return $line unless (defined($line)); # End of file
156+
chomp($line);
157+
if (length($line)==0 || $line=~/^\s*$/ ){
158+
output_line('');
159+
next;
160+
}elsif( $line =~ /^\s*(#.*$)/ ){
161+
# pure comment lines
162+
output_line('',$1);
163+
next;
164+
}
165+
$IntactLine=$line;
166+
if( substr($line,-1,1) eq "\r" ){
167+
chop($line);
168+
}
169+
$line =~ s/\s+$//; # trim tailing blanks
170+
$line =~ s/^\s+//; # trim leading blanks
171+
return $line;
172+
}
173+
174+
}
175+
176+
#::output_line -- Output line shifted properly to the current nesting level
177+
# arg 1 -- actual PseudoPython generated line
178+
# arg 2 -- tail comment (added Dec 28, 2019)
179+
sub output_line
180+
{
181+
my $line=(scalar(@_)==0 ) ? $IntactLine : $_[0];
182+
my $tailcomment=(scalar(@_)==2 ) ? $_[1] : '';
183+
my $indent=' ' x $::TabSize x $CurNest;
184+
my $flag=( $::FailedTrans && scalar(@_)==1 ) ? 'FAIL' : ' ';
185+
my $len=length($line);
186+
my $maxline=80;
187+
my $prefix=sprintf('%4u',$.)." | $CurNest | $flag |";
188+
my $com_zone=$maxline+length($prefix);
189+
my $orig_tail_len=length($tailcomment);
190+
191+
if ($tailcomment){
192+
$tailcomment=($tailcomment=~/^\s+(.*)$/ ) ? $indent.$1 : $indent.$tailcomment;
193+
}
194+
# Special case of empty line or "pure" comment that needs to be indented
195+
if( $len==0 ){
196+
out($prefix,$tailcomment);
197+
say SYSOUT $tailcomment;
198+
return;
199+
}
200+
$line=($line=~/^\s+(.*)$/ )? $indent.$1 : $indent.$line;
201+
say SYSOUT $line;
202+
$line=$prefix.$line;
203+
$len=length($line);
204+
if (scalar(@_)==1){
205+
# no tailcomment
206+
if ($IntactLine=~/^\s+(.*)$/) {
207+
$IntactLine=$1;
208+
}
209+
#remove tailcomment from original line
210+
if( $len > $maxline ){
211+
# long line
212+
if( length($IntactLine) > $maxline ){
213+
out($line);
214+
out((' ' x $com_zone),' #PL: ',substr($IntactLine,0,$maxline));
215+
out((' ' x $com_zone),' Cont: ',substr($IntactLine,$maxline));
216+
}else{
217+
out($line,' #PL: ',$IntactLine);
218+
}
219+
}else{
220+
# short line
221+
out($line,(' ' x ($com_zone-$len)),' #PL: ',$IntactLine);
222+
}
223+
}else{
224+
#line with tail comment
225+
$IntactLine=substr($IntactLine,0,-$orig_tail_len);
226+
if ($tailcomment eq '#\\' ){
227+
out($line,' \ '); # continuation line
228+
}else{
229+
out($line,' ',$tailcomment); # output with tail comment instead of Perl comment
230+
}
231+
if( length($IntactLine)>90 ){
232+
#long line
233+
out((' ' x $com_zone),' #PL: ',substr($IntactLine,0,$maxline));
234+
out((' ' x $com_zone),' #Cont: ',substr($IntactLine,$maxline));
235+
}else{
236+
#short line
237+
out((' ' x $com_zone),' #PL: ',$IntactLine);
238+
}
239+
}
240+
241+
} # output_line
242+
243+
#::correct_nest -- ensure proper indenting of the lines. Accepts two arguments
244+
# if no arguments given it sets $CurNest=$NextNest;
245+
# If only 1 ARG given inrements/decreaments $NextNest;
246+
# NOTE: If zero is given sets NextNest to zero.
247+
# if two argumants given sets increments/decrements both NexNext and $CurNest
248+
# NOTE: Special case -- if 0,0 is passed both set to zero
249+
# Each argiment checked against the min and max threholds befor processing
250+
sub correct_nest
251+
{
252+
my $delta;
253+
if (scalar(@_)==0) {
254+
# if no arguments given set NextNest equal to CurNest
255+
$CurNest=$NextNest;
256+
return;
257+
}
258+
$delta=$_[0];
259+
if ($delta==0 && scalar(@_)==1 ){
260+
$NextNest=0;
261+
return;
262+
}
263+
if( $NextNest+$delta > $MAXNESTING ){
264+
logme('E',"Attempt to set next nesting level above the treshold($MAXNESTING) ingnored");
265+
}elsif( $NextNest+$delta < 0 ){
266+
logme('S',"Attempt to set nesting level below zero ignored");
267+
}else{
268+
$NextNest+=$delta;
269+
}
270+
271+
if(scalar(@_)==2){
272+
$delta=$_[1];
273+
if ($delta==0 && $_[0]==0){
274+
$CurNest=$NextNest=0;
275+
return;
276+
}
277+
if ($delta+$CurNest>$MAXNESTING) {
278+
logme('E',"Attempt to set current nesting level above the treshold($MAXNESTING) ignored");
279+
}elsif($delta+$CurNest<0){
280+
logme('S',"Attempt to set the curent nesting level below zero ignored");
281+
}else{
282+
$CurNest+=$delta;
283+
}
284+
}
285+
}
286+
1;

0 commit comments

Comments
 (0)