# Copyright (c) 2004 Barry Kaminsky. All rights reserved. This program
+ is free software; you can redistribute it and/or modify it under the
+ same terms as Perl itself.

# Last minute changes made May 2, 2004, 4:00 AM EST without much testi
+ng

# VarStructor is an alternative to Perl's reset function, which is exp
+ected to be deprecated. It could also be used to print variables and 
+their values, including "my" variables. See comments at top of sub VA
+RSTRUCTOR for configuration information. 

#################################
# Test variables (could be deleted)
%hash1=("key1"=>"value1","key2"=>"value2");
$hash2{"key1"}="value1";
$hash2{"key2"}="value2";
$Simple_Var = 'simple';
@Simple_Arr = ('simple1','simple2');
#################################

&VARSTRUCTOR('show', 'E: subs(VARSTRUCTOR)'); # Test parameters

sub VARSTRUCTOR
{
##########################################################

   # 1st parameter:
   # Assign "show" to print variables and values or
   # "clear" to clear variables. For security reasons, the
   # default is clear.

   splice (@_,0,0,'clear') if ($_[0] !~ /^\s*(show|clear)\s*$/i);
   $Function = $_[0];

   # 2nd parameter:
   # Comma-separated list of variables, subroutines, and
   # labels, whose variables will be included or excluded.
   # Labels must be of labeled blocks that are wrapped in
   # braces. This parameter must begin with "I:" or "E:"
   # (include or exclude).
   #
   # You can't include or exclude array elements, hash
   # keys or hash values. Legal variables for this
   # parameter begin with $, @, and %, followed by a
   # string of word characters not beginning with a digit.
   #
   # The label and subroutine name lists must be enclosed
   # in separate sets of parentheses, following the word
   # "labels" or "subs". A comma after the closing
   # parenthesis is necessary when another item in this
   # parameter follows. Commas also must separate the
   # labels and subroutine names within the parentheses.
   # Within the code to be parsed, there must be nothing
   # preceding the labels and the "sub"s on the
   # same line except for optional spaces, and the
   # subroutines and labeled blocks must end with the
   # next "}" that is at the same level of indentation as
   # the first character of the label or the "s" of "sub".
   # Within the parameters, the "&" is optional before
   # subroutine names and the ":" is optional after labels.

   splice (@_,1,0,'') if ($_[1] !~ /^\s*(i:|e:)/i);
   $Variables = "$_[1]";

   # 3rd parameter:
   # Target file. Default is $0, indicating the file
   # VarStructor is being run from.

   $_[2] = "$0" if $_[2] =~ /^\s*$/;
   $Targ = "$_[2]";

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

   open(IN, $Targ) or die 'Can not open file';
   @file = <IN>;
   close IN;
   $FILE = join ('',@file);

   $FILE =~ s/[;\n]\s*#[^\n]*//sg; # Delete comments

   ### Prevent parsing of some quoted strings by deleting here docs. R
+arely, a single quoted string would be mistaken for a variable if not
+ in a here doc.

   # Delete here docs with quoted identifiers
   $FILE =~ s/<<\s*('|"|`)
   ([^\n]*?([^\\]|[^\\]\\\\))\1 # Match here doc identifier, which end
+s with an unescaped closing quote. Limitation: an even number of slas
+hes greater than two at the end of the identifier would be wrongly in
+terpreted as escaping the quote and the here doc value would probably
+ not get deleted.
   .*?\n\2\n//sgx;

   # Delete here docs with unquoted identifiers
   $FILE =~ s/<<(\w+);.*\n\1\n//sg;

   # Isolate subroutines to search, according to $Variables
   while ($Variables =~ s/(?<=subs\()\s*\&?(\w+)\s*(,+|\))//)
   {
      $FILE =~ s/(^|\n)(\s*)sub\s*\Q$1\E\s*\{.*?\n\2\}//s;
      $ISOLATED_SUBS .= "$&";
   }

   # Isolate labeled blocks to search, according to $Variables
   while ($Variables =~ s/(?<=labels\()\s*(\w+):?\s*(,+|\))//)
   {
      $FILE =~ s/(^|\n)(\s*)\Q$1\E:.*?\{.*?\n\2\}//s;
      $ISOLATED_LABELS .= "$&";
   }

   # Delete or include individual variables, according to $Variables
   while ($Variables =~ s/[\$|\@|\%][^\d\W]\w*//)
   {
      $ONE_VAR = "$&";
      $VARS_ONLY .= "$ONE_VAR='';" if $Variables =~ /^\s*I:/i;
      $FILE =~ s/\Q$ONE_VAR\E//g if $Variables =~ /^\s*E:/i;
   }

   $FILE = "$VARS_ONLY $ISOLATED_SUBS $ISOLATED_LABELS" if $Variables 
+=~ /^\s*I:/;
   $FILE =~ s/\Q($ISOLATED_SUBS|$ISOLATED_LABELS)\E// if $Variables =~
+ /^\s*E:/;

   # Find arrays. If not an array used in push, require an equals sign
+ to avoid quoted email addresses that look like arrays.
   while (($FILE =~ s/([^\\]|[^\\]\\\\)(\@[^\d\W]\w*)\s*=//)||

   # Find scalars/array elements after ++ or --
   ($FILE =~ s/(?:[^\\]|[^\\]\\\\)(\+\+|--)\s*(\$[^\d\W]\w*(\[.*?\])?)
+//)||

   # Find scalars/array elements before assignment operators, "++", "-
+-", "." or ".="
   ($FILE =~ s/([^\\]|[^\\]\\\\)(\$[^\d\W]\w*(\[.*?\])?)\s*(=|\+=|-=|\
+*=|\/=|\%=|\*\*=|\+\+|--|\.)//)||

   # Find arrays assigned to with push.
   ($FILE =~ s/push[^\w_]*([^\\]|[^\\]\\\\)(\@[^\d\W]\w*)//))
   {
      $ONE_VAR = $2;
      $ONE_VAR =~ s/^\$(.*)\[.*/\@$1/; # Convert element to its array
      ($EVAL_VAR = $ONE_VAR =~ /^\$/ ? "$ONE_VAR='';" : "$ONE_VAR=();"
+) if $Function =~ /^clear$/i;

      # To do: print index numbers next to values
      ($EVAL_VAR = "\\$ONE_VAR = $ONE_VAR\\n") if $Function =~ /^show$
+/i;
      push (@ALL_VAR, "$EVAL_VAR");
   } 

   # Extract hashes
   while (($FILE =~ s/([^\\]|[^\\]\\\\)\%([^\d\W]\w*)\s*=//)||
   ($FILE =~ s/([^\\]|[^\\]\\\\)\$([^\d\W]\w*)\{[^\n]*\}\s*=//))
   {
      $ONE_HASH = "$2";
      push @HASH_DISPLAY, "print \"\\n\%$ONE_HASH\\n\";" .
      "foreach \$key (sort(keys \%$ONE_HASH))" .
      "{print \$key, '=', \$$ONE_HASH\{\$key\}, \"\\n\";}"
      if $Function =~ /^show$/;

      push @HASH_DISPLAY, "\%$ONE_HASH=();" if $Function =~ /^clear$/;
   }

   @ALL_VAR = grep {++$count{$_} < 2} @ALL_VAR;
   @ALL_VAR = sort @ALL_VAR;
   $ALL_VAR = join ('',@ALL_VAR);
   $ALL_VAR =~ s/.*/print"$&";/ if $Function =~ /^show$/i;
   eval $ALL_VAR;

   @HASH_DISPLAY = grep {++$count{$_} < 2} @HASH_DISPLAY;
   @HASH_DISPLAY = sort @HASH_DISPLAY;
   $HASH_DISPLAY = join ('',@HASH_DISPLAY);
   eval $HASH_DISPLAY;
}
[download]