view release on metacpan or  search on metacpan

lib/Parse/RPN.pm  view on Meta::CPAN

=head2  xxx name1 PERLFUNC1

        execute the PERL function name1 with the only one parameter xxx
        the default name space is "main::"
        It is possible tu use a specific name space
        the parameter are "stringified"
        e.g. 'file,name,CAT,substit,PERLFUNC1'
        call the function substit("filename");
        
=cut

$dict{PERLFUNC1} = sub {
    my $work1 = shift;
    my $name  = pop @{ $work1 };
    my $arg   = pop @{ $work1 };
    my $todo;
    if ( $name !~ /::[^:]*$/ )
    {
        $todo = "main::" . $name . '("' . $arg . '");';
    }
    else
    {
        my $before = $`;
        eval "require  $before";
        $todo = $name . '("' . $arg . '");';
    }
    my @ret = eval( $todo );
    if ( $@ )
    {
        chomp $@;
        $DEBUG = $@;
        @ret   = ();
    }
    return \@ret, 2, 0;

};

=head2  xxx nbr name1 PERLVAR

        Return the perl variable.
        If the var returned is an array, return each element of the array on the stack
        If the var returned is a hash , return a STRUCTURATED LIST
        the default name space is "main::"
        It is possible tu use a specific name space
        the parameter are "stringified"
        e.g.1 '{$data},PERLVAR'
        call the value of $data;
        e.g.2 '{%S}->{extra},PERLVAR'
        call the value of $S->{extra};
        
=cut

$dict{PERLVAR} = sub {
    my $work1 = shift;
    my $name  = pop @{ $work1 };
    my $name1 = pop @{ $work1 };
    $name =~ /^\{([^}]*)\}/;
    my $base_name = $1;
    my @ret;
    use PadWalker qw(peek_my);
    my $level = 0 ;
    my $ref_var;
    while ( ! exists  $ref_var->{$base_name} )
    {
        eval { $ref_var= peek_my( $level++ ) };
        if ( $@ )
        { 
            return \@ret, 1, 0;
        }
    }

    my @all     = split /->/, $name;
    my $res     = __deref__( $ref_var, \@all );
    my ($tmp ,undef )= __to_sl__($res,0);
    $tmp =~ s/#\s+$/\#/;
    $tmp =~ s/^\s+#/\#/;
    push @ret, $tmp;
    
    return \@ret, 1, 0;

};

sub __to_sl__
{
    my $ref = shift;
    my $dep = shift;

    my $res;
    if ( ref $ref eq 'HASH' )
    {
        $dep++;
        $res .= '#' x $dep . ' ';
        foreach my $key ( keys %$ref )
        {
            $res .= $key . ' ' . '|' x $dep . ' ';
            my ( $r, $dep ) = __to_sl__( $ref->{ $key }, $dep );
            $res .= $r . ' ' . '#' x $dep . ' ';
        }
    }
    elsif ( ref $ref eq 'ARRAY' )
    { 
        $dep++;
        foreach my $val ( @$ref )
        {
            my ( $r, $dep ) = __to_sl__( $val, $dep );
            $res .= ' ' . '#' x $dep . ' ' . $r;
        }
        $res .= ' ' . '#' x $dep . ' ';
    }
    else
    {
        $res = $ref;
    }
   
    $res =~ s/\s+##\s+##/ ## #/g;
    return $res, $dep;
}

sub __deref__
{