App-sh2p
view release on metacpan or search on metacpan
lib/App/sh2p/Builtins.pm view on Meta::CPAN
$signal = shift @rest;
}
else {
$signal = 'TERM'; # default signal
# 0.06 Hack because this is an inserted token and
# general_arg_list will include this in its count
$ntok--;
}
#print STDERR "do_kill: <@rest>\n";
$ntok += general_arg_list ($cmd, $signal, @rest);
return $ntok;
}
########################################################
sub do_let {
my ($cmd, @rest) = @_;
my $ntok = 1;
# Find any comment - this should go first
if (substr($rest[-1],0,1) eq '#') {
$ntok++;
iout $rest[-1]; # Write the comment out
pop @rest
}
for my $token (@rest) {
# strip quotes
$token =~ s/[\'\"]//g;
# Get variable name
$token =~ /^(.*?)=/;
my $var = "\$$1";
if (Register_variable($var, int)) {
iout "my $var;\n"; # 0.05 added leading $
}
App::sh2p::Compound::arith ($token);
$ntok++;
}
return $ntok;
}
########################################################
# Also does for echo
sub do_print {
my $ntok = 1;
my ($name, @args) = @_;
my $newline = 1;
my $handle = '';
my $opt_u;
my %options;
local @ARGV;
my $redirection = '';
my $file = '';
my $from_fd = ''; # TODO - not currently supported
# Move the comment to before the statement
if ( substr($args[-1],0,1) eq '#' ) {
my $comment = pop @args;
out "\n";
iout $comment;
$ntok++;
}
for my $arg (@args) {
last if is_break($arg) || $arg eq ';';
my $in_redirection_token = 0;
# This is so a > inside a string is not seen as redirection
if ($arg =~ /^([\"\']).*?\1/) {
set_in_quotes();
}
# This should also strip out the redirection
if (!query_in_quotes() && $arg =~ s/(\>{1,2})//) {
$ntok++;
$redirection = $1;
$in_redirection_token = 1;
if ($ARGV[-1] =~ /\d/) {
$from_fd = pop @ARGV;
error_out ("dup file descriptors ($from_fd>&n) not currently supported");
$ntok++;
}
}
if ($arg && $redirection && (! $file)) {
$arg =~ s/(\S+)//;
$file = $1;
$ntok++ unless $in_redirection_token;
}
unset_in_quotes();
push @ARGV, $arg if $arg;
#$ntok++; 0.05 commented out
}
if ($redirection) {
#print STDERR "do_print redirection file <$file>\n";
# January 2009
if ( $file =~ /^\&(\d+)$/ ) {
my $fd = $1;
if ($fd == 1) {
$handle = 'STDOUT ';
}
elsif ($fd == 2) {
$handle = 'STDERR ';
}
else {
lib/App/sh2p/Builtins.pm view on Meta::CPAN
$string .= "$tokens[0]";
# append with a space for print/echo
$string .= ' ' if $i < $#args;
}
elsif ($types[0][0] eq 'OPERATOR') { # 0.05
@trailing_tokens = splice (@args, $i);
last;
}
else {
if ($string) {
App::sh2p::Handlers::interpolation ($string);
$string = ' '; # Add a space between args
out ',';
}
App::sh2p::Parser::convert (@tokens, @types);
out ',' if $i < $#args;
}
$ntok++; # 0.05 (moved)
}
if ($string && $string ne ' ') {
if ($newline) {
$string .= "\\n"
}
App::sh2p::Handlers::interpolation ($string);
}
elsif ($newline) {
out ",\"\\n\""
}
if (@trailing_tokens) { # 0.05
out " "; # cosmetic
$ntok += @trailing_tokens;
my @trailing_types = App::sh2p::Parser::identify (1, @trailing_tokens);
App::sh2p::Parser::convert (@trailing_tokens, @trailing_types);
}
else {
out ";\n";
}
# An ugly hack, but necessary where the first arg is parenthesised
fix_print_arg();
App::sh2p::Handlers::Handle_close_redirection('w') if $redirection;
return $ntok;
} # do_print
########################################################
sub do_read {
my %args;
my $prompt = 'undef';
my $ntok;
local @ARGV;
# First argument is 'read'
shift @_;
$ntok++;
# Find end of statement
for my $arg (@_) {
last if is_break($arg) || $arg eq ';'; # Inserted in sh2p loop
push @ARGV, $arg;
$ntok++;
}
getopts ('p:rsu:nAa', \%args);
if (exists $args{p} && which_shell() eq 'bash') {
# Bash syntax for prompt
$prompt = $args{p}
}
elsif ($ARGV[0] =~ /^(\w*)\?(.*)$/) { # ksh syntax for prompt
$ARGV[0] = $1 || 'REPLY';
$prompt = $2;
}
# Default variable
@ARGV = ('REPLY') if ! @ARGV;
# Add $ prefix to variable names
# Do I need to pre-define them?
for (my $i = 0; $i < @ARGV; $i++) {
if (exists $args{a} || exists $args{A}) {
$ARGV[$i] = "\@$ARGV[$i]";
if (Register_variable($ARGV[$i], '@')) {
pre_out "my $ARGV[$i];\n";
}
}
elsif ($ARGV[$i] =~ s/^<//) {
my $filename;
if (defined $ARGV[$i] && $ARGV[$i]) {
$filename = $ARGV[$i];
}
else {
$filename = $ARGV[$i+1];
}
pop @ARGV;
pop @ARGV if $i == $#ARGV;
App::sh2p::Handlers::Handle_open_redirection('<', $filename);
}
else {
$ARGV[$i] = "\$$ARGV[$i]";
if (Register_variable($ARGV[$i], '$')) {
pre_out "my $ARGV[$i];\n";
}
}
}
if (exists $args{p} && which_shell() eq 'ksh') {
lib/App/sh2p/Builtins.pm view on Meta::CPAN
}
########################################################
sub do_shopt {
my (undef, $switch, @rest) = @_;
my $ntok = 2;
my @options;
for my $option (@rest) {
last if is_break($option) || $option eq ';' || substr($option,0,1) eq '#';
push @options, $option;
$ntok++;
}
error_out ("Shell option @options being set");
if ($switch eq '-s') {
@g_shell_options{@options} = undef;
}
elsif ($switch eq '+s') {
delete @g_shell_options{@options};
}
else {
error_out ("Unrecognised shopt argument: <$switch>");
}
return $ntok;
}
########################################################
sub do_source {
my (undef, @tokens) = @_;
my $ntok = 1;
error_out ();
error_out "sourced file should also be converted";
# Removed enclosing " in 0.06
iout 'do ';
no_semi_colon();
$ntok += App::sh2p::Parser::join_parse_tokens ('.', @tokens);
reset_semi_colon();
out ';';
return $ntok;
}
########################################################
sub do_touch {
my $ntok = @_;
my $cmd = shift;
local @ARGV = @_;
my %args;
getopts ('acdfmr:t', \%args);
if (keys %args) {
error_out "$cmd options not currently supported";
}
my $text = "# $cmd @_\n";
for my $file (@ARGV) {
if (substr ($file,0,1) eq '#') {
iout "$file\n"; # Output comment first
}
# Remove surrounding quotes
$file =~ s/^([\'\"])(.*)\1/$2/;
$text .= << "END"
if (-e \"$file\") {
# update access and modification times, requires perl 5.8
utime undef, undef, \"$file\";
}
else {
open(my \$fh,'>',\"$file\") or warn \"$file:\$!\";
}
END
}
iout $text;
return $ntok;
}
########################################################
sub do_tr {
my ($cmd, @args) = @_;
my $ntok = 1;
my %args;
local @ARGV = @args;
getopts ('cCsd', \%args);
if (keys %args) {
error_out "$cmd options not currently supported";
}
$ntok = @_ - @ARGV;
return $ntok if !@ARGV;
my $from = shift @ARGV;
$ntok++;
my $to;
if (@ARGV) {
$to = shift @ARGV;
$ntok++;
}
# Strip quotes if there are any
$from =~ s/^\'(.*)\'/$1/g;
$to =~ s/^\'(.*)\'/$1/g;
# common case
if (($from eq '[a-z]' || $from eq '[:lower:]') &&
($to eq '[A-Z]' || $to eq '[:upper:]')) {
iout 'uc ';
}
elsif (($from eq '[A-Z]' || $from eq '[:upper:]') &&
($to eq '[a-z]' || $to eq '[:lower:]')) {
iout 'lc ';
}
else {
# Convert patterns TODO
iout "tr/$from/$to/";
}
return $ntok;
}
########################################################
# typeset [[+-Ulprtux] [-L[n]] [-R[n]] [-Z[n]] [-i[n]] | -f [-tux]]
# [name[=value] ...]
# Needs more work!
sub do_typeset {
my $ntok = @_;
my %args;
#print STDERR "do_typeset: $_[0]\n";
# First argument should be 'typeset' or 'declare'
shift @_;
local @ARGV = @_;
getopts ('UPRTUXLRZ:iftux', \%args);
my %type = (i => 'int',
l => 'lc',
u => 'uc',
Z => '%0nd',
L => '%-s',
R => '%s',
X => '%X',
x => '%x');
my $type = '$';
my @opt = grep {$args{$_}} keys %args;
if (exists $type{$opt[0]}) {
$type = $type{$opt[0]};
}
# These types are not yet supported by other functions
if (@opt > 1) {
if ( $args{Z} && defined $args{Z}) {
$type =~ s/n/$args{Z}/;
}
elsif ( $args{f} ) {
if ($args{u}) {
$ntok += do_autoload ('typeset -fu',@ARGV);
$ntok--; # artificial 1st argument
}
return $ntok;
}
else {
error_out "Only one option supported for typedef or declare";
}
}
my $var = $ARGV[0];
# Remove any assignment for the name
$var =~ s/=.*//;
if (Register_variable ("\$$var", $type) ) {
iout 'my ';
}
#$ntok += January 2009
App::sh2p::Handlers::Handle_assignment (@ARGV);
return $ntok;
}
########################################################
# Need getopt here, but it can't deal with +
# set [+-abCefhkmnpsuvxX] [+-o [option]] [+-A name] [--] [arg ...]
sub do_set {
my $ntok = 1;
# First argument is 'set'
( run in 0.862 second using v1.01-cache-2.11-cpan-fd5d4e115d8 )