my $eol = qr/\015|\012|\015\012/;
####
$hash{
$something + $long / $and * $hairy
} = $foo;
####
if ( /blah (foo) gibber/ )
{
$var =~ s/\Q$1\E/bar/g;
}
####
if ( /blah (foo) gibber/ )
{
my $thingy = $1;
$var =~ s/\Q$thingy\E/bar/g;
}
####
$file =~ s/<<(\w+);.*\n\1\n//sg;
####
print <##
$file =~ s/[;\n]\s*#[^\n]*//sg; # Delete comments
####
print "foo; #bar";
####
print <##
print <##
sub twiddle ( $ )
{
my ( $arg ) = @_;
...
}
####
LOOP:
for ( my $I = do { ... }; $i < 20; ++$i ) { ... }
####
#!/usr/bin/perl
require 5.006;
use strict;
use warnings;
# 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
# my @unique = unique_elements @array;
#
# Return a sorted list of unique values out of all values passed in as
# parameters.
sub unique_elements
{
my %seen;
return sort grep { ! $seen{$_}++ } @_;
}
sub VARSTRUCTOR
{
##########################################################
# 1st parameter:
# Assign "show" to print variables and values or
# "clear" to clear variables. For security reasons, the
# default is clear.
# set up default action
my $action = 'clear';
# see if first arg is "show" or "clear"
if ( $_[0] =~ /^\s*(show|clear)\s*$/i )
{
shift; # ok, get rid of it
$action = lc $1;
}
# 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.
my $include = 0;
my $vars = '';
if ( $_[0] =~ /^\s([iIeE]):\s*(.*)$/)
{
shift; # get rid of it
$include = 1 if lc $1 eq 'i';
$vars = $2;
}
# 3rd parameter:
# Target file. Default is $0, indicating the file
# VarStructor is being run from.
# last arg is file name to read the source code from. defaults to
# using the currently-executing script ($0).
my $in_file_name = shift || $0;
##########################################################
my $file = do
{
open my $fh, $in_file_name
or die "opening '$in_file_name': $!";
local $/ = undef; # enter slurp mode
<$fh>;
};
# delete whole-line comments
$file =~ s/^\s*#.*$//mg;
### 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
# (tkil) greediness will kill you here
$file =~ s/<<(\w+);.*?\n\1\n//sg;
# accumulators
my $subs = '';
my $labels = '';
my $out_vars = '';
my @all_vars;
my @hash_disp;
# Isolate subroutines to search, according to $vars
# look for subexpressions like: "subs ( my_sub_1, my_sub_2 )"
# remove it from $vars, then add each subroutine to output.
while ($vars =~ s/ subs \s* \( ( [^\)]+ ) \) \s* //x )
{
my $subs = $1;
foreach my $sub ( map quotemeta, split /,\s*/, $subs )
{
# find the subroutine in the file, save the definition.
$file =~ m! ( # entire expression in $1
^ (\s*) # save indent for later matching
sub \s+ $sub \s*# actual decl start
(?: \( [^\)]+ \) ) # skip prototypes
\s* \{ # opening brace
.*? # whatever (but note non-greedy)
^ \2 \} ) $ # look for brace at same indent
!xsm
or die "couldn't find definition of sub '$sub'";
# save the definition we just found
$subs .= $1;
}
}
# Isolate labeled blocks to search, according to $vars this time,
# look for: labels( ... ) and remove every match from$vars as we
# find them:
while ($vars =~ s/ labels \s* \( ( [^\)]+ ) \) \s* //x )
{
my $labels = $1;
foreach my $label ( map quotemeta, split /,\s*/, $labels )
{
$file =~ m! ( # whole expression ($1)
^ (\s*) # capture label indent ($2)
$label: \s*?
(^ \s*)? # capture loop indent, maybe ($3)
(?: do |
for(?:each)? \(.*?\) |
while \(.*?\) |
until \(.*?\) |
) \s*?
\{
.*? # actual block contents
^ ( \2 | \3 ) \} # closing brace at either label
# or loop indent level
!smx
or die "couldn't find label '$label'" .
" in '$in_file_name'";
# save it for later
$labels .= $1;
}
# Delete or include individual variables, according to $vars
while ($vars =~ s/([\$\@\%][^\d\W]\w*)//x)
{
my $this_var = $1;
if ( $include )
{
$out_vars .= "$this_var='';";
}
else
{
$file =~ s/\Q$this_var\E//g;
}
}
if ( $include )
{
$file = "$out_vars $subs $labels";
}
else
{
# (tkil) this looks completely bogus. WTH?
$file =~ s/\Q($subs|$labels)\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*)//))
{
my $this_var = $2;
$this_var =~ s/^\$(.*)\[.*/\@$1/; # Convert element to its array
my $eval_var;
if ( $action eq 'clear' )
{
$eval_var = $this_var =~ /^\$/ ? "$this_var='';" : "$this_var=();";
}
else
{
# To do: print index numbers next to values
$eval_var = "\\$this_var = $this_var\\n";
}
push (@all_vars, $eval_var);
}
# Extract hashes
while (($file =~ s/([^\\]|[^\\]\\\\)\%([^\d\W]\w*)\s*=//)||
($file =~ s/([^\\]|[^\\]\\\\)\$([^\d\W]\w*)\{[^\n]*\}\s*=//)) {
my $this_hash = $2;
if ( $action eq 'clear' )
{
push @hash_disp, "\%$this_hash=();"
}
else
{
push @hash_disp, "print \"\\n\%$this_hash\\n\";" .
"foreach \$key (sort(keys \%$this_hash))" .
"{print \$key, '=', \$$this_hash\{\$key\}, \"\\n\";}"
}
}
my $all_vars = join '', unique_elements @all_vars;
if ( action eq 'show' )
{
$all_vars =~ s/.*/print"$&";/;
}
eval $all_vars;
my $hash_display = join '', unique_elements @hash_disp;
eval $hash_display;
}