perl_to_python.def

page: perl_to_python
    output_dir: script
    type:

    my ($in_file, $out_file) = @ARGV

    my @lines
    load_lines($in_file, \@lines)

    &call open_W, $out_file
        $call dump_global
        $foreach $l in @lines
            chomp $l
            $print $l

    subcode: dump_global
        $global $use_RE
        $if $use_RE
            $print "subcode: _autoload"
            $print "    \$call class_RE"
            $print

fncode: load_lines($in_file, $out)
    my @include_list = ($in_file)
    $while my $file = shift @include_list
        $file = find_file($file)
        $call get_file_lines, $file
        my $stage
        $foreach @lines
            $if /^\/\*\s+skip\s+python/
                $stage = "skip_python"
                next
            $elif $stage eq "skip_python"
                $if /^\*\//
                    undef $stage
                next
            $elif /^include:\s*(.*)/
                push @include_list, $1
                next

            my $sp
            $if /^(\s+)(.*)/ -> $sp*, $_*
                NOOP

            $call @filters
            push @$out, $_

fncode: find_file($f)
    return $f

subcode: filters
    $if /^$/
        # skip blank
    $elif /^#.*$/
        $if /^#\s*skip/
            push @$out, $sp."pass"
        $else
            push @$out, $sp.$_
        # skip comments
        next
    $elif /\$: \\x23/
        # pass-thru comments
        push @$out, $sp.$_
        next
    $elif /^\/\*(\s|$)/
        $stage = "comment"
        next
    $elif $stage eq "comment"
        $if /^\*\//
            undef $stage
        next
    $elif /^filter: perl_to_python/
        # allow python specific code
        push @$out, "macros:"
        push @$out, "    perl_to_python: 1"
        next
    $elif /^module: perl/
        push @$out, $sp."module: python"
        $global $use_G = 1
        $if $use_G
            push @$out, $sp."use_G: 1"
        next
    $elif /^((fn|sub)code|page):/
        $if $2 eq "fn"
            s/\$//g
        push @$out, "$sp$_"
        next
    $elif /^(\w+):\s*(.*)/ -> $word, $val
        $if $word eq "print_to"
            push @$out, "$sp$word: ".translate_print_to($val)
        $elif $val=~/\s*([\$\@\%].*)/
            push @$out, $sp."$word: ".translate_expr($1)
        $else
            # skip likely mydef directive
            push @$out, "$sp$_"
        next
    $elif /^\$\(/
        $if /^(\$\(set:print_to=)(.*)\)/ -> $t1, $t2
            push @$out, $sp.$t1.translate_print_to($t2).')'
        $elif /^(\$\(set.*:\w+=)([\$\@\%].*)\)$/ -> $t1, $t2
            push @$out, $sp.$t1.translate_expr($t2).')'
        $else
            # skip mydef directive
            push @$out, "$sp$_"
        next
    $elif /^(my|return|push|unshift|print|system|chomp|chdir|mkdir)\s*(.*)/ -> $func, $t
        $call @perl_functions
        next
    $call @perl_regex
    $elif /^([\&\$]call)\s*(\w+)(.*)/ -> $call, $name, $tail
        $if !$tail
            push @$out, "$sp$call $name"
        $else
            $tail=~s/^,\s*//
            $if $tail=~/\s*([\$\@\%].*)/ && $tail !~ /# string\s*$/
                $tail = translate_expr($tail)
            push @$out, "$sp$call $name, $tail"
        next
    $elif /^\$(\w+)\s*$/
        push @$out, "$sp$_"
        next
    $elif /^\$(\w+)\s+(.*)/ -> $func, $t
        my $lead = "$sp\$$func "
        $call @mydef_funcs
        next
    $elif /^(.+)/ -> $t
        $if $direct_translate{$t}
            push @$out, $sp . $direct_translate{$t}
        $else
            push @$out, $sp . translate_Expr($t)
        next

    # ---------------------
    subcode: perl_regex
        $elif /^s\/(.*)\/(.*)\// -> $pat, $repl
            my $s = "\x24(re_str)"
            push @$out, $sp . "$s = re.sub(r'$pat', '$repl', $s)"
            next
        $elif /^(\S+)\s*=~\s*s\/(.*)\/(.*)\// -> $str, $pat, $repl
            my $s = translate_expr($str)
            push @$out, $sp . "$s = re.sub(r'$pat', '$repl', $s)"
            next

    subcode: perl_functions
        # python raises exception
        $t=~s/\s+or\s+die.*//

        $if $func eq "my"
            push @$out, $sp . translate_my($t)
        $elif $func eq "return"
            push @$out, $sp."return ".translate_expr($t)
        $elif $func =~/^(push|unshift)$/ and $t=~/^(\@.*?),\s+(.*)/ -> $array, $t
            $array = translate_expr($array, "left")
            $t = translate_expr($t)
            $if $func eq "push"
                push @$out, $sp . "$array.append($t)"
            $else
                push @$out, $sp . "$array.insert(0, $t)"
        $elif $func eq "print"
            $if $t=~/^(\w+)\s+(.+)/ -> $FH, $t
                $t = translate_expr($t)
                push @$out, $sp . "print($t, end='', file=$FH)"
            $else
                $t = translate_expr($t)
                push @$out, $sp . "print($t)"
        $elif $func eq "system"
            $t = translate_expr($t)
            push @$out, $sp . "os.system($t)"
        $elif $func eq "chomp"
            $if $t
                $t = translate_expr($t)
                push @$out, $sp."$t.rstrip()"
            $else
                push @$out, $sp."\x24(re_str).rstrip()"
        $elif $func=~/^(mkdir|chdir)$/
            $t = translate_expr($t)
            push @$out, $sp."os.$1($t)"

    subcode: mydef_funcs
        $if $func =~ /^(print|die|warn)$/
            $t = translate_print($t)
            $t =~ s/\\([@%])/$1/g
            push @$out, "$lead$t"
        $elif $func =~ /^(dump|while)$/
            push @$out, $lead . translate_expr($t)
        $elif $func eq "for"
            push @$out, $lead. translate_for_param($t)
        $elif $func eq "foreach"
            $if $t=~/^(\%.*)/
                push @$out, "$sp\$for k, v in ".translate_expr($1).".items()"
            $else
                push @$out, "$sp\$for ". translate_for_param($t)
        $elif $func eq "global"
            push @$out, $lead. translate_global($t)

        $elif $func =~/^(if|elif|while)/
            $call filter_if_cond
            push @$out, "$sp\$$func $t"
        $else
            # other $func
            push @$out, $sp . translate_Expr("\$$func $t")

#---------------------------------------- 
subcode: filter_if_cond
    my $caps
    $if $t=~/^(.*?)\s+->\s+(.+)$/
        # regex captures 
        ($t, $caps) = ($1, $2)
        $caps =~ s/\*//g
        $caps = translate_expr($caps, "left")

    my @parts = split /\s+(and|or|&&|\|\|)\s+/, $t
    $foreach $p in @parts
        my $not
        $if $p=~/^!\s*(.*)/
            $p = $1
            $not = "not "

        $if $p eq "&&"
            $p = "and"
        $elif $p eq "||"
            $p = "or"
        $elif $p=~/^exists\s+(.*?)(->)?\{(.+)\}/ -> $v, -, $k
            $p = translate_exists($v, $k, $not)
        $elif $p=~/^-d\s+(.*)/
            $p = $not."os.path.isdir(".translate_expr($1).")"
        $else
            $p = $not.translate_expr($p)
    $if $caps
        push @parts, "-> $caps"
        $use_RE = 1
    $t = join(' ', @parts)

subcode: _autoload
    $global %direct_translate
    %direct_translate=(
        last=>"break",
        next=>"continue",
    );
#---------------------------------------- 

fncode: translate_exists($v, $k, $not)
    $v = translate_expr($v)
    $if $k=~/^\w+$/
        $k = "'$k'"
    $else
        $k = translate_expr($k)
    $if $not
        return "$k not in $v"
    $else
        return "$k in $v"

fncode: translate_print_to($t)
    $if $t=~/^\w+$/
        return $t
    $elif $t=~/^@/
        # need '@' to signify an array
        return '@'.translate_expr($t, "left")
    $else
        return translate_expr($t)

fncode: translate_for_param($t)
    $if $t =~/(.*?)\s+in\s+(.*)/ -> $v, $array
        $v=~s/\$//g
        $if $array =~ /^keys\s*\%(.*)/
            $array = translate_expr("\%$1")
        $elif $array =~ /^sort keys\s*\%(.*)/
            $array = "sorted (".translate_expr("\%$1").".keys())"
        $else
            $array = translate_expr($array, "left")

        return "$v in $array"
    $elif $t=~/(\S+)\s*=\s*(\S+):(\S+)/
        my $i = translate_expr($1, "left")
        my $i1 = translate_expr($2)
        my $i2 = translate_expr($3)
        return "$i=$i1:$i2"

fncode: translate_global($t)
    $global %global_hash
    $if $t=~/^([\$\@\%])(\w+)\s*=\s*(\(.*\))\s*$/ -> $sigil, $name, $t
        $global_hash{$name} = $sigil
        $t = translate_expr($t)
        $if $sigil eq '%' and $t=~/^\((.*)\)$/
            $t = "{$1}"
        return "$name = ".translate_expr($t)
    $else
        my @alist = split /,\s*/, $t
        $foreach $a in @alist
            $if $a =~/^([\$\@\%])(\w+)(.*)/  -> $sigil, $name, $tail
                $global_hash{$name} = $sigil
                $if $tail =~ /^\s*(:?=)\s*(.*)/
                    $a = "$name $1 ".translate_expr($2)
                $elif $sigil eq '@'
                    $a = "$name = []"
                $elif $sigil eq '%'
                    $a = "$name = {}"
                $else
                    $a = "$name = ''"
        return join(', ', @alist)

fncode: translate_my($t)
    # $print translate_my: [$t]
    my (@alist, @blist)
    $if $t=~/\@(\w+)\s*=\s*split\s*\/(.*)\/,\s*(.*)/ -> $a, $pat, $str
        # FIXME: only works for literal delimiter
        $str = translate_expr($str)
        $if $pat =~ /^\\s\+$/
            return "$a = $str.split()"
        $else
            return "$a = $str.split('$pat')"
    $elif $t=~/=/
        # just assignments
        return translate_Expr($t)
    $elif $t =~/^\((.*)\)\s*$/ -> $a
        @alist = split /,\s*/, $a
    $else
        @alist = ($t)

    $foreach $a in @alist
        $if $a=~/^\@(\w+)/
            push @blist, "[]"
        $elif $a=~/^\%(\w+)/
            push @blist, "{}"
        $elif $a=~/^\$(\w+)/
            push @blist, "''"
        substr($a,0,1)=''
    return join(', ', @alist) . " = " . join(', ', @blist)

fncode: translate_string($t)
    my (@fmt_list, @arg_list)
    $while 1
        $if $t=~/\G$/gc
            last
        $elif $t=~/\G\$/gc
            $if $t=~/\G(\w+)/gc -> $v
                $if $t=~/\G((->)?\[.*?\])/gc
                    $v.=$1;
                $elif $t=~/\G((->)?\{.*?\})/gc
                    $v.=$1;
                push @fmt_list, "%s";
                push @arg_list, translate_expr($v)
            $elif $t=~/\G\{(.*?)\}/gc
                my $v = $1
                push @fmt_list, "%s";
                push @arg_list, translate_expr($v)
            $else
                push @fmt_list, '$'
        $elif $t=~/\G([^\$]+)/gc
            push @fmt_list, $1
        $else
            die "translate_string: error!\n"
    $if !@arg_list
        return $t
    $else
        return join('', @fmt_list).' % ('.join(', ', @arg_list).')'

fncode: translate_print($t)
    my @fmt_list
    $while 1
        $if $t=~/\G$/gc
            last
        $elif $t=~/\G\$/gc
            $if $t=~/\G(\d+)/gc
                push @fmt_list, "\$$1"
            $elif $t=~/\G(\w+)/gc
                my $v = $1
                $if $t=~/\G((->)?\[.*?\])/gc
                    $v.=$1;
                $elif $t=~/\G((->)?\{.*?\})/gc
                    $v.=$1;
                my $v = translate_expr('$'.$v)
                $if $v=~/^\w+$/
                    push @fmt_list, '$'.$v
                $else
                    push @fmt_list, '${'.$v.'}'
            $elif $t=~/\G\{(.*?)\}/gc
                my $v = $1
                push @fmt_list, '${'.translate_expr('${'.$v.'}').'}'
            $else
                push @fmt_list, '$'
        $elif $t=~/\G([^\$]+)/gc
            push @fmt_list, $1
        $else
            die "translate_string: error!\n"
    return join('', @fmt_list)

#---------------------------------------- 
fncode: strip_brace($t)
    $if $t=~/^\{(.*)\}/
        return $1
    $else
        return $t
#---------------------------------------- 
macros:
    # debug: 1

fncode: translate_Expr($l)
    $if $l=~/^[%@](.*?)\s*=\s*[%@](.*)/ -> $a, $b
        $a = strip_brace($a)
        $b = strip_brace($b)
        # push @$out, "$sp\$import copy\n"
        my $t1 = translate_expr($a, "left")
        my $t2 = translate_expr($b)
        return "$t1 = copy.deepcopy($t2)"
    $elif $l=~/^([^'"]+?)\s*([\+\-\*\.]?=)\s*(.+)/ -> $left, $op, $right
        my $t1 = translate_expr($left, "left")
        my $t2 = translate_expr($right)
        $if $op eq ".="
            $op = "+="
        $if $t2=~/^\(('.*': .*)\)$/  # a dictionary
            $t2="{$1}"
        return "$t1 $op $t2"
    $else
        return translate_expr($l)

fncode: translate_expr($l, $context)
    $(if:debug)
        $print translate_expr [$l] - $context
    my ($assign, $left, $right)
    $call @check_expression_init
    my (@stack, @types)
    $while 1
        $call parse
        # $print "  token: $token, type: $type"
        $call push
    $call join_stack, $right

    $if $assign
        $(if:debug)
            $print assign: right=[$right] ...
        $if $right=~/^\(.*\)$/
            $right=~s/^\(/{/
            $right=~s/\)$/}/
        $right = "$left $assign $right"

    return $right

    # -------------------------------- 
    subcode: join_stack(t)
        $(t) = join("", @stack)

    subcode: exp_push(exp, type)
        push @stack, $(exp)
        push @types, $(type)

    subcode: exp_pop(assign)
        $(if:assign=undef)
            pop @stack
            pop @types
        $(else)
            my $(assign)=pop @stack
            pop @types

    macros:
        type: 
        type1: @types>0 && $types[-1]
        type2: @types>1 && $types[-2]
        atom1: @stack>0 && $stack[-1]
        atom2: @stack>1 && $stack[-2]
    # -------------------------------- 
    subcode: parse
        my ($token, $type)
        $if $l=~/\G$/gc
            last
        #----  atom ------
        $elif $l=~/\G("([^"\\]|\\.)*")/gc
            $token=translate_string($1)
            $type="atom-string"
        $elif $l=~/\G('([^'\\]|\\.)*')/gc
            $token=$1
            $type="atom-string"
        $elif $l=~/\G(\/([^\\]|\\.)*\/\w*)/gc
            $token=$1
            $type="atom-re"
            $if $token=~/^\/(\$\w+.*)\//
                $token = '/${'.translate_expr($1).'}/'
        $elif $l=~/\G(\d[0-9\.]*)/gc
            $token=$1
            $type="atom-number"
        $elif $l=~/\G(\$\(\w+\))/gc
            $token=$1
            $type="atom-macro"
        #---- special variables ----
        $elif $l=~/\G\$_/gc
            $token = "\x24(re_str)"
            $type = "atom-val"
        $elif $l=~/\G\$(\d+)/gc
            $(if:1)
                $token = "RE.m.group($1)"
                $type = "atom-var"
            $(else)
                $token = $1
                $type="atom-macro"
        $elif $l=~/\G\@(ARGV)/gc
            $token = "sys.argv[1:]"
            $type="atom-var"
        #---- perl variables ----
        $elif $l=~/\G(\\?[\$\@\%]+)(\w+)/gc -> $sigil, $id
            $if $use_G
                $if $global_hash{$id}
                    $id = "G.$id"
            $if $id eq "_"
                $token='$'."(re_str)"
            $elif $sigil=~/^@/ and $context ne "left"
                # manage list cotext in higher layer
                $token = "len($id)"
            $else
                $token=$id
            $type="atom-var"
        $elif $l=~/\G([\$\@\%])\{/gc -> $sigil
            # ${...} @{...} %{...}
            $if $sigil eq '@' and $context ne "left"
                $call exp_push, '{', "arraylen-strip"
            $else
                $call exp_push, '{', "bracket-strip"
        $elif $l=~/\Gqw\((.*?)\)/gc
            my $t = $1
            $t =~ s/\s+/', '/g
            $token = "['$t']"
            $type="atom-qw-list"
        $elif $l=~/\G(and|or)\b/gc
            $token=$1
            $type="operator"
        $elif $l=~/\G(eq|lt|le|gt|ge|ne)\b/gc
            $global %str_cmp_ops=(eq=>'==', lt=>'<', le=>'<=', gt=>'>', ge=>'>=', ne=>'!=')
            $token=$str_cmp_ops{$1}
            $type="operator"
        $elif $l=~/\G(\w+)/gc
            # perl {bare_word}
            $token=$1
            $type="atom-word"
            $if $token eq "x"
                $if $types[-1] eq "atom-string"
                    $token = "*"
                    $type="operator"

        #----  bracket ------
        $elif $l=~/\G([\(\[\{])/gc
            $call exp_push, $1, $1
            next
        $elif $l=~/\G([\)\]\}])/gc
            $call check_exp_bracket
        #---- skip ----
        $elif $l=~/\G(\s+)/gc
            # skip
            next
        #---- operator ----
        $elif $l=~/\G([!=]~)/gc
            $token = $1
            $type="operator"
        $elif $l=~/\G([=+\-\*\/%\^\&\|><\?,\.!:]+)/gc
            $token=$1
            $type="operator"
            $if $token eq ".="
                $token = "+="
            $elif $token eq "=>"
                $token = ":"
                $if $types[-1] eq "atom-word"
                    $stack[-1] = "'$stack[-1]'"
                    $types[-1] = "atom-string"
        $else
            last

    subcode: push
        check_exp_precedence:
        $if !@stack
            $call exp_push, $token, $type
        $elif $type=~/^op/
            $call is_operator
        $elif $type=~/^atom/
            $call is_atom
        # ----------------------
        subcode: is_operator
            $if $token eq "++" or $token eq "--"
                #---- postfix -----------------
                $call exp_pop, $exp
                $call exp_push, "$exp$token", "atom-postfix"
            $elif $token eq ":"
                #---- label -----------------
                $call exp_pop, $exp
                $call exp_push, "$exp$token ", "atom-label"
            $elif $token=~/^(.*)=$/ and $1!~/^[!><=]$/
                $call is_assignment
            $else
                #---- other op ----------------
                $call exp_push, $token, $type
            # ---------------
            subcode: is_assignment
                $if $left
                    die "only simple chained assignment is supported\n"

                $if $token eq '=' and @stack==1 and $types[0] eq "atom-("
                    $left=substr($stack[0], 1, -1)
                $else
                    $call join_stack, $left

                @stack=()
                @types=()
                $assign=$token

        # -----------------
        subcode: is_atom
            $if $(type1) =~/^op/
                $if $(type2) !~/^atom/ 
                    #---- unary -------------
                    $call exp_pop, $op
                    $token=$op.$token
                    $type="atom-unary"
                    goto check_exp_precedence
                $else
                    #---- binary -------------
                    $(set:op=$stack[-1])
                    $if $(op) =~ /^[,:]$/
                        # space after ,
                        $(op).=" "
                    $elif $(op) =~ /^(\.)$/
                        # must be string concatenation
                        $(op) = " + "
                    $elif $(atom2)=~/^[\(\[\{]$/
                        # no space
                    $elif $(op)=~/^\S+$/
                        # space on both side of bin_op
                        $(op)=" $(op) "
                    $call exp_push, $token, $type
            $elif $(type1) =~/^atom/
                # case by case
                $stack[-1].="$token"
            $else
                #---- open bracket ---------
                $call exp_push, $token, $type

    # -------------------------
    subcode: check_exp_bracket
        my $close=$1
        my $open
        $if $close eq ')'
            $open='('
        $if $close eq ']'
            $open='['
        $if $close eq '}'
            $open='{'

        &call find_open_bracket
            $if $(atom1) eq "->"
                $call exp_pop, $t

            $if $open eq "{" and $(type1)=~/^atom/
                $call exp_pop, $primary
                $call check_exp_dict
            $elif $open eq "(" and $(type1) =~/^atom/ and $stack[-1]=~/(\w+)$/
                $call exp_pop, $primary
                $call check_exp_fcall
                $if !$processed
                    $token=$primary.$open.$exp.$close
                    $type="atom-exp"
            $elif $bracket_type =~/-strip/
                $if $bracket_type eq "arraylen-strip"
                    $token = "len($exp)"
                    $type = "atom-exp"
                $else
                    $token = $exp
                    $type = "atom-exp"
            $else
                $token=$open.$exp.$close
                $type="atom-$open"

        # ------------------------
        subcode: find_open_bracket
            my $n=@stack
            my ($i_open, $bracket_type)
            $for $i=$n:0
                $if $stack[$i] eq $open
                    $i_open=$i
                    last
            $if defined $i_open and $stack[$i_open] eq $open
                $bracket_type = $types[$i_open]
                my $exp
                $if $bracket_type eq "{" && $i_open == $n-2 && $types[-1] eq "atom-word"
                    $exp = "'$stack[-1]'"
                    splice(@stack, $i_open)
                    splice(@types, $i_open)
                $else
                    $exp=join("", splice(@stack, $i_open+1))
                    pop @stack
                    splice(@types, $i_open)
                BLOCK
            $else
                $call error_unbalanced
        # ---------------------
        subcode: check_exp_fcall
            my $processed
            $global %fcall_map=(uc=>"upper", lc=>"lower", length=>"len")
            $if $primary eq "join" and $exp=~/(['"].*['"]),\s*(.+)/
                $token = "$1.join($2)"
                $token=~s/\(len\((.*)\)\)$/($1)/  # we want array here
                $type = "atom-string"
                $processed = 1
            $elif $primary =~ /^(uc|lc)$/
                my $fn = $fcall_map{$1}
                $token = "$exp.$fn()"
                $type = "atom-string"
                $processed = 1
            $elif $primary =~ /^(length)$/
                $primary = $fcall_map{$1}
            $elif $primary eq "split"
                $if $exp=~/^\/(.*)\/,\s*(.*)$/
                    $token = "re.split(r'$1', $2)"
                    $type = "atom-array"
                    $processed = 1
            $elif $primary eq "glob"
                $primary = "glob.glob"

        subcode: check_exp_dict
            $(if:1)
                $call dict_direct
            $(else)
                $if $context eq "left"
                    $call dict_direct
                $else
                    $call dict_get
            subcode: dict_direct
                $token = $primary."[$exp]"
                $type = "atom-fcall"
            subcode: dict_get
                $global %dict_type
                $if $dict_type{$primary} eq "ref"
                    $token = "$primary.get($exp)"
                $elif $dict_type{$primary} eq "num"
                    $token = "$primary.get($exp, 0)"
                $else
                    $token = "$primary.get($exp, '')"
                $type = "atom-fcall"

        subcode: error_unbalanced
            warn "Error checking expression $l, unbalanced brackets\n"
            print join(" -- ", @stack), "\n"
            $token=join("", @stack)
            $type="atom-broken"