# 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 testing # VarStructor is an alternative to Perl's reset function, which is expected to be deprecated. It could also be used to print variables and their values, including "my" variables. See comments at top of sub VARSTRUCTOR 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 = ; close IN; $FILE = join ('',@file); $FILE =~ s/[;\n]\s*#[^\n]*//sg; # Delete comments ### Prevent parsing of some quoted strings by deleting here docs. Rarely, 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 ends with an unescaped closing quote. Limitation: an even number of slashes greater than two at the end of the identifier would be wrongly interpreted 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; }