sub compile_filter() { my @criteria; for my $i ( 0 .. $#ARGV ) { my $snippet = $ARGV[$i]; $snippet =~ s/^\s+//; # prime the autoloader on allcappish barewords if (my @capwords = $snippet =~ /\b (?=[A-Z]) ([A-Z0-9]+) \b/xg) { eval deQQ<<"EO_AUTOLOADED_SUBS"; |QQ| |QQ| use subs qw(@capwords); |QQ| EO_AUTOLOADED_SUBS } # args starting with a backslash or which are a bracketed # espression are interpreted as pattern matches if ($snippet =~ m{ ^ \\ | ^ \[ .* \] $ }x) { $snippet = "/$snippet/"; } my $test_compile = deQ <<'START_TEST'; |Q| use warnings qw[FATAL all]; |Q| my $ignore = START_TEST $test_compile .= deQQ(<<"END_TEST"); |QQ| sub { $snippet }; |QQ| |QQ| # so eval returns true |QQ| 1; |QQ| END_TEST # debug("test compile:\n$test_compile"); eval($test_compile) || die "$0: invalid criterion in '$snippet': $@\n"; $criteria[$i] = "do { $snippet }"; } my $real_code = deQ(<<'START_CODE') . "\t"; |Q| use warnings; |Q| #use warnings qw[FATAL all]; |Q| #no warnings qw[deprecated]; |Q| |Q| sub filter { |Q| |Q| debug(sprintf("testing code point %X", ord())); |Q| |Q| my $result = |Q| START_CODE $real_code .= join("\n &&\n\t" => @criteria) . deQ(<<'END_CODE'); |Q| |Q| ; |Q| |Q| debug("result of " . join(" && ",@criteria) . " is $result"); |Q| return $result; |Q| } |Q| |Q| # so eval returns true |Q| 1; END_CODE debug("CRITERIA are\n$real_code"); eval($real_code) || die; }