# 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;
}
