App-sh2p

 view release on metacpan or  search on metacpan

lib/App/sh2p/Utils.pm  view on Meta::CPAN

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;

lib/App/sh2p/Utils.pm  view on Meta::CPAN

}

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 {

lib/App/sh2p/Utils.pm  view on Meta::CPAN

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

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;