view release on metacpan or  search on metacpan

lib/Devel/Chitin/OpTree/LISTOP.pm  view on Meta::CPAN

sub _generate_flag_list {
    map { local $@;
          my $val = eval "$_";
          $val ? ( $_ => $val ) : ()
    } @_
}

my @sysopen_flags = _generate_flag_list(
                         qw( O_RDONLY O_WRONLY O_RDWR O_NONBLOCK O_APPEND O_CREAT
                             O_TRUNC O_EXCL O_SHLOCK O_EXLOCK O_NOFOLLOW O_SYMLINK
                             O_EVTONLY O_CLOEXEC));
sub pp_sysopen {
    my $self = shift;
    my $children = $self->children;

    my $mode = $self->_deparse_flags($children->[3]->deparse(skip_quotes => 1),
                                     \@sysopen_flags);
    $mode ||= 'O_RDONLY';
    my @params = (
            # skip pushmark
            $children->[1]->deparse,  # filehandle
            $children->[2]->deparse,  # file name
            $mode,
        );

    if ($children->[4]) {
        # perms
        push @params, $self->_as_octal($children->[4]->deparse(skip_quotes => 1));
    }
    'sysopen(' . join(', ', @params) . ')';
}

my @waitpid_flags = _generate_flag_list(qw( WNOHANG WUNTRACED ));
sub pp_waitpid {
    my $self = shift;
    my $children = $self->children;
    my $flags = $self->_deparse_flags($children->[2]->deparse(skip_quotes=> 1),
                                      \@waitpid_flags);
    $flags ||= '0';
    my $target = $self->_maybe_targmy;
    "${target}waitpid(" . join(', ', $children->[1]->deparse, # PID
                            $flags) . ')';
}

sub pp_truncate {
    my $self = shift;
    my $children = $self->children;

    my $fh;
    if ($self->op->flags & B::OPf_SPECIAL) {
        # 1st arg is a bareword filehandle
        $fh = $children->[1]->deparse(skip_quotes => 1);

    } else {
        $fh = $children->[1]->deparse;
    }

    "truncate(${fh}, " . $children->[2]->deparse . ')';
}

sub pp_chmod {
    my $self = shift;
    my $children = $self->children;
    my $mode = $self->_as_octal($children->[1]->deparse);
    my $target = $self->_maybe_targmy;
    "${target}chmod(${mode}, " . join(', ', map { $_->deparse } @$children[2 .. $#$children]) . ')';
}

sub pp_mkdir {
    my $self = shift;
    my $children = $self->children;
    my $target = $self->_maybe_targmy;
    my $dir = $children->[1]->deparse;  # 0th is pushmark
    if (@$children == 2) {
        if ($dir eq '$_') {
            "${target}mkdir()";
        } else {
            "${target}mkdir($dir)";
        }
    } else {
        my $mode = $self->_as_octal($children->[2]->deparse);
        "${target}mkdir($dir, $mode)";
    }
}

# strange... glob is a LISTOP, but always has 3 children
# 1. ex-pushmark
# 2. arg containing the pattern
# 3. a gv SVOP refering to a bogus glob in no package with no name
# There's no way to distinguish glob(...) from <...>
sub pp_glob {
    my $self = shift;
    'glob(' . $self->children->[1]->deparse . ')';
}

# pp_split is a LISTOP up through 5.25.5 and became a PMOP in
# 5.25.6
sub pp_split {
    my $self = shift;

    my $children = $self->children;

    my $regex = $self->_resolve_split_expr;

    my @params = ( $regex );

    my $i = 0;
    $i++ if ($children->[0]->op->name eq 'pushre'
             or
             $children->[0]->op->name eq 'regcomp');

    push @params, $children->[$i++]->deparse;  # string

    if (my $n_fields = $children->[ $i++ ]->deparse) {
        push(@params, $n_fields) if $n_fields > 0;
    }

    my $target = $self->_resolve_split_target;

    "${target}split(" . join(', ', @params) . ')';
}

sub _resolve_split_expr {
    my $self = shift;

    my $regex_op = $self->children->[0];