view release on metacpan or  search on metacpan

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

                [ pp_int        => 'int',       1 ],
                [ pp_log        => 'log',       1 ],
                [ pp_sqrt       => 'sqrt',      1 ],
                [ pp_quotemeta  => 'quotemeta', 1 ],
                [ pp_chroot     => 'chroot',    1 ],
                [ pp_readlink   => 'readlink',  0 ],
                [ pp_rmdir      => 'rmdir',     1 ],
                [ pp_defined    => 'defined',   0 ],
                [ pp_pos        => 'pos',       0 ],
                [ pp_alarm      => 'alarm',     0 ],
                [ pp_ref        => 'ref',       0 ],
) {
    my($pp_name, $perl_name, $targmy) = @$a;
    my $sub = sub {
        my $self = shift;
        my $arg = $self->first->deparse;

        my $target = $targmy ? $self->_maybe_targmy : '';
        "${target}${perl_name}("
            . ($arg eq '$_' ? '' : $arg)
            . ')';
    };
    no strict 'refs';
    *$pp_name = $sub;
}

sub pp_fc {
    my($self, %params) = @_;

    my $children = $self->children;
    if (@$children > 1) {
        # This is part of a \F...\E sequence within a double-quoted string, first child is a pushmark
        '\F' . $children->[1]->deparse . '\E';

    } else {
        # This is a regular fc() UNOP
        my $arg = $self->first->deparse;
        my $target = $self->_maybe_targmy;
        "${target}fc("
            . ( $arg eq '$_' ? '' : $arg )
            . ')';
    }
}


# Functions that don't operate on $_
#                   OP name        Perl fcn    targmy?
foreach my $a ( [ pp_scalar     => 'scalar',    0 ],
                [ pp_rand       => 'rand',      1 ],
                [ pp_srand      => 'srand',     1 ],
                [ pp_each       => 'each',      0 ],
                [ pp_keys       => 'keys',      0 ],
                [ pp_values     => 'values',    0 ],
                [ pp_akeys      => 'keys',      0 ],
                [ pp_avalues    => 'values',    0 ],
                [ pp_aeach      => 'each',      0 ],
                [ pp_reach      => 'each',      0 ],
                [ pp_rkeys      => 'keys',      0 ],
                [ pp_rvalues    => 'values',    0 ],
                [ pp_ggrgid     => 'getgrgid',  0 ],
                [ pp_gpwuid     => 'getpwuid',  0 ],
                [ pp_gpwnam     => 'getpwnam',  0 ],
                [ pp_gpwent     => 'getpwent',  0 ],
                [ pp_ggrnam     => 'getgrnam',  0 ],
                [ pp_close      => 'close',     0 ],
                [ pp_closedir   => 'closedir',  0 ],
                [ pp_dbmclose   => 'dbmclose',  0 ],
                [ pp_eof        => 'eof',       0 ],
                [ pp_fileno     => 'fileno',    0 ],
                [ pp_getc       => 'getc',      0 ],
                [ pp_readdir    => 'readdir',   0 ],
                [ pp_rewinddir  => 'rewinddir', 0 ],
                [ pp_tell       => 'tell',      0 ],
                [ pp_telldir    => 'telldir',   0 ],
                [ pp_enterwrite => 'write',     0 ],
                [ pp_ghbyname   => 'gethostbyname', 0 ],
                [ pp_gnbyname   => 'getnetbyname', 0 ],
                [ pp_gpbyname   => 'getprotobyname', 0 ],
                [ pp_shostent   => 'sethostent', 0 ],
                [ pp_snetent    => 'setnetent', 0 ],
                [ pp_sprotoent  => 'setprotoent', 0 ],
                [ pp_sservent   => 'setservent', 0 ],
                [ pp_getpgrp    => 'getpgrp',   1 ],
                [ pp_tied       => 'tied',      0 ],
                [ pp_untie      => 'untie',     0 ],
                [ pp_getpeername=> 'getpeername',   0 ],
                [ pp_getsockname=> 'getsockname',   0 ],
                [ pp_caller     => 'caller',    0 ],
                [ pp_exit       => 'exit',      0 ],
) {
    my($pp_name, $perl_name, $targmy) = @$a;
    my $sub = sub {
        my $self = shift;
        my $arg = $self->first->deparse;

        my $target = $targmy ? $self->_maybe_targmy : '';
        "${target}${perl_name}($arg)";
    };
    no strict 'refs';
    *$pp_name = $sub;
}

# These look like keywords but take an argument
foreach my $a ( [ pp_dump       => 'CORE::dump' ],
                [ pp_next       => 'next' ],
                [ pp_last       => 'last' ],
                [ pp_redo       => 'redo' ],
) {
    my($pp_name, $perl_name) = @$a;
    my $sub = sub {
        my $self = shift;
        my $arg = $self->first->deparse;
        "${perl_name} $arg";
    };
    no strict 'refs';
    *$pp_name = $sub;
}

sub pp_umask {
    my $self = shift;
    'umask(' . $self->_as_octal( $self->first->deparse(skip_quotes => 1) ) . ')';