File Coverage

blib/lib/App/sh2p/Utils.pm

Criterion	Covered	Total	%
statement	6	200	3.0
branch	0	90	0.0
condition	0	21	0.0
subroutine	2	50	4.0
pod	0	48	0.0
total	8	409	1.9

package App::sh2p::Utils;

use warnings;
use strict;

our $VERSION = '0.06';

require Exporter;
our (@ISA, @EXPORT);
@ISA = ('Exporter');
@EXPORT = qw (Register_variable  Register_env_variable
              Delete_variable    get_variable_type
              print_types_tokens reset_globals
              iout    out        pre_out   error_out    flush_out
              rd_iout rd_remove
              get_special_var    set_special_var    can_var_interpolate
              mark_function      unmark_function    ina_function
              mark_subshell      unmark_subshell    ina_subshell
              inc_block_level    dec_block_level    get_block_level
              is_user_function   set_user_function  unset_user_function
              dec_indent         inc_indent
              rem_empty_string   fix_print_arg
              no_semi_colon      reset_semi_colon   query_semi_colon
              set_in_quotes      unset_in_quotes    query_in_quotes
              out_to_buffer      off_out_to_buffer
              set_shell          which_shell
              open_out_file      close_out_file
              set_break          is_break);

############################################################################

my $g_indent_spacing = 4;

my %g_special_vars = (
      'IFS'      => '" \t\n"',
      'ERRNO'    => '$!',
      'HOME'     => '$ENV{HOME}',
      'PATH'     => '$ENV{PATH}',
      'FUNCNAME' => '(caller(0))[3]',    # Corrected 0.04
      '?'        => '($? >> 8)',
      '#'        => 'scalar(@ARGV)',
      '@'        => '"@ARGV"',
      '*'        => '"@ARGV"',
      '-'        => 'not supported',
      '$'        => '$$',
      '!'        => 'not supported'
      );

# This hash keeps a key for each variable declared
# so we know if to put a 'my' prefix
my %g_variables;

# This hash keeps track of environment variables
my %g_env_variables;

my %g_user_functions;
my $g_new_line       = 1;
my $g_use_semi_colon = 1;
my $g_ina_function   = 0;
my $g_ina_subshell   = 0;
my $g_block_level    = 0;
my $g_indent         = 0;
my $g_errors         = 0;
my $g_is_in_quotes   = 0;
my $g_shell_in_use   = "ksh";

my $g_outh;
my $g_filename;
my $g_out_buffer;    # Main output buffer
my $g_err_buffer;    # INSPECT messages, for output before the statement
my $g_pre_buffer;    # For preamble, like declaring 'my' variables
my $g_ref_redirect;  # Redirect output to buffer instead of script file
my $g_break = \do{my $some_scalar};   # We have to define a 'break' somehow

# Remember position and length for later deletion
my $g_rd_pos = 0;
my $g_rd_len = 0;

#  For use by App::sh2p only
############################################################################
# Called by Handlers::interpolate
sub can_var_interpolate {

   my ($name) = @_;
   my $retn;

   $retn = get_special_var ($name, 1);

   if (defined $retn && $retn !~ /^[\$\@]/) {
       return 0
   }
   else {
       return 1
   }
}
########################################################
# This is primarily for [@] and [*].  Also to prevent globbing inside ""
sub query_in_quotes {
    return $g_is_in_quotes;
}

sub set_in_quotes {
    $g_is_in_quotes = 1;
}

sub unset_in_quotes {
    $g_is_in_quotes = 0;
}

############################################################################

sub set_break {

    return $g_break
}

sub is_break {
    my $ref = shift;

    if (defined $ref && ref($ref) && $ref eq $g_break) {
        return 1
    }
    else {
        return 0
    }
}

############################################################################

sub get_special_var {
   my ($name, $no_errors) = @_;
   my $retn;

   return undef if ! defined $name;

   $no_errors = 0 if ! defined $no_errors;

   # Remove dollar prefix and quotes
   $name =~ s/^([\'\"]?)\$(.*?)\1/$2/;

   if ($name eq '0') {
       $retn = '$0';
   }
   elsif ($name =~ /^(\d+)$/) {
       my $offset = $1 - 1;
       $retn = "\$ARGV[$offset]";
   }
   elsif ($name eq 'PWD') {

       if (!$no_errors) {
           error_out ("Using \$PWD is unsafe: use Cwd::getcwd");
       }
       $retn = '$ENV{PWD}';
   }
   elsif ($name eq '*' && query_in_quotes()) {

       my $glue = $g_special_vars{'IFS'};
       $glue =~ s/^([\"\'])(.*)\1$/$2/;
       $glue = substr($glue,0,1);
       $retn = "join(\"$glue\",\@ARGV)";
   }
   else {
       $retn = $g_special_vars{$name};
   }

   # In a subroutine we use @_
   if (defined $retn && $g_ina_function) {
       $retn =~ s/ARGV/_/;
   }

   return $retn;
}

############################################################################

sub set_special_var {
   my ($name, $value) = @_;
   #print STDERR "set_special_var: <$name> <$value>\n";

   # Do not set environment variables through here - January 2009
   if (substr($g_special_vars{$name},0,4) ne '$ENV') {
       $g_special_vars{$name} = $value;
   }

   return $value;
}

############################################################################

sub no_semi_colon() {
    $g_use_semi_colon = 0;
}

sub reset_semi_colon() {
    $g_use_semi_colon = 1;
}

sub query_semi_colon() {
    return $g_use_semi_colon;
}

############################################################################

sub set_shell {
    my $shell = shift;
    $g_shell_in_use = $shell;
    #print STDERR "Shell set to <$shell>\n";
}

sub which_shell {
    return $g_shell_in_use;
}

#################################################################################

sub mark_function {
    $g_ina_function++;
}

sub unmark_function {
    $g_ina_function--;

    if ($g_ina_function < 0) {
        print STDERR "++++ Internal Error, function count = $g_ina_function\n";
    }
}

sub ina_function {
    return $g_ina_function;
}

#################################################################################

sub mark_subshell {
    $g_ina_subshell++;
}

sub unmark_subshell {

    # Delete all the variables for this subshell

    while (my($key, $value) = each %g_variables) {
          if ($value->[2] == $g_ina_subshell) {
              delete $g_variables{$key};
          }
    }

    $g_ina_subshell--;

    if ($g_ina_subshell < 0) {
        print STDERR "++++ Internal Error, subshell count = $g_ina_subshell\n";
    }
}

sub ina_subshell {
    return $g_ina_subshell;
}

############################################################################
# Return TRUE if NOT already registered
sub Register_variable {

    my ($name, $type) = @_;
    my $level  = get_block_level();

    if (! defined $type) {
        $type = '$'
    }

    # Remove '$' if it exists
    $name =~ s/^\$//;

    # January 2009
    if (exists $g_special_vars{$name} && $name ne 'IFS') {
        return 0;
    }

    if (exists $g_variables{$name}) {

       if ($g_variables{$name}->[0] <= $level &&
           $g_variables{$name}->[2] == $g_ina_subshell) {
           #print STDERR "Register_variable: <$name> <$g_variables{$name}->[1]> returning 0\n";
           return 0
       }
       else {
           # Create the variable with the block level and type
           $g_variables{$name} = [$level, $type, $g_ina_subshell];
           return 1
       }
    }
    elsif (exists $g_env_variables{$name}) {

       $g_env_variables{$name} = undef;
       return 0;
    }
    else {
       # Create the variable with a block level and type

       $g_variables{$name} = [$level, $type, $g_ina_subshell];
       return 1
    }
}

############################################################################

sub Register_env_variable {
    my ($name) = @_;

    # Does not matter if it already exists, or its type
    $g_env_variables{$name} = undef;
}

############################################################################

sub get_variable_type {

    my ($name) = @_;
    my $level  = get_block_level();

    # Remove '$' if it exists - 0.06
    $name =~ s/^\$//;

    if (exists $g_variables{$name}) {

       if ($g_variables{$name}->[0] <= $level) {
           return $g_variables{$name}->[1]
       }
    }

    return '$';      # default
}

############################################################################
# Called by unset and export
sub Delete_variable {
    my ($name) = @_;
    my $level  = get_block_level();

    if (exists $g_variables{$name}) {
       if ($g_variables{$name}->[0] <= $level) {    # ->[0] 0.05
           delete $g_variables{$name}
       }
    }

}

#################################################################################

sub inc_block_level {
    $g_block_level++;
}

sub dec_block_level {

    # Remove registered variables of current block level ->[0] added 0.05
    while (my($key, $value) = each (%g_variables)) {
        delete $g_variables{$key} if $value->[0] == $g_block_level;
    }

    $g_block_level--;

    if ($g_block_level < 0) {
        print STDERR "++++ Internal Error, block level = $g_block_level\n";
        my @caller = caller;
        die "@caller\n";
    }
}

sub get_block_level {
    return $g_block_level;
}

#################################################################################

sub is_user_function {
   my ($name) = @_;

   return (exists $g_user_functions{$name})
}

sub set_user_function {
   my ($name) = @_;

   $g_user_functions{$name} = undef;

   return 1;   # true
}

sub unset_user_function {
   my ($name) = @_;

   delete $g_user_functions{$name} if exists $g_user_functions{$name};

   return 1;   # true
}

#################################################################################

sub mark_new_line {
    $g_new_line = 1;
}

sub new_line {
    return $g_new_line;
}

#################################################################################

sub inc_indent { $g_indent++ if $g_indent < 80 }
sub dec_indent { $g_indent-- if $g_indent > 0  }

#################################################################################

sub open_out_file {
    my ($g_filename, $perms) = @_;

    if ($g_filename eq '-') {
        $g_outh = *STDOUT;
    }
    else {
        open ($g_outh, '>', $g_filename) || die "$g_filename: $!\n";

        # fchmod is not implemented on all platforms
        chmod ($perms, $g_filename) if defined $perms;
        print STDERR "Processing $g_filename:\n";
    }

    $g_out_buffer = '';
    $g_err_buffer = '';
    $g_pre_buffer = '';
}

sub close_out_file {

    flush_out ();

    close ($g_outh);
    print STDERR "\n";
    $g_filename = undef;
}

#################################################################################
# Out to remember redirection position
sub rd_iout {

    $g_rd_pos = length ($g_out_buffer);
    iout (@_);
    $g_rd_len = length ($g_out_buffer) - $g_rd_pos;
}

sub rd_remove {

    if ($g_rd_len) {
        $g_out_buffer = substr ($g_out_buffer, 0, $g_rd_pos) .
                        substr ($g_out_buffer, $g_rd_pos + $g_rd_len);
    }
}

#################################################################################

sub out_to_buffer {
    flush_out();
    ($g_ref_redirect) = @_;
}

sub off_out_to_buffer {
    flush_out();
    $g_ref_redirect = undef;
}

#################################################################################
# Indented out
sub iout {

   #print $g_outh ' ' x ($g_indent * $g_indent_spacing);

   my (@args) = @_;

   if (query_semi_colon()) {
       unshift @args, (' ' x ($g_indent * $g_indent_spacing));
   }

   out (@args);
}

#################################################################################

sub out {

   local $" = '';
   #my @caller = caller();
   #print STDERR "out: <@_> @caller\n";

   $g_out_buffer .= "@_";

   $g_new_line = 0;

}

################################################################################
# I don't like these hacks, but any other way is convoluted
sub fix_print_arg {
    # This avoids 'print (...) interpreted as function'
    #print STDERR "fix_print_arg: <$g_out_buffer>\n";

    if ($g_out_buffer =~ /print/) {
        $g_out_buffer =~ s/(^|[^\'\"]+)(print\s+)\(/$2\"\",(/;
    }
}

sub rem_empty_string {

    return if $g_out_buffer =~ /print/;   # Often required

    # Remove "". at start of calls
    $g_out_buffer =~ s/\(\"\"\./(/;

    # Remove "". in assignments
    $g_out_buffer =~ s/= \"\"\./= /;

}

################################################################################

sub error_out {
    my $msg = shift;

    # 0.06
    if (defined $msg) {
        $g_err_buffer .= "# **** INSPECT: $msg\n";
    }
    else {
        $g_err_buffer .= "\n";
    }

    $g_errors++;
}

################################################################################

sub pre_out {
    my $msg = shift;

    if (!defined $msg) {
        $msg = "\n";
    }

    if (query_semi_colon()) {
        $g_pre_buffer .= (' ' x ($g_indent * $g_indent_spacing)).$msg;
    }
    else {
        $g_pre_buffer .= $msg;
    }

}

#################################################################################

sub flush_out {

   if (defined $g_ref_redirect) {
       $$g_ref_redirect .= $g_err_buffer if $g_err_buffer;
       $$g_ref_redirect .= $g_pre_buffer if $g_pre_buffer;
       $$g_ref_redirect .= $g_out_buffer;

       $g_ref_redirect = undef;
   }
   else {
       print $g_outh $g_err_buffer if $g_err_buffer;
       print $g_outh $g_pre_buffer if $g_pre_buffer;
       print $g_outh $g_out_buffer;
   }

   # Leading space for readability with multiple files
   $g_err_buffer =~ s/\#/ \#/g;
   print STDERR $g_err_buffer;

   $g_out_buffer = '';
   $g_err_buffer = '';
   $g_pre_buffer = '';
   $g_rd_len     = 0;

}

#################################################################################

sub reset_globals {

    %g_variables      = ();
    %g_env_variables  = ();
    %g_user_functions = ();

    $g_out_buffer     = '';
    $g_err_buffer     = '';
    $g_pre_buffer     = '';

    $g_new_line       = 1;
    $g_use_semi_colon = 1;
    $g_ina_function   = 0;
    $g_ina_subshell   = 0;
    $g_block_level    = 0;
    $g_indent         = 0;
    $g_errors         = 0;
    $g_is_in_quotes   = 0;
    $g_shell_in_use   = "ksh";

    $g_rd_pos = 0;
    $g_rd_len = 0;

}

#################################################################################
# Debug purposes only
sub print_types_tokens {

    my ($types, $tokens) = @_;
    my $caller = (caller(1))[3];

    for (my $i = 0; $i < @$types; $i++) {

        if (defined $types->[$i][0]) {
            print STDERR "$caller Type: ".$types->[$i][0].", ";
            print STDERR "Token: ".$tokens->[$i]."\n";
        }
        else {
            print STDERR "**** Type undefined for Token: <".$tokens->[$i].">\n";
        }
    }

    if (@$types != @$tokens) {
        print STDERR "Types array: ".@$types.", Token array: ".@$tokens."\n";
    }
    print STDERR "\n";
}

#################################################################################

# Module end
1;