Author: dylan
Date: 2004-06-17 23:37:16 -0400 (Thu, 17 Jun 2004)
New Revision: 240
Modified:
trunk/main/common/lib/Haver/Preprocessor.pm
Log:
Haver::Preprocessor now has named levels for DEBUG(),
which can be defined with the -levels option.
all ":opt" options are now "-opt".
There is a -rtdebug option for runtime debugging configuration,
there is a -name option to prepend the name or number or DEFAULT
to debugging messages... I'll document this all later.
DUMP: is now completely gone. Any code that uses it will have to be fixed.
ASSERT: and DEBUG: are now the only two commands right now.
Any preprocessor commands can optionally start with a single comment char now.
This makes them less confusing to people that arn't aware of our
debugging/assertion
system. They just look like insane comments. :)
Also if you remove the "use Haver::Preprocessor;" lines, perl will happily
ignore them.
So,
#ASSERT: 1 == 2;
is the same as
ASSERT: 1 == 2;
Also, next version of this module will allow:
#ASSERT("one is not two"): 1 == 2;
which will die with "one is not two!" if 1 == 2 is false,
instead of dying with "assertion: (1 == 2) failed" or whatever.
Modified: trunk/main/common/lib/Haver/Preprocessor.pm
===================================================================
--- trunk/main/common/lib/Haver/Preprocessor.pm 2004-06-17 22:03:33 UTC (rev
239)
+++ trunk/main/common/lib/Haver/Preprocessor.pm 2004-06-18 03:37:16 UTC (rev
240)
@@ -17,103 +17,150 @@
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
package Haver::Preprocessor;
use strict;
-#use warnings;
+use warnings;
use Carp;
use Filter::Simple;
our $Did;
-our %Opt = (
- ASSERT => 0,
- DUMP => 0,
- DEBUG => undef,
- IFDEF => 0,
+our %Option = (
+ assert => 0,
+ debug => undef,
+ rtdebug => 0,
+ verbose => 0,
+ levels => {},
+ name => 0,
);
FILTER {
- if ($Opt{ASSERT}) {
- s/^\s*ASSERT:\s*(.+?);$/assert($1)/meg;
+ if ($Option{assert}) {
+ s/^#?\s*ASSERT(?:\((.+?)\))?:\s*(.+?);$/assert($1, $2)/meg;
} else {
- s/^\s*ASSERT:/# ASSERT:/mg;
+ s/^#?\s*ASSERT(?:\((.+?)\))?:/# ASSERT:/mg;
}
- if ($Opt{DUMP}) {
- s/^\s*DUMP:\s*(.+?);$/dumper($1)/meg;
+ if (defined $Option{debug}) {
+ s/^#?\s*DEBUG(?:\((\w+?)\))?:\s*(.+?);\s*$/debug($1, $2)/meg;
} else {
- s/^\s*DUMP:/# DUMP:/mg;
+ s/^#?\s*DEBUG(?:\(\s*(\w+?)\s*\))?:/# DEBUG:/mg;
}
-
- if (defined $Opt{DEBUG}) {
- s/^\s*DEBUG(?:\((\d+)\))?:\s*(.+?);\s*$/debug($1, $2)/meg;
- } else {
- s/^\s*DEBUG(?:\((\d+)\))?:/# DEBUG:/mg;
- }
-
- if ($Opt{IFDEF}) {
- s/^\s*IFDEF\s*(.+?)\s*\{/ifdef($1)/meg;
- } else {
- s/^\s*IFDEF\s*(.+?)\s*\{/if (0) {/mg;
- }
-
};
sub import {
my ($class, @args) = @_;
my @keys;
- no strict 'refs';
- foreach my $arg (@args) {
- if ($arg =~ s/^://) {
- if ($arg =~ s/=(.+)$//) {
- $Opt{uc($arg)} = $1;
+ while (my $arg = shift @args) {
+ my $opt = $arg;
+ if ($opt =~ s/-no//) {
+ $Option{$opt} = 0;
+ } elsif ($opt =~ s/^-//) {
+ if (exists $Option{$opt}) {
+ if (not @args or $args[0] =~ /^-/) {
+ if ($opt eq 'debug') {
+ $Option{$opt} = 'ALL';
+ } else {
+ $Option{$opt}++;
+ }
+ } else {
+ $Option{$opt} = shift @args;
+ }
} else {
- $Opt{uc($arg)}++;
+ croak "Unknown option: $arg";
}
- push(@keys, uc($arg));
- } elsif ($arg =~ s/^!//) {
- delete $Opt{uc($arg)};
+ push(@keys, $opt);
}
}
-
- if ($Opt{VERBOSE} and @keys) {
+
+ if ($Option{verbose} and @keys) {
print STDERR __PACKAGE__, ":\n",
- map { sprintf " %-8s = %s\n", $_, what($Opt{$_}) }
sort keys %Opt;
+ map { sprintf " %-8s = %s\n", uc($_),
what($Option{$_}) } sort keys %Option;
}
}
+
+sub show {
+ print STDERR __PACKAGE__, ": ", join(', ', @_), "\n";;
+}
+
+sub what {
+ my $v = shift;
+ return $v;
+}
+
+
sub debug {
my ($level, $rest) = @_;
- if (not defined $level) {
- $level = 1;
+ my $name;
+
+ if ($Option{name}) {
+ my $l = defined $level ? $level : '*';
+ $name = "'($l) ', ";
+ } else {
+ $name = '';
}
- if ($level <= $Opt{DEBUG}) {
- return qq{print STDERR $rest, "\n";};
+
+
+ if ($Option{rtdebug}) {
+ my $str;
+ if (not defined $level) {
+ $str = 'undef';
+ } elsif (not ($level =~ /^\d+$/)) {
+ $str = $level;
+ $str =~ s/'/\\'/g;
+ $str = "'$str'";
+ }
+ my $if = "if Haver::Preprocessor::check($str)";
+ return qq(print STDERR $name $rest, "\n" $if;);
+ } elsif (check($level)) {
+ return qq{print STDERR $name $rest, "\n";};
} else {
return qq{#DEBUG:};
}
}
-sub ifdef {
- my $var = shift;
+sub check {
+ my ($level) = @_;
+ my $l = level($level);
+
+ if ($l != 0 and $l <= level($Option{debug})) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
- no strict 'refs';
- if (defined ${$var}) {
- return 'if (1) {';
+sub level {
+ my ($level) = @_;
+
+ if (not defined $level) {
+ return level("DEFAULT");
+ } elsif ($level =~ /^\d+$/) {
+ return $level;
+ } elsif (exists $Option{levels}{$level}) {
+ return $Option{levels}{$level};
+ } elsif ($level eq "DEFAULT") {
+ return 1;
+ } elsif ($level eq "ALL" and %{ $Option{levels} }) {
+ return max(values %{ $Option{levels} }) || 1;
} else {
- return 'if (0) {';
+ return level("DEFAULT");
}
}
+sub max {
+ my $max = 0;
+ foreach (@_) {
+ if ($max < $_) {
+ $max = $_;
+ }
+ }
+ return $max;
+}
-sub show {
- print STDERR __PACKAGE__, ": ", join(', ', @_), "\n";;
-}
-sub what {
- $_[0] ? 'ON' . " ($_[0])" : 'OFF'
-}
-
sub assert {
+ my $msg = shift;
my $cond = shift;
my $s = ' ' x 18;
my $code = <<CODE;
@@ -126,11 +173,5 @@
return $code;
}
-sub dumper {
- my $expr = shift;
- require Data::Dumper;
- return "warn Data::Dumper::Dumper($expr);";
-}
-
1;
