Carp-Datum-0.1.3/0040700000605300000120000000000007323625311012766 5ustar dhooverstaffCarp-Datum-0.1.3/README0100644000605300000120000001032407421373525013663 0ustar dhooverstaff Carp::Datum 0.1 Copyright (c) 2002, Dave Hoover Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi ------------------------------------------------------------------------ This program is free software; you can redistribute it and/or modify it under the terms of the Artistic License, a copy of which can be found with perl. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Artistic License for more details. ------------------------------------------------------------------------ ======================================================================== This module is known to exercise a bug in perl 5.6.0. Don't use that version of perl: use 5.005_03, or try 5.6.1. If ran under 5.6.0 nonetheless, the t/failmsg_on tests will be skipped. ======================================================================== *** This is alpha software -- use at your own risks *** Name DSLI Description Info ----------- ---- -------------------------------------------- ----- Carp::Datum adpf Debugging And Tracing Ultimate Module CDE ======================================================================== This module is the Perl version of a C/C++ library, called DATUM, which Christophe Dehaudt & Raphael Manfredi used in many programs since 1996. Following is the preamble to the DATUM library, written by Raphael in 1998: --- Begin Exerpt: A bug in a software system may have multiple causes. It can be the result of an oversight, a typo, a misunderstanding, a misuse, etc... Being able to identify the presence of a bug, and then nail it down as quickly as possible were the reasons of our deciding to create debugging foundations. During the bug hunting phase, a developer needs to be able to trace routine execution around the suspected bug spot, which is a moving target usually. Flexibility of the tracing subsystem is therefore mandatory to only be able to trace a specific area of the software. Detecting bugs as early as possible is also recognized as the most efficient route to quality, and it is certainly economically justified. By following the Design by Contract principle, i.e. by inserting pre- and post-conditions to specify the interfaces, one guards against improper implementations and also formally documents the original intent of the designer. That is also an invaluable aid during maintenance or evolution, since it avoids improper use of existing interfaces that could otherwise lead to havoc when left undetected. NOTE: It is a wise practice to develop and test a piece of software with all the assertions turned on (that includes pre- and post-conditions, but also any additional assertion checking within the code), and release it with only pre-conditions enabled. Indeed, software correctness is compromised when any pre-condition is violated. --- End Exerpt. Carp::Datum implements the following features: * Programming by contract: pre-conditions, post-conditions, assertions. * Flow control tracing: routine entry, arguments, returned values * Dynamic (i.e. runtime) configuration via mini language to tailor debugging and/or tracing at the routine / file / package / type level. * Ability to statically remove all assertions and flow control tracing hooks in modules making use of Carp::Datum. * Cooperation with Log::Agent for tracing. In order to do so, the following routines are provided: Assertions: DREQUIRE, DENSURE, DASSERT Flow control: DFEATURE, DVAL, DARY, DVOID Tracing: DTRACE A sepcial precondition, VERIFY, is always kept (i.e. never stripped) and can be used for checking important conditions, to write: VERIFY $pre_condition, "message"; where one would otherwise use a test like: logcroak "message" if !$pre_condition; in regular code. Over the years, the original authors found DATUM to be a very valuable aid in large software, especially in situations where the bug tolerence is zero: OS modules, DB access/replication modules. Send bug reports, hints, tips, suggestions to Dave Hoover at . Carp-Datum-0.1.3/MANIFEST0100644000605300000120000000232507323625310014127 0ustar dhooverstaffREADME The main README file MANIFEST This shipping list ChangeLog List of changes Datum.pm Main runtime file Datum/Assert.pm Assert expression extractor Datum/Cfg.pm Dynamic DATUM configuration Datum/Flags.pm Flag constants Datum/MakeMaker.pm Offer to strip Carp::Datum calls Datum/Parser.pm Generated by perl-byacc Datum/Parser.y Parser for dynamic config language Datum/Strip.pm Strips most DATUM calls lexically Datum/Makefile Makefile for Datum subdirectory Makefile.PL Generic Makefile template scripts/datum_strip.PL Wrapper on Carp::Datum::Strip t/basic_dflt.t Tests basic default settings t/basic_off.t Tests with DATUM switched off t/basic_on.t Tests with DATUM switched on t/code.pl Common code for regression tests t/test.pl Testing code using Carp::Datum t/trace_off.t Tests tracing when DATUM switched off t/trace_on.t Tests tracing when DATUM switched on Carp-Datum-0.1.3/ChangeLog0100644000605300000120000000153407421373407014557 0ustar dhooverstaffMon Jan 14 17:36:34 EST 2002 Dave Hoover . Description: Minor updates and corrections throughout documention. Fri Jul 13 19:06:15 MEST 2001 Christophe Dehaudt . Description: Added DEBUG CONFIGURATION and HISTORY AND CREDITS sections in the main manpage. Fixed demo script to include leading DFEATURE call. Random cleanup in Datum::Cfg documentation. Wed May 30 23:10:54 MEST 2001 Raphael Manfredi . Description: Added LIMITATIONS section to warn about stringify overloading. Since the argument list may be dumped at DFEATURE time, and $self is part of that list, we would recurse when DFEATURE is called and the argument list is printed. Sun Mar 25 17:40:43 MEST 2001 Raphael Manfredi Version 0.1.0. Initial public alpha relase. Carp-Datum-0.1.3/Datum.pm0100644000605300000120000010406407421373513014415 0ustar dhooverstaff# -*- Mode: perl -*- # # $Id: Datum.pm,v 0.1.1.2 2001/07/13 17:04:58 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Datum.pm,v $ # Revision 0.1.1.2 2001/07/13 17:04:58 ram # patch2: integrated mods made by CDE: # patch2: added DEBUG CONFIGURATION section # patch2: added HISTORY AND CREDITS section # patch2: fixed demo script to include leading DFEATURE call # # Revision 0.1.1.1 2001/05/30 21:09:36 ram # patch1: added LIMITATIONS section to warn about stringify overloading # # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package Carp::Datum; use vars qw($VERSION); $VERSION = '0.101'; use Log::Agent; use Log::Agent qw(logwrite); use Getargs::Long qw(ignorecase); use Carp::Datum::Flags; require Carp::Datum::Parser; require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS); @ISA = qw(Exporter); @EXPORT = (qw(DLOAD_CONFIG DFEATURE DTRACE DASSERT VERIFY DREQUIRE DENSURE DVAL DARY DVOID implies equiv ), @Carp::Datum::Flags::EXPORT); @EXPORT_FAIL = qw(on off); @EXPORT_OK = qw(on off); %EXPORT_TAGS = (all => \@EXPORT); use vars qw( $DBG $DEBUG_TABLE $CFG ); $DBG = DBG_OFF; require Carp::Datum::Cfg; $CFG = Carp::Datum::Cfg->make(); $DEBUG_TABLE = {default => { debug => [DBG_ALL, 0], trace => [TRC_ALL, 0], args => -1 }, alias => [] }; # # ->export_fail # # Called by Exporter when one of the symbols listed in @EXPORT_FAIL is # indeed exported. # sub export_fail { my ($self, @syms) = @_; my @failed; foreach my $sym (@syms) { if ($sym eq 'on') { $DBG = DBG_ON } elsif ($sym eq 'off') { $DBG = DBG_OFF } else { push(@failed, $sym) } } Log::Agent::DATUM_is_here() if $DBG; # Intercept Log::Agent traces return @failed; # Empty list if OK } # # DLOAD_CONFIG # # read the debug input to get the debug instructions. Filename # content and raw string configuration are concatened to be parsed. # # Arguments: # -file => $filename: file to load [optionnal] # -config => $string: string which contains config set up [optionnal] # -trace => boolean: print the parsing result when true [optionnal] # sub DLOAD_CONFIG { return unless $DBG; my ($dump_parser, @remaining) = cgetargs(@_, {-strict => 0, -extra => 1}, [qw(trace)]); require Carp::Datum::Cfg; $CFG = Carp::Datum::Cfg->make(@remaining); Log::Agent::DATUM_is_here(); # Intercept Log::Agent traces return unless $dump_parser == 1; require Data::Dumper; DTRACE(TRC_DEBUG, Data::Dumper::Dumper($CFG->cfg_table)); return; } # # DFEATURE # # sub DFEATURE { return unless $DBG && $CFG->check_debug(DBG_FLOW); # # This routine is usually called as: # # DFEATURE(my $f, "any", "other", $param); # # so the first argument is a lexical lvalue. # # To ensure the tracing capabilities, we rely on the immediate collecting # of the "$f" lexical as soon as the scope of the routine is left: the # DESTROY hook will be called on the Carp::Datum object, so we'll know. # # One day, Perl's garbage collecting scheme may loose this systematic # destroying of lexicals by differing object reclaiming if reference # counting is abandonned and GC algorithms requiring object traversal # are implemented. # # When that day comes, the alternative will be to systematically use # the DVOID, DVAL and DARY on returning, and to maintain a parallel # stack here. Exceptions will be detected by tagging the depth level # and checking it at DVOID, DVAL or DARY time. This will probably require # probing the subroutine name of our caller, and computing the depth # of the perl stack if the caller does not match. And to handle recursion, # and exceptions happening in there, to flag places where eval() is used # so that we know where to look if the stack depth is not as deep as # expected. # # A huge work anyway, so despite reference counting not being the best # GC algorithm, it has the nice property of being somewhat predictible. # It's usually bad to depend on such knowledge, but here that's very, # and I mean VERY, convenient. # # -- RAM, 01/10/2000 # $_[0] = new Carp::Datum(@_[1 .. $#_]); return; # XXX use weakrefs in 5.6 and above to keep track of those objects in # XXX a parallel stack, and to fix display ordering in DESTROY, where # XXX the caller is sometimes destroyed before the callee. } # # DVOID # DVAL # DARY # # Print the return code and effectively return it. # # When the given parameter is an array and the return context is also # an array, there is no trouble to determine what is returned: it is the # array. # # But when the context is a scalar, it is more difficult since the # parameter might be either a regular array, or a list of # statement. For the fist case, the function must return the number of # elements , and the latter form must return the last statements # value. # # Use DVOID when you would otherwise say "return;". # Use DVAL to return a scalar, or the last element of a list when called in # scalar context, the list when called in array context (wantarray). # Use DARY when you return a list, and it will be taken as the amount of items # when you're called in scalar context, and as the list otherwise. # # To be properly stripped when assertions are to be removed from the code, # one should say: # # return DVAL 1; # will become "return 1;" # # and NOT: # # return DVAL(1); # will really become "return (1);" # # unless you really mean: # # return DVAL (1); # # i.e. the DVOID, DVAL and DARY words are to be thought as "tags" that will be # removed, without otherwise touching anything else. # sub DVOID { return unless $DBG && $CFG->check_debug(DBG_RETURN); trace("Returning" . where(1)); return; } sub DVAL { return wantarray ? @_: $_[$#_] unless $DBG && $CFG->check_debug(DBG_RETURN); # fix the arg list when the value to return is undef @_ = (undef) if $#_ == -1; trace("Returning: " . (wantarray ? "(" . (join ', ', (map {data_format($_)} @_)) . ")": data_format($_[$#_])) .where(1)); return (wantarray ? @_ : $_[$#_]); } sub DARY { return @_ unless $DBG && $CFG->check_debug(DBG_RETURN); # fix the arg list when the value to return is undef # @_ = () if $#_ == -1; # get the scalar of the array my $a = @_; trace("Returning: " . (wantarray ? "(" . (join ', ', (map {data_format($_)} @_)) . ")": data_format(scalar @_)) .where(1)); return @_; } # # DTRACE # # Arguments Form 1: # {-level => level, -marker => marker}, message # # Arguments Form 2: # level, message # # Arguments Form 3: # message # sub DTRACE { return if $DBG && !$CFG->check_debug(DBG_TRACE); # parse arguments my $level = TRC_DEBUG; my $marker = ''; if (ref $_[0] eq 'HASH') { my $hashref = shift; if (defined $hashref->{-level}) { $level = $hashref->{-level}; } if (defined $hashref->{-marker}) { $marker = $hashref->{-marker}; } } else { if ($_[0] =~ /^\d+$/) { # take the first argument as level if it is not alone if ($#_ > 0) { $level = shift; } } } if ($DBG) { # check whether tracing level is permitted return unless $CFG->check_trace($level); trace(join('', @_) . where(1), $marker); return; } # # No debugging activated, call must be remapped to Log::Agent. # %Carp::Datum::logmap = ( TRC_EMERGENCY() => [\&logdie, undef], # panic TRC_ALERT() => [\&logerr, undef], TRC_CRITICAL() => [\&logerr, undef], TRC_ERROR() => [\&logerr, undef], TRC_WARNING() => [\&logwarn, undef], TRC_NOTICE() => [\&logsay, undef], TRC_INFO() => [\&logtrc, 'info'], TRC_DEBUG() => [\&logtrc, 'debug'], ) unless defined %Carp::Datum::logmap; my $entry = $Carp::Datum::logmap{$level}; # # Use magic "goto &" to forget about the DTRACE call. # # That's important if they use the caller indication feature # in Log::Agent. Otherwise, all calls would be traced from here. # if (defined $entry) { my ($fn, $loglvl) = @$entry; @_ = defined $loglvl ? ($loglvl, join('', @_)) : (join '', @_); goto &$fn; } else { @_ = (join '', @_); goto &logerr; } return; } # # DASSERT # sub DASSERT { return assert(DBG_PANIC|DBG_STACK, 'assertion', @_) unless $DBG; my $dbg_flag = $CFG->flag('debug'); return unless $dbg_flag & DBG_ASSERT; assert($dbg_flag, 'assertion', @_); } # # DREQUIRE # sub DREQUIRE { return assert(DBG_PANIC|DBG_STACK, 'pre-condition', @_) unless $DBG; my $dbg_flag = $CFG->flag('debug'); return unless $dbg_flag & DBG_REQUIRE; assert($dbg_flag, 'pre-condition', @_); } # # VERIFY # # same behavior as a DREQUIRE, but it cannot be disabled with the # Datum debug flag. It is useful to protect the edge of a module from # the external invocation. sub VERIFY { my ($test, $string) = @_; assert(DBG_PANIC|DBG_STACK, 'verify', @_); } # # DENSURE # sub DENSURE { return assert(DBG_PANIC|DBG_STACK, 'post-condition', @_) unless $DBG; my $dbg_flag = $CFG->flag('debug'); return unless $dbg_flag & DBG_ENSURE; assert($dbg_flag, 'post-condition', @_); } # # implies # # Implement the logical operation (migth be useful for assertion) # sub implies { return (!$_[0]) || $_[1]; } # # equiv # # Implement the logical operation (migth be useful for assertion) # sub equiv { return !$_[0] == !$_[1]; } # # assert # # perhaps modify the signature when caching features is implemented for # CFG # sub assert { my $debug_flag = shift; my $assert_type = shift; my $test = shift; return if $test; # # Carp::Datum is potentially used by many modules. Its core code # must be as small as possible to compile quickly. # # Here, we get an assertion failure, an exceptional event. It's ok # to impose a further delay. # require Carp::Datum::Assert; Carp::Datum::Assert->import(qw(assert_expr stack_dump)); my $expr = assert_expr(2); my $msg; $msg = ": " . join('', @_) if @_; $msg .= " ($expr)" if $expr ne ''; $msg = $msg . where(2); my $stack = stack_dump(2); # # When debugging, log to the debug file. # if ($DBG) { trace("$assert_type FAILED". $msg, "!!"); if ($debug_flag & DBG_STACK) { foreach my $item (@$stack) { trace($item, "!!"); } } } # # Always log something to the error channel anyway # # If they configured Log::Agent with -confess, they'll get a # stack dump as well on panic. # if ($debug_flag & DBG_PANIC) { logdie "PANIC: $assert_type FAILED" . $msg; } else { logwarn "$assert_type FAILED" . $msg; } } # # alias # # Alias filename, to strip long filenames. # sub alias { my ($name) = @_; for my $alias (@{$CFG->cfg_alias}) { my ($x, $y) = @{$alias}; if (substr($name, 0, length $x) eq $x) { substr($name, 0, length $x) = $y; last; } } return $name; } # # where # sub where { my ($level) = @_; my ($package, $filename, $line) = caller($level); $filename = alias($filename); return " [$filename:$line]"; } my $DEPTH = 0; my $max_trace_depth = -1; my $space = "| "; # # ->new # # Create a new object, meant to be destroyed at function exit # sub new { my $this = shift @_; my $class = ref($this) || $this; my $self = {}; # get the max argument setting (by specifying 'args(yes|no|num);' # in config file. # NOTE: that is done before the arg query since the call is # modifying the DB::args value with different values. my $max_arg = $CFG->flag('args', 1); my $offset = 2; my ($package, $filename, $line) = caller($offset); my $sub = (caller($offset + 1))[3]; $sub = $sub ? "$sub()" : "global"; my $from = ''; $from = " from $sub at " . alias($filename) . ":$line" if defined $line; package DB; # ignore warning use vars qw(@args); my @caller = caller(2); package Carp::Datum; # grab info from leftover parameters my $info = @_ ? ": '@_'": ""; if (@caller) { # shrink the list of argument if too long my $shrinked = 0; if ($max_arg >= 0 && $#DB::args >= $max_arg ) { $#DB::args = $max_arg - 1; $shrinked = 1; } my @args_list = map { data_format($_) } @DB::args; push @args_list, "..." if $shrinked; $self->{'call'} = "$caller[3](" . join(", ", @args_list) . ")$info"; } else { $self->{'call'} = "global$info" } $self->{'call'} .= $from; trace("+-> " . $self->{'call'} . where($offset)); $self->{'depth'} = $DEPTH++; bless $self, $class; } # # ->DESTROY # sub DESTROY { my $self = shift; my $prev_depth = $DEPTH; $DEPTH = $self->{'depth'}; trace("+-< " . $self->{'call'}); $DEPTH = $prev_depth - 1; } # # trace # sub trace { my ($message, $header) = @_; $header .= " "; $header = substr($header, 0, 3); logwrite('debug', 'debug', $header . $space x $DEPTH . $message); } # # data_format # # return the given value to a printable form. # sub data_format { return "undef" unless defined $_[0]; return $_[0] if (ref $_[0]) || ($_[0]=~ /^-?[1-9]\d{0,8}$/) || (($_[0] + 0) eq $_[0]) ; require Data::Dumper; return Data::Dumper::qquote($_[0] ); } 1; =head1 NAME Carp::Datum - Debugging And Tracing Ultimate Module =head1 SYNOPSIS # In modules use Carp::Datum; # Programming by contract sub routine { DFEATURE my $f_, "optional message"; # $f_ is a lexical lvalue here my ($a, $b) = @_; DREQUIRE $a > $b, "a > b"; $a += 1; $b += 1; DASSERT $a > $b, "ordering a > b preserved"; my $result = $b - $a; DENSURE $result < 0; return DVAL $result; } # Tracing DTRACE "this is a debug message"; DTRACE TRC_NOTICE, "note: a = ", $a, " is positive"; DTRACE {-level => TRC_NOTICE, -marker => "!!"}, "note with marker"; # Returning return DVAL $scalar; # single value return DARY @list; # list of values # In application's main use Carp::Datum qw(:all on); # turns Datum "on" or "off" DLOAD_CONFIG(-file => "debug.cf", -config => "config string"); =head1 DESCRIPTION The C module brings powerful debugging and tracing features to development code: automatic flow tracing, returned value tracing, assertions, and debugging traces. Its various functions may be customized dynamically (i.e. at run time) via a configuration language allowing selective activation on a routine, file, or object type basis. See L for configuration defails. C traces are implemented on top of C and go to its debugging channel. This lets the application have full control of the final destination of the debugging information (logfile, syslog, etc...). C can be globally turned on or off by the application. It is off by default, which means no control flow tracing (routine entry and exit), and no returned value tracing. However, assertions are still fully monitored, and the C calls are redirected to C. The C version of C is implemented with macros, which may be redefined to nothing to remove all assertions in the released code. The Perl version cannot be handled that way, but comes with a C module that will B remove all the assertions, leaving only C calls. Modules using C can make use of C in their Makefile.PL to request stripping at build time. See L for instructions. Here is a small example showing what traces look like, and what happens by default on assertion failure. Since C is not being customized, the debugging channel is STDERR. In real life, one would probably customize Log::Agent with a file driver, and redirect the debug channel to a file separate from both STDOUT and STDERR. First, the script, with line number: 1 #!/usr/bin/perl 2 3 use Carp::Datum qw(:all on); 4 5 DFEATURE my $f_; 6 7 show_inv(2, 0.5, 0); 8 9 sub show_inv { 10 DFEATURE my $f_; 11 foreach (@_) { 12 print "Inverse of $_ is ", inv($_), "\n"; 13 } 14 return DVOID; 15 } 16 17 sub inv { 18 DFEATURE my $f_; 19 my ($x) = @_; 20 DREQUIRE $x != 0, "x=$x not null"; 21 return DVAL 1 / $x; 22 } 23 What goes to STDOUT: Inverse of 2 is 0.5 Inverse of 0.5 is 2 FATAL: PANIC: pre-condition FAILED: x=0 not null ($x != 0) [./demo:20] The debugging output on STDERR: +-> global [./demo:5] | +-> main::show_inv(2, 0.5, 0) from global at ./demo:7 [./demo:10] | | +-> main::inv(2) from main::show_inv() at ./demo:12 [./demo:18] | | | Returning: (0.5) [./demo:21] | | +-< main::inv(2) from main::show_inv() at ./demo:12 | | +-> main::inv(0.5) from main::show_inv() at ./demo:12 [./demo:18] | | | Returning: (2) [./demo:21] | | +-< main::inv(0.5) from main::show_inv() at ./demo:12 | | +-> main::inv(0) from main::show_inv() at ./demo:12 [./demo:18] !! | | | pre-condition FAILED: x=0 not null ($x != 0) [./demo:20] !! | | | main::inv(0) called at ./demo line 12 !! | | | main::show_inv(2, 0.5, 0) called at ./demo line 7 ** | | | FATAL: PANIC: pre-condition FAILED: x=0 not null ($x != 0) [./demo:20] | | +-< main::inv(0) from main::show_inv() at ./demo:12 | +-< main::show_inv(2, 0.5, 0) from global at ./demo:7 +-< global The last three lines were manually re-ordered for this manpage: because of the pre-condition failure, Perl enters its global object destruction routine, and the destruction order of the lexicals is not right. The $f_ in show_inv() is destroyed before the one in inv(), resulting in the inversion. To better please the eye, it has been fixed. And the PANIC is emitted when the pre-condition failure is detected, but it would have messed up the trace example. Note that the stack dump is prefixed with the "!!" token, and the fatal error is tagged with "**". This is a visual aid only, to quickly locate troubles in logfiles by catching the eye. Routine entry and exit are tagged, returned values and parameters are shown, and the immediate caller of each routine is also traced. The final tags C refer to the file name (here the script used was called "demo") and the line number where the call to the C routine is made: here the C at line 10. It also indicates the caller origin: here, the call is made at line 7 of file C. The special name "global" (without trailing () marker) is used to indicate that the caller is the main script, i.e. there is no calling routine. Returned values in inv() are traced as "(0.5)" and "(2)", and not as "0.5" and "2" as one would expect, because the routine was called in non-scalar context (within a print statement). =head1 PROGRAMMING BY CONTRACT =head2 Introduction The Programming by Contract paradigm was introduced by Bertrand Meyer in his I book, and later implemented natively in the Eiffel language. It is very simple, yet extremely powerful. Each feature (routine) of a program is viewed externally as a supplier for some service. For instance, the sqrt() routine computes the square root of any positive number. The computation could be verified, but sqrt() probably provides an efficient algorithm for that, and it has already been written and validated. However, sqrt() is only defined for positive numbers. Giving a negative number to it is not correct. The old way (i.e. in the old days before Programming by Contract was formalized), people implemented that restriction by testing the argument I of sqrt(), and doing so in the routine itself to factorize code. Then, on error, sqrt() would return -1 for instance (which cannot be a valid square root for a real number), and the desired quantity otherwise. The caller had then to check the returned value to determine whether an error had occurred. Here it is easy, but in languages where no out-of-band value such as Perl's C are implemented, it can be quite difficult to both report an error and return a result. With Programming by Contract, the logic is reversed, and the code is greatly simplified: =over 4 =item * It is up to the caller to always supply a positive value to sqrt(), i.e. to check the value first. =item * In return, sqrt() promises to always return the square root of its argument. =back What are the benefits of such a gentlemen's agreement? The code of the sqrt() routine is much simpler (meaning fewer bugs) because it does not have to bother with handling the case of negative arguments, since the caller promised to never call with such invalid values. And the code of the caller is at worst as complex as before (one test to check that the argument is positive, against a check for an error code) and at best less complex: if it is known that the value is positive, it doesn't even have to be checked, for instance if it is the result of an abs() call. But if sqrt() is called with a negative argument, and there's no explicit test in sqrt() to trap the case, what happens if sqrt() is given a negative value, despite a promise never to do so? Well, it's a bug, and it's a bug in the caller, not in the sqrt() routine. To find those bugs, one usually monitors the assertions (pre- and post-conditions, plus any other assertion in the code, which is both a post-condition for the code above and a pre-condition for the code below, at the same time) during testing. When the product is released, assertions are no longer checked. =head2 Formalism Each routine is equipped with a set of pre-conditions and post-conditions. A routine I is therefore defined as: r(x) pre-condition body post-condition The pre- and post-conditions are expressions involving the parameters of r(), here only I, and, for the post-condition, the returned value of r() as well. Conditions satisfying this property are made visible to the clients, and become the routine's I, which can be written as: =over 4 =item * You, the caller, promise to always call me with my pre-condition satisfied. Failure to do so will be a bug in your code. =item * I promise you, the caller, that my implementation will then perform correctly and that my post-condition will be satisfied. Failure to do so will be a bug in my code. =back In object-oriented programming, pre- and post-conditions can also use internal attributes of the object, but then become debugging checks that everything happens correctly (in the proper state, the proper order, etc...) and cannot be part of the contract (for external users of the class) since clients cannot check that the pre-condition is true, because it will not have access to the internal attributes. Furthermore, in object-oriented programming, a redefined feature must I the pre-condition of its parent feature and I its post-condition. It can also keep them as-is. To fully understand why, it's best to read Meyer. Intuitively, it's easy to understand why the pre-condition cannot be strengthened, nor why the post-condition cannot be weakened: because of dynamic binding, a caller of r() only has the static type of the object, not its dynamic type. Therefore, it cannot know in advance which of the routines will be called amongst the inheritance tree. =head2 Common Pitfalls =over 4 =item * Do not write both a pre-condition and a test with the same expression. =item * Never write a pre-condition when trying to validate user input! =item * Never write a test on an argument when failure means an error, use a pre-condition. If a pre-condition is so important that it needs to always be monitored, even within the released product, then C provides C, a pre-condition that will always be checked (i.e. never stripped by C). It can be used to protect the external interface of a module against abuse. =head2 Implementation With Carp::Datum, pre-conditions can be given using C or C. Assertions are written with C and post-conditions given by C. Although all assertions could be expressed with only C, stating whether it's a pre-condition with C also has a commentary value for the reader. Moreover, one day, there might be an automatic tool to extract the pre- and post-conditions of all the routines for documentation purposes, and if all assertions are called C, the tool will have a hard time figuring out which is what. Moreover, remember that a pre-condition failure I means a bug in the caller, whilst other assertion failures means a bug near the place of failure. If only for that, it's worth making the distinction. =back =head1 INTERFACE =head2 Control Flow =over 4 =item DFEATURE my $f_, I This statement marks the very top of any routine. Do not omit the C which is very important to ensure that what is going to be stored in the lexically scoped $f_ variable will be destroyed when the routine ends. Any name can be used for that lexical, but $f_ is recommended because it is both unlikely to conflict with any real variable and short. The I part will be printed in the logs at routine entry time, and can be used to flag object constructors, for instance, for easier grep'ing in the logs afterwards. =item return DVOID This can be used in place of an ordinary C from a routine. It allows tracing of the return statement. =item return DVAL I Use this form when returning something in scalar context. Do not put any parentheses around I, or it will be incorrectly stripped by C. Examples: return DVAL 5; # OK return DVAL ($a == 1) ? 2 : 4; # WRONG (has parenthesis) return DVAL (1, 2, 4); # WRONG (and will return 4) my $x = ($a == 1) ? 2 : 4; return DVAL $x; # OK return DVAL &foo(); # Will be traced as array context Using DVAL allows tracing of the returned value. =item return DARY (I) Use this form when returning something in list context. Using DARY allows tracing of the returned values. return DARY @x; If a routine returns something different depending on its calling context, then write: return DARY @x if wantarray; return DVAL $x; Be very careful with that, otherwise the program will behave differently when the C and C tokens are stripped by C, thereby raising subtle bugs. =back =head2 Programming by Contract =over 4 =item C I, I Specify a pre-condition I, along with a I that will be printed whenever the pre-condition fails, i.e. when I evaluates to false. The I string may be used to dump faulty values, for instance: DREQUIRE $x > 0, "x = $x positive"; The I is optional and may be left off. =item C I, I This is really the same as C, except that it will not be stripped by C and that it will always be monitored and cause a fatal error, whatever dynamic configuration is setup. =item C I, I Specify a post-condition I, along with an optional I that will be printed whenever the post-condition fails, i.e. when I evaluates to false. =item C I, I Specify an assertion I, and an optional I printed when I evaluates to false. =back =head2 Tracing Tracing is ensured by the C routine, which is never stripped. When C is off, traces are redirected to C (then channel depends on the level of the trace). The following forms can be used, from the simpler to the more complex: DTRACE "the variable x+1 is ", $x + 1, " and y is $y"; DTRACE TRC_WARNING, "a warning message"; DTRACE { -level => TRC_CRITICAL, -marker => "##" }, "very critical"; The first call emits a trace at the C level, by default. The second call emits a warning at the C level, and the last call emits a C message prefixed with a marker. Markers are 2-char strings emitted in the very first columns of the debugging output, and can be used to put emphasis on specifice messages. Internally, C and C use the following markers: !! assertion failure and stack trace ** critical errors, fatal if not trapped by eval {} >> a message emitted via a Log::Agent routine, not DTRACE The table below lists the available C levels defined by C, and how they remap to C routines when C is off: Carp::Datum Log::Agent ------------- ------------- TRC_EMERGENCY logdie TRC_ALERT logerr TRC_CRITICAL logerr TRC_ERROR logerr TRC_WARNING logwarn TRC_NOTICE logsay TRC_INFO logtrc "info" TRC_DEBUG logtrc "debug" If an application does not configure C specifically, all the calls map nicely to perl's native routines (die, warn and print). =head2 Convenience Routines =over 4 =item C I, I Returns true when both I and I have the same truth value, whether they are both true or both false. =item C I, I Returns the truth value of I implies I, which is the same as: !expr1 || expr2 It is always true except when I is true and I is false. Warning: this is function, not a macro. That is to say, both arguments are evaluated, and there is no short-circuit when I is false. =back =head1 DEBUG CONFIGURATION =head2 Global Switch on/off The C module can be turned on/off. This indication must be included when the module is imported in the main program as followed: # In application's main use Carp::Datum qw(:all on); # to turn on use Carp::Datum qw(:all off); # to turn off When C is turned off, most of the specific functions (DFEATURE, ...) continue to be invoked during the program execution but they return immediately. In details, all the tracing functions are disconnected, the contracts (DASSERT, DREQUIRE, DENSURE) continue to be verified: assertion failure will stop the program. That leads to a tiny perfomance loss when running production release. But, the delivered code keeps the possibility to be easily debugged. If the performance would be problematic in a production release, there is a stripper program available that can extract all the C calls from a source file. (see L). To turn on/off debugging according to an environment variable, the module can be imported like the following: # In application's main use Carp::Datum (":all", $ENV{DATUM}); # as a preamble to the program execution # in your favorite shell (here /bin/ksh) export DATUM=on # to turn on export DATUM=off # to turn off =head2 Dynamic Configuration The dynamic configuration is loaded when the C function is invoked in the main program. The function signature passes either a filename or directly a string (or both). DLOAD_CONFIG(-file => "./debug.cf") # filename - or - DLOAD_CONFIG(-config => <. The dynamic setting allows to filter the debug traces when running. For instance, one can enforce a routine to be silent. As an important note, the dynamic configuration is effective only when the global debug switch is turned on. =back =head1 LIMITATIONS It's not possible to insert tracing hooks like C or C in stringification overloading routines. For C, that is because the argument list might be dumped, and printing C<$self> will re-invoke the stringification routine recursively. For C, this is implied by the fact that there cannot be any C in the routine, hence C cannot be used. =head1 BUGS Please report any bugs to the current maintainer. =head1 HISTORY AND CREDITS The seed of the C module started to grow in 1996 when Raphael Manfredi and Christophe Dehaudt were involved in a tricky project involving kernel environment. It was Christophe's first experience with I principles. Raphael was already familar with the concept due to his participation in the development of the Eiffel compiler. Written in C, the first release was based on pre-processor macros. It already distinguished the pre-conditions, post-conditions and assertions. Also included were the concepts of dynamic configuration and flow tracing. The benefit of this lonely include file was very important since the final integration was very short and, since then, there has been no major bug reported on the delivered product. Based on this first success, they leveraged the techniques for developments in C++. The debug module was upgraded with the necessary notions required for true OO programming in C++. The Perl module was produced in 2000, when Raphael and Christophe needed for Perl the same powerful support that they had initiated a few years prior. Before the first official release in spring 2001, they developed several other Perl modules and applications (mainly related to CGI programming) that were powered by C. Some of them have also been published in CPAN directory (for instance: C). =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Carp::Datum::Cfg(3), Carp::Datum::MakeMaker(3), Carp::Datum::Strip(3), Log::Agent(3). =cut Carp-Datum-0.1.3/Datum/0040700000605300000120000000000007323625311014040 5ustar dhooverstaffCarp-Datum-0.1.3/Datum/Assert.pm0100644000605300000120000000741607421373425015663 0ustar dhooverstaff# # $Id: Assert.pm,v 0.1 2001/03/31 10:04:36 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Assert.pm,v $ # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package Carp::Datum::Assert; require Exporter; use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw(assert_expr stack_dump); use Log::Agent; # # assert_expr # # Fetch corresponding assert expression by going back to the file where # the failure occurred, and parsing it. This is very rough. # # Arguments: # offset amount of frames to skip # # Returns assertion expression if found, undef otherwise. # sub assert_expr { my ($offset) = @_; my ($package, $file, $line) = caller($offset); local *FILE; unless (open(FILE, $file)) { logerr "can't open $file to get assert expression: $!"; return; } local $_; my $count = $line; while () { last unless --$count > 0; } if ($count) { logwarn "reached EOF in $file whilst looking for line #$line"; close FILE; return; } unless (s/^\s*(?:DASSERT|DREQUIRE|DENSURE|VERIFY)\b//) { chomp; logwarn "expected assertion at line #$line in $file, got: $_"; close FILE; return; } # # Ok, we found something... now perform heuristic parsing... # my $expr = $_; $expr =~ s/^\s+//; $expr =~ s/\s+$//; $expr =~ s/^\(\s*//; if ($expr =~ s/(?:\)\s*)?;\s*$//) { # # Expression seems to be all on one line, like in: # # DASSERT($a == $b, "a equals b"); # # We're only interested in the "$a == $b" part though. # $expr =~ s/^\s*(.*?)\s*,\s*['"].*/$1/; #' for emacs coloring close FILE; return $expr; } # # Expression is not contained on one line. Advance in the file until # we see a ";" ending a line. Limit to the next 10 lines, or something # is probably wrong. # my $limit = 10; while ($limit-- > 0) { $_ = ; unless (defined $_) { logwarn "reached EOF in $file whilst building ". "assert text from line #$line"; close FILE; return; } chomp; s/^\s+//; $expr .= " " . $_; last if /;\s*$/; } close FILE; logwarn "assertion in $file, line #$line too long, cutting parsing" if $limit < 0; # # Got something? Same processing as above. # if ($expr =~ s/(?:\)\s*)?;\s*$//) { $expr =~ s/^\s*(.*?)\s*,\s*['"].*/$1/; #' for emacs coloring return $expr; } logwarn "can't compute assertion text at $file, line #$line, guessing..."; # # Limit to first 60 chars, then mark end with ... # $expr =~ s/^(.*?),\s*['"].*/$1/; #' for emacs coloring $expr = substr($expr, 0, 60); $expr .= "..."; return $expr; } # # stack_dump # # Dump the stack, discarding the first $offset frames. # sub stack_dump { my ($offset) = @_; # # Let Carp do the hard work. # require Carp; local $Carp::CarpLevel = 0; my $message = Carp::longmess("dump"); my @stack = split(/\n/, $message); splice(@stack, 0, $offset + 1); # Also skip initial "dump error" line foreach my $l (@stack) { $l =~ s/^\s+// } return \@stack; } 1; =head1 NAME Carp::Datum::Assert - Assertion expression extractor =head1 SYNOPSIS # Not meant to be used by user code =head1 DESCRIPTION This module is used internally by C to extract the expression text of a failed assertion, directly from the file. This extraction is done lexically, and the general guidelines, which are documented in L, apply here too. =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Carp::Datum(3), Carp::Datum::Strip(3). =cut Carp-Datum-0.1.3/Datum/Cfg.pm0100644000605300000120000005131307421373443015114 0ustar dhooverstaff# -*- Mode: perl -*- # # $Id: Cfg.pm,v 0.1.1.1 2001/07/13 17:05:28 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Cfg.pm,v $ # Revision 0.1.1.1 2001/07/13 17:05:28 ram # patch2: random cleanup (from CDE) # # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package Carp::Datum::Cfg; use Carp::Datum::Flags; use Getargs::Long qw(ignorecase); require Exporter; use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = (qw( ), @Carp::Datum::Flags::EXPORT); use vars qw($DEBUG_TABLE); # # Structure of the hash ref that is returned by the parser: # # FLAG_SETTING: # { debug => [ DTM_SET, DTM_CLEAR ], # trace => [ DTM_SET, DTM_CLEAR ], # args => VAL # } # # debug and trace correspond to a two values array. First value is the # set mask and the second is the clear one. # # args indicates the maximum number of arguments that is printed # during the tracing of the flow. -1 means all arguments. # # # DEBUG_TABLE: # { default => FLAG_SETTING, # # routine => { "routine_name1" => FLAG_SETTING, # "routine_name2" => FLAG_SETTING, # .... # }, # # file => { flags => { "path1" => FLAG_SETTING, # "path2" => FLAG_SETTING, # .... # }, # routine => { "routine_name1" => FLAG_SETTING, # "routine_name2" => FLAG_SETTING, # .... # } # }, # # type => { flags => { "type1" => FLAG_SETTING, # "type2" => FLAG_SETTING, # .... # }, # routine => { "routine_name1" => FLAG_SETTING, # "routine_name2" => FLAG_SETTING, # .... # } # }, # # alias => [ [ "path1", "alias1" ], # [ "path2", "alias2" ], # .... # ], # # define => { "name1" => FLAG_SETTING, # "name2" => FLAG_SETTING, # .... # } # } # # # default debug table $DEBUG_TABLE = {default => { debug => [DBG_ALL, 0], trace => [TRC_ALL, 0], args => -1 }, alias => [] }; # # ->make # # # Arguments: # -file => $filename: file to load [optionnal] # -config => $string: string which contains config set up [optionnal] # sub make { my $self = bless {}, shift; my ($filename, $raw_config) = cgetargs(@_, [qw(file config)]); $self->{cfg_table} = $DEBUG_TABLE; local $_ = ''; if (defined $filename && open(XFILE, $filename)) { $_ = "\n" . join('', ); die $@ if $@; close XFILE; } if (defined $raw_config) { $_ .= "\n" . $raw_config; $filename .= " + " if defined $filename; $filename .= "'RAW DATA CONFIGURATION'"; } # to prevent the parsing when the given parameter is a fake # filename, there is a test on the string to parse. It must # contain a blank character to possibly be parsed. A non existing # path will not contain this character. if (/\s/) { # use the parser to populate the debug tree structure my $p = Carp::Datum::Parser->new(\&Carp::Datum::Parser::yylex, \&Carp::Datum::Parser::yyerror, 0); $p->init_parser($filename); my $result = $p->yyparse(); # add the default values to the result if they have not been # set during the parsing while (my ($k, $v) = each %$DEBUG_TABLE) { $result->{$k} = $v unless defined $result->{$k}; } $self->{cfg_table} = $result; } # separate the result in different attibutes to speed-up the # processing (one dereference is saved). That is also beautifying # the code. $self->{cfg_file} = $self->cfg_table->{file}; $self->{cfg_routine} = $self->cfg_table->{routine}; $self->{cfg_cluster} = $self->cfg_table->{cluster}; $self->{cfg_type} = $self->cfg_table->{type}; $self->{cfg_alias} = $self->cfg_table->{alias}; return $self; } ######################################################################### # Internal Attribute Access: these methods are not intended to be used # # from the external of the object. # ######################################################################### sub cfg_table {$_[0]->{cfg_table}} sub cfg_alias {$_[0]->{cfg_alias}} # # ->basename # sub basename { my $name = shift; my $result = $name; if ($name =~ /\//) { ($result) = $name =~ /.*\/(\S+)/; } return $result; } # # ->add_flag # # static class function that is used by the flag routine when additive # method is requested for flag computation. # # Arguments: # $old: old value, # $new: new value (can be undef or null) # # Returns: # the clear bits of new are cleared on old and set bits of new are # set on old. # sub add_flag { my ($old, $new) = @_; if (defined $new && $new != 0) { return $old & ~$new->[DTM_CLEAR] | $new->[DTM_SET]; } return $old; } # # ->add_args # # static class function that is used by the flag routine when replacing # method is requested for flag computation. # # Arguments: # $old: old value, # $new: new value (can be undef or null) # # Returns: # the new value if defined # sub add_args { my ($old, $new) = @_; return $old unless defined $new; return $new; } ######################################################################### # Class Feature: usable from the external world # ######################################################################### # # ->check_debug # # return true when the given mask matches the flag setting for debug # mode # # Arguments: # $mask: bit field that is compared to the setting. # # $caller_penalty: [optional] allows to provide a penalty used to # determine the function features (via caller()) that is used to get # the configuration setting. When not specified or 0, the call level # right above the function that call the check_debug (2 steps from # here) will be used. # # Returns: # a boolean value. # sub check_debug { return $_[0]->flag('debug', @_ == 3 ? ($_[2]+1) : 1) & $_[1]; } # # ->check_trace # # return true when the given mask matches the flag setting for trace # mode # # Arguments: # $mask: bit field that is compared to the setting. # # $caller_penalty: [optional] allows to provide a penalty used to # determine the function features (via caller()) that is used to get # the configuration setting. When not specified or 0, the call level # right above the function that call the check_trace (2 steps from # here) will be used. # # Returns: # a boolean value. # sub check_trace { return $_[0]->flag('trace', @_ == 3 ? ($_[2]+1) : 1) & $_[1]; } # # ->flag # # Perform a walkthrough the different level of configuration setting # and and gets a (additive | replacing) value for the result computation. # # When requesting the flag for 'debug' or 'trace', each stage value is # added. For 'args' request, each value overwrites the previous one. # # The walkthrough is perfomed in the following order: # - default # - file # - routine # - routine for file # - type # - routine for type # # Arguments: # $field: string that indicates the key that is used during the # walkthrough. It is either 'debug', 'trace' or 'args'. # # $caller_penalty: [optional] allows to provide a penalty used to # determine the function features (via caller()) that is used to get # the configuration setting. When not specified or 0, the call level # right above the function that call the check_trace (2 steps from # here) will be used. # # Returns: # a value that depends from the $field request: # for 'debug' and 'trace': it represents a bit field. # for 'args': it is an integer.. # sub flag { my $self = shift; my ($field, $caller_penalty) = @_; # get debug caller (for filename location) my $caller_level = defined $caller_penalty ? (1 + $caller_penalty) : 1; my ($package, $filename, $line1) = caller($caller_level); # get debug caller (for routine name) package DB; use vars qw(@args); # ignore warning my ($package1, $filename1, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($caller_level + 1); package Carp::Datum::Cfg; # the method that is gonna used to compute the different flag # depends of what it is looked for: # 'debug' or 'trace' -> flags are merged during the walkthrough # 'args' -> value are overwritten during the walkthough my $merge_routine = \&add_flag; $merge_routine = \&add_args if $field eq 'args'; $subroutine = '' unless defined $subroutine; my ($func_name) = $subroutine =~ /.*::(\S+)/; my $file_routine = undef; my $type_routine = undef; # first get the default flag setting my $result = &$merge_routine(0, $self->cfg_table->{default}->{$field}); # update with cluster setting my $cluster_cfg = $self->{cfg_cluster}; if (defined $cluster_cfg) { # perhaps, the package gets directly an entry in the table if (defined $cluster_cfg->{$package}) { $result = &$merge_routine( $result, $cluster_cfg->{$package}->{flags}->{$field} ); } else { # anyway, try to find a filter matching a part of the package name my $tmp = $package; while ($tmp =~ /(.*)::/) { $tmp = $1; if (defined $cluster_cfg->{$tmp}) { $result = &$merge_routine( $result, $cluster_cfg->{$tmp}->{flags}->{$field} ); last; } }; } } # update with file specific setting (if any), trying base name second my $file_cfg = $self->{cfg_file}->{$filename}; if (defined $file_cfg) { $result = &$merge_routine($result, $file_cfg->{flags}->{$field}); $file_routine = $file_cfg->{routine}->{$func_name}; } else { $file_cfg = $self->{cfg_file}->{basename($filename)}; if (defined $file_cfg) { $result = &$merge_routine($result, $file_cfg->{flags}->{$field}); $file_routine = $file_cfg->{routine}->{$func_name}; } } # update with routine specific setting (if any) my $routine_cfg = $self->{cfg_routine}->{$func_name}; $result = &$merge_routine($result, $routine_cfg->{flags}->{$field}); # update with routine specific setting from file specification (if any) $result = &$merge_routine($result, $file_routine->{flags}->{$field}); # update with dynamic type specific setting (if any) my $dyna_type = ''; ($dyna_type) = $DB::args[0] =~ /(.*)=\w+\(.*\)/ if defined $DB::args[0]; my $dyna_cfg = $self->{cfg_type}->{$dyna_type}; $result = &$merge_routine($result, $dyna_cfg->{flags}->{$field}); # update with routine specific setting from type specification (if any) $type_routine = $dyna_cfg->{routine}->{$func_name}; $result = &$merge_routine($result, $type_routine->{flags}->{$field}); return $result; } 1; =head1 NAME Carp::Datum::Cfg - Dynamic Debug Configuration Setting for Datum =head1 SYNOPSIS # In application's main use Carp::Datum qw(:all on); # turns Datum "on" or "off" DLOAD_CONFIG(-file => "./debug.cf", -config => "config string"); =head1 DESCRIPTION By using the DLOAD_CONFIG function in an application's main file, a debugging configuration can be dynamically loaded to define a particular level of debug/trace flags for a specific sub-part of code. For instance, the tracing can be turned off when entering a routine of a designated package. That is very useful for concentrating the debugging onto the area that is presently developed and/or to filter some verbose parts of code (recursive function call), when they don't need to be monitored to fix the problem. =head1 EXAMPLE Before the obscure explaination of the grammar, here is an example of what can be specified by dynamic configuration: /* * flags definition: macro that can be used in further configuration * settings */ flags common { all(yes); trace(yes): all; } flags silent { all(yes); flow(no); trace(no); return(no); } /* * default setting to use when there is no specific setting * for the area */ default common; /* * specific settings for specific areas */ routine "context", "cleanup" { use silent; } routine "validate", "is_num", "is_greater" { use silent; } file "Keyed_Tree.pm" { use silent; } file "Color.pm" { use silent; trace(yes): emergency, alert, critical; } cluster "CGI::MxScreen" { use silent; assert(no); ensure(no); } /* * aliasing to reduce the trace output line length */ alias "/home/dehaudtc/usr/perl/lib/site_perl/5.6.0/CGI" => ""; =head1 INTERFACE The only user interface is the C routine, which expects the following optional named parameters: =over 4 =item C<-config> => I Give an inlined configuration string that is appended to the one defined by C<-file>, if any. =item C<-file> => I Specifies the configuration file to load to initialize the debugging and tracing flags to be used for this run. =back =head1 CONFIGURATION DIRECTIVES =head2 Main Configuration Directives The following main directives can appear at a nesting level of 0. The syntax unit known as I is a list of semi-colon terminated directives held within curly braces. =over 4 =item C I => I Defines an alias to be used during tracing. The I string is replaced by the I in the logs. For instance, given: alias "/home/dehaudtc/lib/CGI" => ""; then a trace for file C would be traced as coming from file CCGIE/Carp.pm>, which is nicer to read. =item C I, I I The I defines the flags to be applied to all named clusters. A cluster is a set of classes under a given name scope. Cluster names are given by strings within double quotes, as in: cluster "CGI::MxScreen", "Net::MsgLink" { use silent; } This would apply to all classes under the "CGI::MxScreen" or "Net::MsgLink" name scopes, i.e. C would be affected. An exact match is attempted first, i.e. saying: cluster "CGI::MxScreen" { use verbose; } cluster "CGI::MxScreen::Screen" { use silent; } would apply the I flags for C but the I ones to C. =item C I|I. Specifies the default flags that should apply. The default flags can be given by providing the I of flags, defined by the C directive, or by expansing them in the following I. For instance: default silent; would say that the flags to apply by default are the ones defined by an earlier C directive. Not expanding defaults allows for quick switching by replacing I with I. It is up to the module user to define what is meant by that though. =item C I, I I The I defines the flags to be applied to all named files. File names are given by strings withing double quotes, as in: file "foo.pm", "bar.pm" { use silent; } This would apply to all files named "foo.pm" or "bar.pm", whatever their directory, i.e. it would apply to C as well as C<../bar.pm>. An exact match is attempted first, i.e. saying: file "foo.pm" { use verbose; } file "/tmp/foo.pm" { use silent; } would apply the I flags for C but the I ones to C<./foo.pm>. =item C I I Define a symbol I whose flags are described by the following I. This I can then be used in C and C directives. For instance: flags common { all(yes); trace(yes): all; } would define the flags known as I, which can then be re-used, as in: flags other { use common; # reuses definiton of common flags panic(no); # but switches off panic, enabled in common } A flag symbol must be defined prior being used. =item C I, I I The I defines the flags to be applied to all named routines. Routine names are given by strings within double quotes, as in: routine "foo", "bar" { use silent; } This would apply to all routines named "foo" or "bar", whatever their package, for instance C and C. =head2 Debugging and Tracing Flags Debugging (and tracing) flags can be specified only within syntactic I items, as expected by main directives such as C or C. Following is a list of debugging flags that can be specified in the configuration. The order in which they are given in the file is significant: the I/I settings are applied sequentially. =over 4 =item C I Uses flags defined by a C directive under I. It acts as a recursive macro expansion (since C can also be specified in C). The symbol I must have been defined earlier. =item flow(yes|no) Whether to print out the entering/exiting of routines. That implies the invocation of the C function in the routines. =item return(yes|no) Whether to print out the returned when using the return C and C routines. =item trace(yes|no) Whether to print out traces specified by the C function. By default all trace levels are affected. It may be followed by a list of trace levels affected by the directive, as in. trace(yes): emergency, alert, critical; Trace levels are purely conventional, and have a strict one-to-one mapping with C levels given at the C call. They are further described in L below. There is one bit per defined trace level, contrary to the convention established by syslog(), for better tuning. =item require(yes|no) Whether to evaluate the pre-condition given by C. But see L below. =item assert(yes|no) Whether to evaluate the assertion given by C. But see L below. =item ensure(yes|no) Whether to evaluate the post-condition given by C. But see L below. =item panic(yes|no) Whether to panic upon an assertion failure (pre/post condition or assertion). If not enabled, a simple warning is issued, tracing the assertion failure. =item stack(yes|no) Whether to print out a stack trace upon assertion failure. =item all(yes|no) Enable or disables B the previously described items. =back =head2 Assertion Evaluation Note When C is switched off, the assertions are always monitored, and any failure is fatal. This is because a failing assertion is a Bad Thing in production mode. Also, since C and friends are not C macros but routines, the assertion expression is evaluated anyway, so it might as well be tested. Therefore, a directive like: require(no); will only turn off monitoring of pre-conditions in debugging mode (e.g. because the interface is not finalized, or the clients do not behave properly yet). =head2 Trace Levels Here is the list of trace flags that can be specified by the configuration: Configuration DTRACE flag ------------- ------------- all TRC_ALL emergency TRC_EMERGENCY alert TRC_ALERT critical TRC_CRITICAL error TRC_ERROR warning TRC_WARNING notice TRC_NOTICE info TRC_INFO debug TRC_DEBUG A user could say something like: trace(no): all; trace(yes): emergency, alert, critical, error; Since flags are applied in sequence, the first directive turns all tracing flags to off, the second enables only the listed ones. =head1 BUGS Some things are not fully documented. =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Log::Agent(3). =cut Carp-Datum-0.1.3/Datum/Flags.pm0100644000605300000120000000456307421373457015463 0ustar dhooverstaff# -*- Mode: perl -*- # # $Id: Flags.pm,v 0.1 2001/03/31 10:04:36 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Flags.pm,v $ # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # package Carp::Datum::Flags; BEGIN { sub DBG_ON () {1}; sub DBG_OFF () {0}; sub DTM_SET () {0}; sub DTM_CLEAR () {1}; sub DBG_ALL () {0xffffffff}; sub DBG_FLOW () {0x00000001}; # Control flow (entry/exit) sub DBG_RETURN () {0x00000002}; # Trace return value sub DBG_REQUIRE () {0x00000004}; # Check preconditions sub DBG_ASSERT () {0x00000008}; # Check plain assertions sub DBG_ENSURE () {0x00000010}; # Check postconditions sub DBG_TRACE () {0x00000020}; # Emit trace messages sub DBG_PANIC () {0x00000040}; # Panic on assertion failure sub DBG_STACK () {0x00000080}; # Dump stack trace on assert failure } BEGIN { sub TRC_ALL () {0xffffffff}; sub TRC_EMERGENCY () {0x00000001}; sub TRC_ALERT () {0x00000002}; sub TRC_CRITICAL () {0x00000004}; sub TRC_ERROR () {0x00000008}; sub TRC_WARNING () {0x00000010}; sub TRC_NOTICE () {0x00000020}; sub TRC_INFO () {0x00000040}; sub TRC_DEBUG () {0x00000080}; } require Exporter; use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw( DBG_ON DBG_OFF DTM_SET DTM_CLEAR DBG_ALL DBG_FLOW DBG_RETURN DBG_REQUIRE DBG_ASSERT DBG_ENSURE DBG_TRACE DBG_PANIC DBG_STACK TRC_ALL TRC_EMERGENCY TRC_ALERT TRC_CRITICAL TRC_ERROR TRC_WARNING TRC_NOTICE TRC_INFO TRC_DEBUG ); 1; =head1 NAME Carp::Datum::Flags - Flag Constants =head1 SYNOPSIS # Used internally to define debugging and tracing flag constants =head1 DESCRIPTION This module is used internally by C. It defines the constants that are exported and made available automatically to all users of C. =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Carp::Datum(3). =cut Carp-Datum-0.1.3/Datum/MakeMaker.pm0100644000605300000120000001067707421373470016262 0ustar dhooverstaff# -*- Mode: perl -*- # # $Id: MakeMaker.pm,v 0.1 2001/03/31 10:04:36 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: MakeMaker.pm,v $ # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package Carp::Datum::MakeMaker; use Log::Agent; require Exporter; use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(WriteMakefile); require ExtUtils::MakeMaker; # # ->WriteMakefile # # Supersedes the version from ExtUtils::MakeMaker to get a chance to ask # whether the debugging version of the module needs to be installed or not. # This is only possible starting with version 5.45 of MakeMaker (perl 5.6.1). # sub WriteMakefile { my %args = @_; my $version = $ExtUtils::MakeMaker::VERSION; my $name = $args{NAME}; my $LIMIT = 5.45; if ($version < $LIMIT) { print "Keeping Carp::Datum calls in $name -- MakeMaker is too old\n"; print "(Would need ExtUtils::MakeMaker version $LIMIT or better)\n"; return &ExtUtils::MakeMaker::WriteMakefile; } elsif (-t STDIN) { local *TTY; open(TTY, ">/dev/tty"); select((select(TTY), $| = 1)[0]); print TTY <; return &ExtUtils::MakeMaker::WriteMakefile if $ans =~ /^n/i; } else { print "Will build $name with calls to Carp::Datum stripped\n"; } # # They wish to remove all Carp::Datum code from the installed files. # $args{'macro'} = {} unless exists $args{'macro'}; $args{'macro'}->{PM_FILTER} = "datum_strip"; return &ExtUtils::MakeMaker::WriteMakefile(%args); } 1; =head1 NAME Carp::Datum::MakeMaker - Offer to strip Carp::Datum calls statically =head1 SYNOPSIS # Put this at the top of the Makefile.PL for your module use ExtUtils::MakeMaker; # you may omit this line use Carp::Datum::MakeMaker; =head1 DESCRIPTION The C module supersedes the regular WriteMakefile() routine of C. When running the Makefile.PL from a module interactively, the user will be asked whether calls to C should be stripped at build time. By default, or when running non-interactively, most calls to Carp::Datum routines will be removed: the C program will be invoked to filter *.pm files during the build process. This program is a mere wrapper for the datum_strip() routine, defined in C. The only call that will not be stripped is the DTRACE() call. However, it will be dynamically remapped to a C call. It cannot be statically remapped because of its baroque interface. At the top of Makefile.PL, insert use Carp::Datum::MakeMaker; which will take care of loading C. Note that it makes sense to refer to this module, since C is being used internally, and therefore the user will not be able to install the module if they do not have C already installed. If you wish to be nicer about C not being installed, you can say instead: use ExtUtils::MakeMaker; eval "use Carp::Datum::MakeMaker;"; WriteMakefile( 'NAME' => "Your::module::name", 'PREREQ_PM' => { 'Carp::Datum' => '0.100', }, ); It will allow them to run the Makefile.PL, and yet be reminded about the missing C module. Chances are they won't be able to go much farther though... =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Carp::Datum::Strip(3), ExtUtils::MakeMaker(3). =cut Carp-Datum-0.1.3/Datum/Parser.pm0100644000605300000120000011402707323625310015645 0ustar dhooverstaff# @(#)yaccpar 1.8 (Berkeley) 01/20/91 (JAKE-P5BP-0.6 04/26/98) package Parser; #line 22 "./Parser.y" package Carp::Datum::Parser; use Carp::Datum::Flags; BEGIN { sub TRUE () {1}; sub FALSE () {0}; } #line 14 "Parser.pm" $FLAGS=257; $DEFAULT=258; $FILE=259; $ROUTINE=260; $USE=261; $TYPE=262; $ALIAS=263; $STRING=264; $T_WORD=265; $T_NUM=266; $FLOW=267; $REQUIRE=268; $ASSERT=269; $ENSURE=270; $RETURN=271; $STACK=272; $CLUSTER=273; $PANIC=274; $PROPAGATE=275; $EXEC=276; $TRACE=277; $EMERGENCY=278; $ALERT=279; $CRITICAL=280; $ERROR=281; $AUTOMARK=282; $INVARIANT=283; $WARNING=284; $NOTICE=285; $INFO=286; $DEBUG=287; $TEST=288; $DUMP=289; $ALL=290; $USR1=291; $USR2=292; $MEMORY=293; $OBJECT=294; $STATE=295; $STARTUP=296; $YES=297; $NO=298; $LEQ=299; $GEQ=300; $AS=301; $ARGS=302; $YYERRCODE=256; @yylhs = ( -1, 2, 0, 1, 1, 3, 3, 3, 3, 3, 3, 3, 4, 5, 5, 6, 7, 8, 10, 9, 14, 14, 14, 15, 15, 12, 12, 12, 16, 16, 16, 16, 16, 18, 23, 23, 24, 24, 25, 25, 27, 27, 27, 27, 26, 26, 26, 26, 26, 26, 26, 26, 26, 19, 20, 29, 29, 21, 21, 30, 22, 22, 28, 28, 28, 28, 28, 28, 28, 28, 17, 17, 11, 13, 13, 31, ); @yylen = ( 2, 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, 1, 5, 3, 4, 5, 5, 5, 5, 5, 0, 1, 2, 2, 1, 0, 2, 3, 2, 1, 1, 1, 1, 5, 0, 2, 1, 3, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 3, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 1, 1, 3, 1, ); @yydefred = ( 1, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 4, 5, 6, 7, 8, 9, 10, 11, 72, 0, 0, 0, 75, 0, 73, 0, 0, 0, 0, 0, 0, 63, 65, 66, 67, 64, 69, 68, 0, 0, 62, 0, 0, 0, 29, 30, 31, 32, 0, 0, 13, 0, 0, 0, 0, 0, 0, 0, 70, 0, 0, 0, 0, 14, 0, 26, 0, 0, 24, 0, 21, 0, 74, 0, 0, 0, 0, 12, 0, 60, 61, 0, 0, 56, 55, 0, 27, 0, 58, 16, 22, 23, 18, 19, 15, 17, 71, 0, 59, 54, 53, 0, 33, 45, 46, 47, 48, 49, 50, 51, 52, 44, 40, 41, 42, 43, 0, 36, 38, 0, 0, 39, 37, ); @yydgoto = ( 1, 3, 2, 11, 12, 13, 14, 15, 16, 17, 69, 20, 43, 24, 70, 71, 44, 60, 45, 46, 47, 48, 82, 103, 117, 118, 119, 120, 49, 86, 50, 25, ); @yysindex = ( 0, 0, 0, -156, -249, -116, -238, -238, -238, -236, -238, 0, 0, 0, 0, 0, 0, 0, 0, 0, -92, -224, -24, 0, -41, 0, -40, -39, -262, -38, -224, -249, 0, 0, 0, 0, 0, 0, 0, 1, 2, 0, 9, -74, 3, 0, 0, 0, 0, 20, 5, 0, -250, -238, -224, -250, -200, -224, -26, 0, 21, -283, -283, -243, 0, 8, 0, -283, -196, 0, -124, 0, 10, 0, -9, -100, 12, 17, 0, -249, 0, 0, 31, 33, 0, 0, 34, 0, 36, 0, 0, 0, 0, 0, 0, 0, 0, 0, 22, 0, 0, 0, -60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 35, 0, 0, -166, -60, 0, 0, ); @yyrindex = ( 0, 0, 0, 81, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -36, 0, 0, 0, 0, 0, 0, 0, 0, -36, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 28, 0, -35, 0, -36, -35, 0, -36, 0, 0, 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 37, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, 0, 0, 0, 0, 0, ); @yygindex = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 91, 7, -21, 49, 43, -62, 18, 0, 0, 0, 0, 0, -33, 0, 0, -16, -20, 0, 0, 0, 0, 55, ); $YYTABLESIZE=319; @yytable = ( 116, 90, 115, 53, 53, 53, 53, 21, 91, 58, 7, 31, 22, 91, 80, 81, 19, 32, 33, 34, 35, 36, 37, 84, 38, 94, 23, 39, 28, 83, 85, 30, 40, 74, 88, 51, 77, 31, 59, 56, 41, 61, 62, 32, 33, 34, 35, 36, 37, 63, 38, 64, 42, 39, 80, 81, 26, 27, 40, 29, 67, 65, 66, 68, 76, 79, 41, 87, 89, 92, 72, 95, 98, 72, 99, 100, 65, 101, 42, 121, 102, 2, 52, 54, 55, 57, 97, 57, 72, 25, 20, 28, 65, 72, 18, 65, 34, 35, 75, 78, 122, 4, 5, 6, 7, 123, 8, 9, 73, 0, 0, 0, 104, 105, 106, 107, 93, 10, 108, 109, 110, 111, 0, 0, 112, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 31, 0, 0, 0, 0, 96, 32, 33, 34, 35, 36, 37, 19, 38, 0, 0, 39, 0, 0, 0, 0, 40, 0, 7, 31, 0, 0, 0, 0, 41, 32, 33, 34, 35, 36, 37, 0, 38, 0, 0, 39, 42, 0, 0, 0, 40, 0, 0, 0, 0, 31, 0, 0, 41, 0, 0, 32, 33, 34, 35, 36, 37, 0, 38, 0, 42, 39, 0, 0, 0, 0, 40, 0, 0, 0, 0, 0, 0, 0, 41, 0, 104, 105, 106, 107, 0, 0, 108, 109, 110, 111, 42, 0, 112, 0, 0, 0, 0, 31, 0, 0, 0, 113, 114, 32, 33, 34, 35, 36, 37, 0, 38, 0, 0, 39, 31, 0, 0, 0, 40, 0, 32, 33, 34, 35, 36, 37, 41, 38, 0, 0, 39, 0, 0, 0, 0, 40, 0, 0, 42, 0, 31, 0, 0, 41, 0, 0, 32, 33, 34, 35, 36, 37, 0, 38, 0, 42, 39, 0, 0, 0, 0, 40, 0, 0, 0, 0, 0, 0, 0, 41, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, ); @yycheck = ( 60, 125, 62, 44, 44, 44, 44, 123, 70, 30, 260, 261, 5, 75, 297, 298, 265, 267, 268, 269, 270, 271, 272, 266, 274, 125, 264, 277, 264, 62, 63, 123, 282, 54, 67, 59, 57, 261, 31, 301, 290, 40, 40, 267, 268, 269, 270, 271, 272, 40, 274, 125, 302, 277, 297, 298, 7, 8, 282, 10, 40, 43, 59, 58, 264, 44, 290, 59, 264, 59, 52, 59, 41, 55, 41, 41, 58, 41, 302, 44, 58, 0, 123, 123, 123, 123, 79, 59, 70, 125, 125, 59, 74, 75, 3, 77, 59, 59, 55, 125, 120, 257, 258, 259, 260, 121, 262, 263, 53, -1, -1, -1, 278, 279, 280, 281, 125, 273, 284, 285, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 260, 261, -1, -1, -1, -1, 125, 267, 268, 269, 270, 271, 272, 265, 274, -1, -1, 277, -1, -1, -1, -1, 282, -1, 260, 261, -1, -1, -1, -1, 290, 267, 268, 269, 270, 271, 272, -1, 274, -1, -1, 277, 302, -1, -1, -1, 282, -1, -1, -1, -1, 261, -1, -1, 290, -1, -1, 267, 268, 269, 270, 271, 272, -1, 274, -1, 302, 277, -1, -1, -1, -1, 282, -1, -1, -1, -1, -1, -1, -1, 290, -1, 278, 279, 280, 281, -1, -1, 284, 285, 286, 287, 302, -1, 290, -1, -1, -1, -1, 261, -1, -1, -1, 299, 300, 267, 268, 269, 270, 271, 272, -1, 274, -1, -1, 277, 261, -1, -1, -1, 282, -1, 267, 268, 269, 270, 271, 272, 290, 274, -1, -1, 277, -1, -1, -1, -1, 282, -1, -1, 302, -1, 261, -1, -1, 290, -1, -1, 267, 268, 269, 270, 271, 272, -1, 274, -1, 302, 277, -1, -1, -1, -1, 282, -1, -1, -1, -1, -1, -1, -1, 290, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 302, ); $YYFINAL=1; #ifndef YYDEBUG #define YYDEBUG 0 #endif $YYMAXTOKEN=302; #if YYDEBUG @yyname = ( "end-of-file",'','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','', '','','','','','',"'('","')'",'','',"','",'','','','','','','','','','','','','',"':'","';'","'<'",'', "'>'",'','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','', '','','','','','','','','','','','','','','','','','','','','','','',"'{'",'',"'}'",'','','','','','','','','','', '','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','', '','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','', '','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','','', '',"FLAGS","DEFAULT","FILE","ROUTINE","USE","TYPE","ALIAS","STRING","T_WORD", "T_NUM","FLOW","REQUIRE","ASSERT","ENSURE","RETURN","STACK","CLUSTER","PANIC", "PROPAGATE","EXEC","TRACE","EMERGENCY","ALERT","CRITICAL","ERROR","AUTOMARK", "INVARIANT","WARNING","NOTICE","INFO","DEBUG","TEST","DUMP","ALL","USR1","USR2", "MEMORY","OBJECT","STATE","STARTUP","YES","NO","LEQ","GEQ","AS","ARGS", ); @yyrule = ( "\$accept : root", "\$\$1 :", "root :\$\$1 statements", "statements :", "statements : statements statement", "statement : flags_definition", "statement : default_setting", "statement : alias_setting", "statement : file_definition", "statement : cluster_definition", "statement : type_definition", "statement : routine_definition", "flags_definition : FLAGS ident '{' flags_list '}'", "default_setting : DEFAULT ident ';'", "default_setting : DEFAULT '{' flags_list '}'", "alias_setting : ALIAS STRING AS STRING ';'", "file_definition : FILE string_list '{' flags_or_routines_list '}'", "cluster_definition : CLUSTER string_list '{' flags_list '}'", "routine_definition : ROUTINE string_list '{' flags_list '}'", "type_definition : TYPE string_list '{' flags_or_routines_list '}'", "flags_or_routines_list :", "flags_or_routines_list : flags_or_routines", "flags_or_routines_list : flags_or_routines_list flags_or_routines", "flags_or_routines : flags_spec ';'", "flags_or_routines : routine_definition", "flags_list :", "flags_list : flags_spec ';'", "flags_list : flags_list flags_spec ';'", "flags_spec : USE ident_list", "flags_spec : trace_spec", "flags_spec : flag_spec", "flags_spec : args_spec", "flags_spec : automark_spec", "trace_spec : TRACE '(' yes_or_no ')' trace_flags", "trace_flags :", "trace_flags : ':' trace_flag_list", "trace_flag_list : trace_flag", "trace_flag_list : trace_flag_list ',' trace_flag", "trace_flag : trace_flag_token", "trace_flag : cmp_tag trace_flag_token", "cmp_tag : LEQ", "cmp_tag : GEQ", "cmp_tag : '>'", "cmp_tag : '<'", "trace_flag_token : ALL", "trace_flag_token : EMERGENCY", "trace_flag_token : ALERT", "trace_flag_token : CRITICAL", "trace_flag_token : ERROR", "trace_flag_token : WARNING", "trace_flag_token : NOTICE", "trace_flag_token : INFO", "trace_flag_token : DEBUG", "flag_spec : flag '(' yes_or_no ')'", "args_spec : ARGS '(' args_level ')'", "args_level : yes_or_no", "args_level : T_NUM", "automark_spec : automark_flag", "automark_spec : automark_flag ':' STRING", "automark_flag : AUTOMARK '(' yes_or_no ')'", "yes_or_no : YES", "yes_or_no : NO", "flag : ALL", "flag : FLOW", "flag : RETURN", "flag : REQUIRE", "flag : ASSERT", "flag : ENSURE", "flag : PANIC", "flag : STACK", "ident_list : ident", "ident_list : ident_list ',' ident", "ident : T_WORD", "string_list : string", "string_list : string_list ',' string", "string : STRING", ); #endif sub yyclearin { my $p; ($p) = @_; $p->{yychar} = -1; } sub yyerrok { my $p; ($p) = @_; $p->{yyerrflag} = 0; } sub new { my $p = bless {}, $_[0]; $p->{yylex} = $_[1]; $p->{yyerror} = $_[2]; $p->{yydebug} = $_[3]; return $p; } sub YYERROR { my $p; ($p) = @_; ++$p->{yynerrs}; $p->yy_err_recover; } sub yy_err_recover { my $p; ($p) = @_; if ($p->{yyerrflag} < 3) { $p->{yyerrflag} = 3; while (1) { if (($p->{yyn} = $yysindex[$p->{yyss}->[$p->{yyssp}]]) && ($p->{yyn} += $YYERRCODE) >= 0 && $p->{yyn} <= $#yycheck && $yycheck[$p->{yyn}] == $YYERRCODE) { warn("yydebug: state " . $p->{yyss}->[$p->{yyssp}] . ", error recovery shifting to state" . $yytable[$p->{yyn}] . "\n") if $p->{yydebug}; $p->{yyss}->[++$p->{yyssp}] = $p->{yystate} = $yytable[$p->{yyn}]; $p->{yyvs}->[++$p->{yyvsp}] = $p->{yylval}; next yyloop; } else { warn("yydebug: error recovery discarding state ". $p->{yyss}->[$p->{yyssp}]. "\n") if $p->{yydebug}; return(undef) if $p->{yyssp} <= 0; --$p->{yyssp}; --$p->{yyvsp}; } } } else { return (undef) if $p->{yychar} == 0; if ($p->{yydebug}) { $p->{yys} = ''; if ($p->{yychar} <= $YYMAXTOKEN) { $p->{yys} = $yyname[$p->{yychar}]; } if (!$p->{yys}) { $p->{yys} = 'illegal-symbol'; } warn("yydebug: state " . $p->{yystate} . ", error recovery discards " . "token " . $p->{yychar} . "(" . $p->{yys} . ")\n"); } $p->{yychar} = -1; next yyloop; } 0; } # yy_err_recover sub yyparse { my $p; my $s; ($p, $s) = @_; if ($p->{yys} = $ENV{'YYDEBUG'}) { $p->{yydebug} = int($1) if $p->{yys} =~ /^(\d)/; } $p->{yynerrs} = 0; $p->{yyerrflag} = 0; $p->{yychar} = (-1); $p->{yyssp} = 0; $p->{yyvsp} = 0; $p->{yyss}->[$p->{yyssp}] = $p->{yystate} = 0; yyloop: while(1) { yyreduce: { last yyreduce if ($p->{yyn} = $yydefred[$p->{yystate}]); if ($p->{yychar} < 0) { if ((($p->{yychar}, $p->{yylval}) = &{$p->{yylex}}($s)) < 0) { $p->{yychar} = 0; } if ($p->{yydebug}) { $p->{yys} = ''; if ($p->{yychar} <= $#yyname) { $p->{yys} = $yyname[$p->{yychar}]; } if (!$p->{yys}) { $p->{yys} = 'illegal-symbol'; }; warn("yydebug: state " . $p->{yystate} . ", reading " . $p->{yychar} . " (" . $p->{yys} . ")\n"); } } if (($p->{yyn} = $yysindex[$p->{yystate}]) && ($p->{yyn} += $p->{yychar}) >= 0 && $p->{yyn} <= $#yycheck && $yycheck[$p->{yyn}] == $p->{yychar}) { warn("yydebug: state " . $p->{yystate} . ", shifting to state " . $yytable[$p->{yyn}] . "\n") if $p->{yydebug}; $p->{yyss}->[++$p->{yyssp}] = $p->{yystate} = $yytable[$p->{yyn}]; $p->{yyvs}->[++$p->{yyvsp}] = $p->{yylval}; $p->{yychar} = (-1); --$p->{yyerrflag} if $p->{yyerrflag} > 0; next yyloop; } if (($p->{yyn} = $yyrindex[$p->{yystate}]) && ($p->{yyn} += $p->{'yychar'}) >= 0 && $p->{yyn} <= $#yycheck && $yycheck[$p->{yyn}] == $p->{yychar}) { $p->{yyn} = $yytable[$p->{yyn}]; last yyreduce; } if (! $p->{yyerrflag}) { &{$p->{yyerror}}('syntax error', $s); ++$p->{yynerrs}; } return(undef) if $p->yy_err_recover; } # yyreduce warn("yydebug: state " . $p->{yystate} . ", reducing by rule " . $p->{yyn} . " (" . $yyrule[$p->{yyn}] . ")\n") if $p->{yydebug}; $p->{yym} = $yylen[$p->{yyn}]; $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}+1-$p->{yym}]; if ($p->{yyn} == 1) { #line 52 "./Parser.y" { $expect = yy_top; # allocate the object that is gonna be returned $result = {}; } } if ($p->{yyn} == 2) { #line 59 "./Parser.y" { $p->{yyval} = $result; } } if ($p->{yyn} == 11) { #line 79 "./Parser.y" { my $new = $p->{yyvs}->[$p->{yyvsp}-0]; if (defined $result->{routine}) { for my $key (keys %{$new}) { $result->{routine}->{$key} = $new->{$key}; } } else { $result->{routine} = $new; } } } if ($p->{yyn} == 12) { #line 94 "./Parser.y" { if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { $result->{define}->{$p->{yyvs}->[$p->{yyvsp}-3]} = $p->{yyvs}->[$p->{yyvsp}-1]; } } } if ($p->{yyn} == 13) { #line 103 "./Parser.y" { $result->{default} = {}; if (defined $result->{define}->{$p->{yyvs}->[$p->{yyvsp}-1]}) { merge_flag($result->{default},$result->{define}->{$p->{yyvs}->[$p->{yyvsp}-1]}); } } } if ($p->{yyn} == 14) { #line 110 "./Parser.y" { if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { $result->{default} = $p->{yyvs}->[$p->{yyvsp}-1]; } } } if ($p->{yyn} == 15) { #line 119 "./Parser.y" { push @{$result->{alias}}, [$p->{yyvs}->[$p->{yyvsp}-3], $p->{yyvs}->[$p->{yyvsp}-1]]; } } if ($p->{yyn} == 16) { #line 126 "./Parser.y" { if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { for my $string (@{$p->{yyvs}->[$p->{yyvsp}-3]}) { $result->{file}->{$string} = $p->{yyvs}->[$p->{yyvsp}-1]; } } } } if ($p->{yyn} == 17) { #line 137 "./Parser.y" { if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { for my $string (@{$p->{yyvs}->[$p->{yyvsp}-3]}) { $result->{cluster}->{$string}->{flags} = $p->{yyvs}->[$p->{yyvsp}-1]; } } } } if ($p->{yyn} == 18) { #line 148 "./Parser.y" { my $hash = {}; if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { for my $string (@{$p->{yyvs}->[$p->{yyvsp}-3]}) { $hash->{$string}->{flags} = $p->{yyvs}->[$p->{yyvsp}-1]; } } $p->{yyval} = $hash; } } if ($p->{yyn} == 19) { #line 161 "./Parser.y" { if ($p->{yyvs}->[$p->{yyvsp}-1] != 0) { for my $string (@{$p->{yyvs}->[$p->{yyvsp}-3]}) { $result->{type}->{$string} = $p->{yyvs}->[$p->{yyvsp}-1]; } } } } if ($p->{yyn} == 20) { #line 171 "./Parser.y" { $p->{yyval} = 0; } } if ($p->{yyn} == 21) { #line 172 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 22) { #line 174 "./Parser.y" { my $current = $p->{yyvs}->[$p->{yyvsp}-1]; my $new = $p->{yyvs}->[$p->{yyvsp}-0]; # # If new node holds flags, merge them. # if (defined $new->{flags}) { if (defined $current->{flags}) { merge_flag($current->{flags}, $new->{flags}); } else { $current->{flags} = $new->{flags}; } } # # If new node holds routine, merge them. # if (defined $new->{routine}) { if (defined $current->{routine}) { for my $key (keys %{$new->{routine}}) { $current->{routine}->{$key} = $new->{routine}->{$key}; } } else { $current->{routine} = $new->{routine}; } } $p->{yyval} = $current; } } if ($p->{yyn} == 23) { #line 212 "./Parser.y" { my $flag = {}; $flag->{flags} = $p->{yyvs}->[$p->{yyvsp}-1]; $p->{yyval} = $flag; } } if ($p->{yyn} == 24) { #line 219 "./Parser.y" { my $routine = {}; $routine->{routine} = $p->{yyvs}->[$p->{yyvsp}-0]; $p->{yyval} = $routine; } } if ($p->{yyn} == 25) { #line 228 "./Parser.y" { $p->{yyval} = 0; } } if ($p->{yyn} == 26) { #line 229 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-1]; } } if ($p->{yyn} == 27) { #line 231 "./Parser.y" { my $flag = $p->{yyvs}->[$p->{yyvsp}-2]; my $new = $p->{yyvs}->[$p->{yyvsp}-1]; merge_flag($flag, $new); $p->{yyval} = $flag; } } if ($p->{yyn} == 28) { #line 242 "./Parser.y" { my $flag = {}; for my $ident (@{$p->{yyvs}->[$p->{yyvsp}-0]}) { if (defined $result->{define}->{$ident}) { merge_flag($flag, $result->{define}->{$ident}); } } $p->{yyval} = $flag; } } if ($p->{yyn} == 29) { #line 254 "./Parser.y" { my $flag = {}; $flag->{trace} = $p->{yyvs}->[$p->{yyvsp}-0]; # If at least one trace flag is set, we need to activate # tracing. If no flag is set and all are clear, we deactivate # tracing alltogether. if ($flag->{trace}->[DTM_SET]) { $flag->{debug} = [DBG_TRACE, 0]; } elsif ($flag->{trace}->[DTM_CLEAR] == TRC_ALL) { $flag->{debug} = [0, DBG_TRACE]; } $p->{yyval} = $flag; } } if ($p->{yyn} == 30) { #line 271 "./Parser.y" { my $flag = {}; $flag->{debug} = $p->{yyvs}->[$p->{yyvsp}-0]; $p->{yyval} = $flag; } } if ($p->{yyn} == 31) { #line 278 "./Parser.y" { my $flag = {}; $flag->{args} = $p->{yyvs}->[$p->{yyvsp}-0]; $p->{yyval} = $flag; } } if ($p->{yyn} == 32) { #line 285 "./Parser.y" { ; } } if ($p->{yyn} == 33) { #line 292 "./Parser.y" { # create a new flag $flag = [0, 0]; if ($p->{yyvs}->[$p->{yyvsp}-2]) { $flag->[DTM_SET] = $p->{yyvs}->[$p->{yyvsp}-0]; } else { $flag->[DTM_CLEAR] = $p->{yyvs}->[$p->{yyvsp}-0]; } $p->{yyval} = $flag; } } if ($p->{yyn} == 34) { #line 306 "./Parser.y" { $p->{yyval} = TRC_ALL; } } if ($p->{yyn} == 35) { #line 307 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 36) { #line 311 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 37) { #line 312 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-2] | $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 38) { #line 317 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 39) { #line 318 "./Parser.y" { $p->{yyval} = &{$p->{yyvs}->[$p->{yyvsp}-1]}($p->{yyvs}->[$p->{yyvsp}-0]); } } if ($p->{yyn} == 40) { #line 322 "./Parser.y" { $p->{yyval} = \&less_or_equal; } } if ($p->{yyn} == 41) { #line 323 "./Parser.y" { $p->{yyval} = \&greater_or_equal; } } if ($p->{yyn} == 42) { #line 324 "./Parser.y" { $p->{yyval} = \&greater; } } if ($p->{yyn} == 43) { #line 325 "./Parser.y" { $p->{yyval} = \&less; } } if ($p->{yyn} == 44) { #line 329 "./Parser.y" { $p->{yyval} = TRC_ALL; } } if ($p->{yyn} == 45) { #line 330 "./Parser.y" { $p->{yyval} = TRC_EMERGENCY; } } if ($p->{yyn} == 46) { #line 331 "./Parser.y" { $p->{yyval} = TRC_ALERT; } } if ($p->{yyn} == 47) { #line 332 "./Parser.y" { $p->{yyval} = TRC_CRITICAL; } } if ($p->{yyn} == 48) { #line 333 "./Parser.y" { $p->{yyval} = TRC_ERROR; } } if ($p->{yyn} == 49) { #line 334 "./Parser.y" { $p->{yyval} = TRC_WARNING; } } if ($p->{yyn} == 50) { #line 335 "./Parser.y" { $p->{yyval} = TRC_NOTICE; } } if ($p->{yyn} == 51) { #line 336 "./Parser.y" { $p->{yyval} = TRC_INFO; } } if ($p->{yyn} == 52) { #line 337 "./Parser.y" { $p->{yyval} = TRC_DEBUG; } } if ($p->{yyn} == 53) { #line 342 "./Parser.y" { # create a new flag $flag = [0, 0]; if ($p->{yyvs}->[$p->{yyvsp}-1]) { $flag->[DTM_SET] = $p->{yyvs}->[$p->{yyvsp}-3]; } else { $flag->[DTM_CLEAR] = $p->{yyvs}->[$p->{yyvsp}-3]; } $p->{yyval} = $flag; } } if ($p->{yyn} == 54) { #line 356 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-1]; } } if ($p->{yyn} == 55) { #line 360 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0] ? -1 : 0; } } if ($p->{yyn} == 56) { #line 361 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 57) { #line 367 "./Parser.y" { ; } } if ($p->{yyn} == 58) { #line 371 "./Parser.y" { ; } } if ($p->{yyn} == 59) { #line 378 "./Parser.y" { ; } } if ($p->{yyn} == 60) { #line 384 "./Parser.y" { $p->{yyval} = TRUE; } } if ($p->{yyn} == 61) { #line 385 "./Parser.y" { $p->{yyval} = FALSE; } } if ($p->{yyn} == 62) { #line 389 "./Parser.y" { $p->{yyval} = DBG_ALL; } } if ($p->{yyn} == 63) { #line 390 "./Parser.y" { $p->{yyval} = DBG_FLOW; } } if ($p->{yyn} == 64) { #line 391 "./Parser.y" { $p->{yyval} = DBG_RETURN; } } if ($p->{yyn} == 65) { #line 392 "./Parser.y" { $p->{yyval} = DBG_REQUIRE; } } if ($p->{yyn} == 66) { #line 393 "./Parser.y" { $p->{yyval} = DBG_ASSERT; } } if ($p->{yyn} == 67) { #line 394 "./Parser.y" { $p->{yyval} = DBG_ENSURE; } } if ($p->{yyn} == 68) { #line 395 "./Parser.y" { $p->{yyval} = DBG_PANIC; } } if ($p->{yyn} == 69) { #line 396 "./Parser.y" { $p->{yyval} = DBG_STACK; } } if ($p->{yyn} == 70) { #line 400 "./Parser.y" { $p->{yyval} = [$p->{yyvs}->[$p->{yyvsp}-0]];} } if ($p->{yyn} == 71) { #line 402 "./Parser.y" { push @{$p->{yyvs}->[$p->{yyvsp}-2]}, $p->{yyvs}->[$p->{yyvsp}-0]; $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-2]; } } if ($p->{yyn} == 72) { #line 409 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } if ($p->{yyn} == 73) { #line 413 "./Parser.y" { $p->{yyval} = [$p->{yyvs}->[$p->{yyvsp}-0]]; } } if ($p->{yyn} == 74) { #line 415 "./Parser.y" { push @{$p->{yyvs}->[$p->{yyvsp}-2]}, $p->{yyvs}->[$p->{yyvsp}-0]; $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-2]; } } if ($p->{yyn} == 75) { #line 422 "./Parser.y" { $p->{yyval} = $p->{yyvs}->[$p->{yyvsp}-0]; } } #line 896 "Parser.pm" $p->{yyssp} -= $p->{yym}; $p->{yystate} = $p->{yyss}->[$p->{yyssp}]; $p->{yyvsp} -= $p->{yym}; $p->{yym} = $yylhs[$p->{yyn}]; if ($p->{yystate} == 0 && $p->{yym} == 0) { warn("yydebug: after reduction, shifting from state 0 ", "to state $YYFINAL\n") if $p->{yydebug}; $p->{yystate} = $YYFINAL; $p->{yyss}->[++$p->{yyssp}] = $YYFINAL; $p->{yyvs}->[++$p->{yyvsp}] = $p->{yyval}; if ($p->{yychar} < 0) { if ((($p->{yychar}, $p->{yylval}) = &{$p->{yylex}}($s)) < 0) { $p->{yychar} = 0; } if ($p->{yydebug}) { $p->{yys} = ''; if ($p->{yychar} <= $#yyname) { $p->{yys} = $yyname[$p->{yychar}]; } if (!$p->{yys}) { $p->{yys} = 'illegal-symbol'; } warn("yydebug: state $YYFINAL, reading " . $p->{yychar} . " (" . $p->{yys} . ")\n"); } } return ($p->{yyvs}->[1]) if $p->{yychar} == 0; next yyloop; } if (($p->{yyn} = $yygindex[$p->{yym}]) && ($p->{yyn} += $p->{yystate}) >= 0 && $p->{yyn} <= $#yycheck && $yycheck[$p->{yyn}] == $p->{yystate}) { $p->{yystate} = $yytable[$p->{yyn}]; } else { $p->{yystate} = $yydgoto[$p->{yym}]; } warn("yydebug: after reduction, shifting from state " . $p->{yyss}->[$p->{yyssp}] . " to state " . $p->{yystate} . "\n") if $p->{yydebug}; $p->{yyss}[++$p->{yyssp}] = $p->{yystate}; $p->{yyvs}[++$p->{yyvsp}] = $p->{yyval}; } # yyloop } # yyparse #line 426 "./Parser.y" # Print semantic error sub yywrong { my ($msg) = @_; print STDERR "file $file, line $yylineno: ERROR: $msg\n"; #confess "trace:\n"; yyerror("syntax error"); } # Print warning sub yywarn { my ($msg) = @_; print STDERR "file $file line $yylineno: WARNING: $msg\n"; } # Print warning without line number sub yytell { my ($msg) = @_; print STDERR "WARNING: $msg\n"; } sub yy_lineno { $yylineno += $yylval =~ tr/\n/\n/; } # Print parsing error, trying to give at least next two tokens sub yyerror { my ($msg) = @_; my ($near) = /^\s*(\S+[ \t]*\w*)/; ($near) = /^\s*(\w+[ \t]*\w*)/ if $near eq ''; $near =~ tr/\n\t/ /; $near =~ tr/ //s; $near =~ s/\s*$//; print STDERR "$msg at line $yylineno in file $file"; my ($after) = $yylast =~ /(\w+\s+\w+)$/; ($after) = $yylast =~/(\S+\s*\w+)$/ if $after eq ''; ($after) = $yylast =~/(\S+)$/ if $after eq ''; print STDERR " after \"$after\"" unless $after eq ''; print STDERR " near \"$near\"" unless $near eq ''; print STDERR "\n"; die "Abort processing\n"; } sub yy_top { &yy_comment if m!/(/|\*)!; # Discard comments my $kw; return $kw if defined ($kw = &yy_keyword); return &yy_dflt; } sub yy_skip { my $in_comment = 0; $yylval = ""; while ($_ ne '') { if (!$in_comment) { my $sp = ""; if ($skip_mode == 0) { # leave what matches for next turn if (s/^(\s*)($skip_to)/$2/) { $yylval .= $1; $sp = $yylval; $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number return $K_FIND; } } elsif (s/^(\s*)($skip_to)//) { $yylval .= $1; $sp = $yylval; $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number return $K_FIND; } } # skip comment if (s/^(\/\*)//) { $in_comment = 1; $yylval .= $1; } if (s/^(.*\*\/)//) { $in_comment = 0; $yylval .= $1; } s/^(.*)//; $yylval .= $1; s/^(\s*)//; $yylval .= $1; } return 0; # Should not reach that point, but if we do... } # Strip comment on current lines and subsequent ones, updating $yylineno # This takes care of comments appearing within lexical parts, whilst global # ones starting at the beginning of a line are taken care of by &yylex. # The routine handles both // and /* */ comments. sub yy_comment { while (s!^(//.*)!! || s!^(/\*(?:.|\n)*?\*/)!!) { my $com = $1; print "yylex: tokener stripped '$com' at line $yylineno\n" if $yydebug; $yylineno += $com =~ tr/\n/\n/; # Count lines s/^(\s*)//; my $sl = $1; $yylineno += $sl =~ tr/\n/\n/; # Count lines } } sub yy_keyword { %Keyword = ( 'alert' => $ALERT, 'alias' => $ALIAS, 'all' => $ALL, 'args' => $ARGS, 'assert' => $ASSERT, 'automark' => $AUTOMARK, 'cluster' => $CLUSTER, 'critical' => $CRITICAL, 'debug' => $DEBUG, 'default' => $DEFAULT, 'dump' => $DUMP, 'error' => $ERROR, 'emergency' => $EMERGENCY, 'ensure' => $ENSURE, 'exec' => $EXEC, 'file' => $FILE, 'flags' => $FLAGS, 'flow' => $FLOW, 'info' => $INFO, 'memory' => $MEMORY, 'no' => $NO, 'notice' => $NOTICE, 'object' => $OBJECT, 'panic' => $PANIC, 'propagate' => $PROPAGATE, 'require' => $REQUIRE, 'return' => $RETURN, 'routine' => $ROUTINE, 'severe' => $SEVERE, 'stack' => $STACK, 'startup' => $STARTUP, 'state' => $STATE, 'test' => $TEST, 'trace' => $TRACE, 'type' => $TYPE, 'use' => $USE, 'usr1' => $USR1, 'usr2' => $USR2, 'warning' => $WARNING, 'yes' => $YES ) unless defined %Keyword; return undef unless /^(\w+)/ && exists $Keyword{$1}; my $word = $1; s/^\w+//; $yylval = $word; return $Keyword{$word}; } sub yy_dflt { &yy_comment if m!/(/|\*)!; # Discard comments if (s/^(>=)//) { return $GEQ; } if (s/^(<=)//) { return $LEQ; } if (s/^(=>)//) { return $AS; } # Characters standing for themselves if (s/^([{}!<>:=;,()\[\]])//) { return $yylval = ord($1); } # Handle special tokens if (s/^(\*)//) { $yylval = $1; return $T_POINTER } # handle string if (s/^\"(.*?)\"//) { $yylval = $1; return $STRING; } # Handle numbers if (s/^(0\d+)\b//) { $yylval = oct($1); return $T_NUM; } if (s/^(0b[01]+)\b//i) { $yylval = bin($1); return $T_NUM } if (s/^(0x[\da-f]+)\b//i) { $yylval = hex($1); return $T_NUM } if (s/^(\d+)\b//) { $yylval = int($1); return $T_NUM } # Words if (s/^(\w+)//) { $yylval = $1; return $T_WORD } # Default action: return whatever character we are facing s/^(.)// and return $yylval = ord($1); return 0; # Should not reach that point, but if we do... } # Lexical parser of the $_ string, along with line count tracking. In order # to simplify processing of lines, the parsed string must have a leading # new-line prepended to it before firing off the gramatical analysis. sub yylex { my $sp = ''; # Amount of spaces stripped of my $sl = 0; # True if at the start of a line if ($expect ne "yy_skip") { for (;;) { s/^(\s*)// and $sp = $1; # Spaces are not significant $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number next if $sl && s|^\s*\//.*\n|\n|; # Skip comments last; } } if ($yydebug) { my ($trace) = /^((?:.*)\n*(?:.*)\n*)/m; # Next two lines at most my $more = length($trace) < length($_) ? "...more...\n" : ''; $trace =~ tr/\n/\n/s; # Avoid succession of new-lines print "yylex: [line $yylineno] $trace$more"; print "yylex: calling $expect\n"; } my $ret = $_ ne '' ? &$expect : 0; # 0 signals EOF to yyparse # Remember last read token for yyerror. Dont forget that it might be # an ASCII number and convert it back to a char in that case... $yylast = $yylval eq $ret ? chr($yylval) : $yylval; $yylast = '' unless $ret; print "yylex: tokener read '$yylast'\n" if $yydebug; return ($ret, $yylval); } sub init_parser { my ($p) = shift; $file = shift; # for error message and to store in attribute card info $yylineno = 0; } ################################################################# # # Routines usefull during the parsing # ################################################################# # # -> merge_flag # sub merge_flag { my ($flag, $new) = @_; # merge the debug unless (defined $flag->{debug}) { $flag->{debug} = [0, 0]; } if (defined $new->{debug}) { my $set = ($flag->{debug}->[DTM_SET] & ~$new->{debug}->[DTM_CLEAR]) | $new->{debug}->[DTM_SET]; my $clear = ($flag->{debug}->[DTM_CLEAR] & ~$new->{debug}->[DTM_SET]) | $new->{debug}->[DTM_CLEAR]; $flag->{debug}->[DTM_SET] = $set; $flag->{debug}->[DTM_CLEAR] = $clear; } # merge the trace unless (defined $flag->{trace}) { $flag->{trace} = [0, 0]; } if (defined $new->{trace}) { my $set = ($flag->{trace}->[DTM_SET] & ~$new->{trace}->[DTM_CLEAR]) | $new->{trace}->[DTM_SET]; my $clear = ($flag->{trace}->[DTM_CLEAR] & ~$new->{trace}->[DTM_SET]) | $new->{trace}->[DTM_CLEAR]; $flag->{trace}->[DTM_SET] = $set; $flag->{trace}->[DTM_CLEAR] = $clear; } # merge args level unless (defined $flag->{args}) { $flag->{args} = -1; } if (defined $new->{args}) { $flag->{args} = $new->{args}; } } sub less { my $flag = shift; return ($flag - 1); } sub less_or_equal { my $flag = shift; return less($flag) | $flag; } sub greater { return ~(less_or_equal(@_)); } sub greater_or_equal { my $flag = shift; return greater_or_equal($flag) | $flag; } 1; #line 1267 "Parser.pm" 1; Carp-Datum-0.1.3/Datum/Parser.y0100644000605300000120000004656707323625310015516 0ustar dhooverstaff/* -*- Mode: perl -*- * * $Id: Parser.y,v 0.1 2001/03/31 10:04:36 ram Exp $ * * Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi * * You may redistribute only under the terms of the Artistic License, * as specified in the README file that comes with the distribution. * * HISTORY * $Log: Parser.y,v $ * Revision 0.1 2001/03/31 10:04:36 ram * Baseline for first Alpha release. * * $EndLog$ */ %{ package Carp::Datum::Parser; use Carp::Datum::Flags; BEGIN { sub TRUE () {1}; sub FALSE () {0}; } %} %token FLAGS DEFAULT FILE ROUTINE USE TYPE ALIAS %token STRING T_WORD T_NUM %token FLOW REQUIRE ASSERT ENSURE RETURN STACK CLUSTER PANIC PROPAGATE %token EXEC TRACE EMERGENCY ALERT CRITICAL ERROR %token AUTOMARK INVARIANT %token WARNING NOTICE INFO DEBUG TEST DUMP ALL USR1 USR2 %token MEMORY OBJECT STATE STARTUP %token YES NO LEQ GEQ AS %token ARGS %start root %% root : { $expect = yy_top; # allocate the object that is gonna be returned $result = {}; } statements { $$ = $result; } ; statements : /* empty */ | statements statement ; statement : flags_definition | default_setting | alias_setting | file_definition | cluster_definition | type_definition # routine_definition rule is shared. # Its processing must not always modify the $result variable. | routine_definition { my $new = $1; if (defined $result->{routine}) { for my $key (keys %{$new}) { $result->{routine}->{$key} = $new->{$key}; } } else { $result->{routine} = $new; } } ; flags_definition : FLAGS ident '{' flags_list '}' { if ($4 != 0) { $result->{define}->{$2} = $4; } } ; default_setting : DEFAULT ident ';' { $result->{default} = {}; if (defined $result->{define}->{$2}) { merge_flag($result->{default},$result->{define}->{$2}); } } | DEFAULT '{' flags_list '}' { if ($3 != 0) { $result->{default} = $3; } } ; alias_setting : ALIAS STRING AS STRING ';' { push @{$result->{alias}}, [$2, $4]; } file_definition : FILE string_list '{' flags_or_routines_list '}' { if ($4 != 0) { for my $string (@{$2}) { $result->{file}->{$string} = $4; } } } ; cluster_definition : CLUSTER string_list '{' flags_list '}' { if ($4 != 0) { for my $string (@{$2}) { $result->{cluster}->{$string}->{flags} = $4; } } } ; routine_definition : ROUTINE string_list '{' flags_list '}' { my $hash = {}; if ($4 != 0) { for my $string (@{$2}) { $hash->{$string}->{flags} = $4; } } $$ = $hash; } ; type_definition : TYPE string_list '{' flags_or_routines_list '}' { if ($4 != 0) { for my $string (@{$2}) { $result->{type}->{$string} = $4; } } } ; flags_or_routines_list : /* empty */ { $$ = 0; } | flags_or_routines { $$ = $1; } | flags_or_routines_list flags_or_routines { my $current = $1; my $new = $2; # # If new node holds flags, merge them. # if (defined $new->{flags}) { if (defined $current->{flags}) { merge_flag($current->{flags}, $new->{flags}); } else { $current->{flags} = $new->{flags}; } } # # If new node holds routine, merge them. # if (defined $new->{routine}) { if (defined $current->{routine}) { for my $key (keys %{$new->{routine}}) { $current->{routine}->{$key} = $new->{routine}->{$key}; } } else { $current->{routine} = $new->{routine}; } } $$ = $current; } ; flags_or_routines : flags_spec ';' { my $flag = {}; $flag->{flags} = $1; $$ = $flag; } | routine_definition { my $routine = {}; $routine->{routine} = $1; $$ = $routine; } ; flags_list : /* empty */ { $$ = 0; } | flags_spec ';' { $$ = $1; } | flags_list flags_spec ';' { my $flag = $1; my $new = $2; merge_flag($flag, $new); $$ = $flag; } ; flags_spec : USE ident_list { my $flag = {}; for my $ident (@{$2}) { if (defined $result->{define}->{$ident}) { merge_flag($flag, $result->{define}->{$ident}); } } $$ = $flag; } | trace_spec { my $flag = {}; $flag->{trace} = $1; # If at least one trace flag is set, we need to activate # tracing. If no flag is set and all are clear, we deactivate # tracing alltogether. if ($flag->{trace}->[DTM_SET]) { $flag->{debug} = [DBG_TRACE, 0]; } elsif ($flag->{trace}->[DTM_CLEAR] == TRC_ALL) { $flag->{debug} = [0, DBG_TRACE]; } $$ = $flag; } | flag_spec { my $flag = {}; $flag->{debug} = $1; $$ = $flag; } | args_spec { my $flag = {}; $flag->{args} = $1; $$ = $flag; } | automark_spec { ; } ; trace_spec : TRACE '(' yes_or_no ')' trace_flags { # create a new flag $flag = [0, 0]; if ($3) { $flag->[DTM_SET] = $5; } else { $flag->[DTM_CLEAR] = $5; } $$ = $flag; } ; trace_flags : /* empty */ { $$ = TRC_ALL; } | ':' trace_flag_list { $$ = $2; } ; trace_flag_list : trace_flag { $$ = $1; } | trace_flag_list ',' trace_flag { $$ = $1 | $3; } ; trace_flag : trace_flag_token { $$ = $1; } | cmp_tag trace_flag_token { $$ = &{$1}($2); } ; cmp_tag : LEQ { $$ = \&less_or_equal; } | GEQ { $$ = \&greater_or_equal; } | '>' { $$ = \&greater; } | '<' { $$ = \&less; } ; trace_flag_token : ALL { $$ = TRC_ALL; } | EMERGENCY { $$ = TRC_EMERGENCY; } | ALERT { $$ = TRC_ALERT; } | CRITICAL { $$ = TRC_CRITICAL; } | ERROR { $$ = TRC_ERROR; } | WARNING { $$ = TRC_WARNING; }; | NOTICE { $$ = TRC_NOTICE; } | INFO { $$ = TRC_INFO; } | DEBUG { $$ = TRC_DEBUG; } ; flag_spec : flag '(' yes_or_no ')' { # create a new flag $flag = [0, 0]; if ($3) { $flag->[DTM_SET] = $1; } else { $flag->[DTM_CLEAR] = $1; } $$ = $flag; } ; args_spec : ARGS '(' args_level ')' { $$ = $3; } ; args_level : yes_or_no { $$ = $1 ? -1 : 0; } | T_NUM { $$ = $1; } ; automark_spec : automark_flag { ; } | automark_flag ':' STRING { ; } ; automark_flag : AUTOMARK '(' yes_or_no ')' { ; } ; yes_or_no : YES { $$ = TRUE; } | NO { $$ = FALSE; } ; flag : ALL { $$ = DBG_ALL; } | FLOW { $$ = DBG_FLOW; } | RETURN { $$ = DBG_RETURN; } | REQUIRE { $$ = DBG_REQUIRE; } | ASSERT { $$ = DBG_ASSERT; } | ENSURE { $$ = DBG_ENSURE; } | PANIC { $$ = DBG_PANIC; } | STACK { $$ = DBG_STACK; } ; ident_list : ident { $$ = [$1];} | ident_list ',' ident { push @{$1}, $3; $$ = $1; } ; ident : T_WORD { $$ = $1; } ; string_list : string { $$ = [$1]; } | string_list ',' string { push @{$1}, $3; $$ = $1; } ; string : STRING { $$ = $1; } ; %% # Print semantic error sub yywrong { my ($msg) = @_; print STDERR "file $file, line $yylineno: ERROR: $msg\n"; #confess "trace:\n"; yyerror("syntax error"); } # Print warning sub yywarn { my ($msg) = @_; print STDERR "file $file line $yylineno: WARNING: $msg\n"; } # Print warning without line number sub yytell { my ($msg) = @_; print STDERR "WARNING: $msg\n"; } sub yy_lineno { $yylineno += $yylval =~ tr/\n/\n/; } # Print parsing error, trying to give at least next two tokens sub yyerror { my ($msg) = @_; my ($near) = /^\s*(\S+[ \t]*\w*)/; ($near) = /^\s*(\w+[ \t]*\w*)/ if $near eq ''; $near =~ tr/\n\t/ /; $near =~ tr/ //s; $near =~ s/\s*$//; print STDERR "$msg at line $yylineno in file $file"; my ($after) = $yylast =~ /(\w+\s+\w+)$/; ($after) = $yylast =~/(\S+\s*\w+)$/ if $after eq ''; ($after) = $yylast =~/(\S+)$/ if $after eq ''; print STDERR " after \"$after\"" unless $after eq ''; print STDERR " near \"$near\"" unless $near eq ''; print STDERR "\n"; die "Abort processing\n"; } sub yy_top { &yy_comment if m!/(/|\*)!; # Discard comments my $kw; return $kw if defined ($kw = &yy_keyword); return &yy_dflt; } sub yy_skip { my $in_comment = 0; $yylval = ""; while ($_ ne '') { if (!$in_comment) { my $sp = ""; if ($skip_mode == 0) { # leave what matches for next turn if (s/^(\s*)($skip_to)/$2/) { $yylval .= $1; $sp = $yylval; $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number return $K_FIND; } } elsif (s/^(\s*)($skip_to)//) { $yylval .= $1; $sp = $yylval; $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number return $K_FIND; } } # skip comment if (s/^(\/\*)//) { $in_comment = 1; $yylval .= $1; } if (s/^(.*\*\/)//) { $in_comment = 0; $yylval .= $1; } s/^(.*)//; $yylval .= $1; s/^(\s*)//; $yylval .= $1; } return 0; # Should not reach that point, but if we do... } # Strip comment on current lines and subsequent ones, updating $yylineno # This takes care of comments appearing within lexical parts, whilst global # ones starting at the beginning of a line are taken care of by &yylex. # The routine handles both // and /* */ comments. sub yy_comment { while (s!^(//.*)!! || s!^(/\*(?:.|\n)*?\*/)!!) { my $com = $1; print "yylex: tokener stripped '$com' at line $yylineno\n" if $yydebug; $yylineno += $com =~ tr/\n/\n/; # Count lines s/^(\s*)//; my $sl = $1; $yylineno += $sl =~ tr/\n/\n/; # Count lines } } sub yy_keyword { %Keyword = ( 'alert' => $ALERT, 'alias' => $ALIAS, 'all' => $ALL, 'args' => $ARGS, 'assert' => $ASSERT, 'automark' => $AUTOMARK, 'cluster' => $CLUSTER, 'critical' => $CRITICAL, 'debug' => $DEBUG, 'default' => $DEFAULT, 'dump' => $DUMP, 'error' => $ERROR, 'emergency' => $EMERGENCY, 'ensure' => $ENSURE, 'exec' => $EXEC, 'file' => $FILE, 'flags' => $FLAGS, 'flow' => $FLOW, 'info' => $INFO, 'memory' => $MEMORY, 'no' => $NO, 'notice' => $NOTICE, 'object' => $OBJECT, 'panic' => $PANIC, 'propagate' => $PROPAGATE, 'require' => $REQUIRE, 'return' => $RETURN, 'routine' => $ROUTINE, 'severe' => $SEVERE, 'stack' => $STACK, 'startup' => $STARTUP, 'state' => $STATE, 'test' => $TEST, 'trace' => $TRACE, 'type' => $TYPE, 'use' => $USE, 'usr1' => $USR1, 'usr2' => $USR2, 'warning' => $WARNING, 'yes' => $YES ) unless defined %Keyword; return undef unless /^(\w+)/ && exists $Keyword{$1}; my $word = $1; s/^\w+//; $yylval = $word; return $Keyword{$word}; } sub yy_dflt { &yy_comment if m!/(/|\*)!; # Discard comments if (s/^(>=)//) { return $GEQ; } if (s/^(<=)//) { return $LEQ; } if (s/^(=>)//) { return $AS; } # Characters standing for themselves if (s/^([{}!<>:=;,()\[\]])//) { return $yylval = ord($1); } # Handle special tokens if (s/^(\*)//) { $yylval = $1; return $T_POINTER } # handle string if (s/^\"(.*?)\"//) { $yylval = $1; return $STRING; } # Handle numbers if (s/^(0\d+)\b//) { $yylval = oct($1); return $T_NUM; } if (s/^(0b[01]+)\b//i) { $yylval = bin($1); return $T_NUM } if (s/^(0x[\da-f]+)\b//i) { $yylval = hex($1); return $T_NUM } if (s/^(\d+)\b//) { $yylval = int($1); return $T_NUM } # Words if (s/^(\w+)//) { $yylval = $1; return $T_WORD } # Default action: return whatever character we are facing s/^(.)// and return $yylval = ord($1); return 0; # Should not reach that point, but if we do... } # Lexical parser of the $_ string, along with line count tracking. In order # to simplify processing of lines, the parsed string must have a leading # new-line prepended to it before firing off the gramatical analysis. sub yylex { my $sp = ''; # Amount of spaces stripped of my $sl = 0; # True if at the start of a line if ($expect ne "yy_skip") { for (;;) { s/^(\s*)// and $sp = $1; # Spaces are not significant $sl = $sp =~ tr/\n/\n/; # Count newlines seen $yylineno += $sl; # Keep track of line number next if $sl && s|^\s*\//.*\n|\n|; # Skip comments last; } } if ($yydebug) { my ($trace) = /^((?:.*)\n*(?:.*)\n*)/m; # Next two lines at most my $more = length($trace) < length($_) ? "...more...\n" : ''; $trace =~ tr/\n/\n/s; # Avoid succession of new-lines print "yylex: [line $yylineno] $trace$more"; print "yylex: calling $expect\n"; } my $ret = $_ ne '' ? &$expect : 0; # 0 signals EOF to yyparse # Remember last read token for yyerror. Dont forget that it might be # an ASCII number and convert it back to a char in that case... $yylast = $yylval eq $ret ? chr($yylval) : $yylval; $yylast = '' unless $ret; print "yylex: tokener read '$yylast'\n" if $yydebug; return ($ret, $yylval); } sub init_parser { my ($p) = shift; $file = shift; # for error message and to store in attribute card info $yylineno = 0; } ################################################################# # # Routines usefull during the parsing # ################################################################# # # -> merge_flag # sub merge_flag { my ($flag, $new) = @_; # merge the debug unless (defined $flag->{debug}) { $flag->{debug} = [0, 0]; } if (defined $new->{debug}) { my $set = ($flag->{debug}->[DTM_SET] & ~$new->{debug}->[DTM_CLEAR]) | $new->{debug}->[DTM_SET]; my $clear = ($flag->{debug}->[DTM_CLEAR] & ~$new->{debug}->[DTM_SET]) | $new->{debug}->[DTM_CLEAR]; $flag->{debug}->[DTM_SET] = $set; $flag->{debug}->[DTM_CLEAR] = $clear; } # merge the trace unless (defined $flag->{trace}) { $flag->{trace} = [0, 0]; } if (defined $new->{trace}) { my $set = ($flag->{trace}->[DTM_SET] & ~$new->{trace}->[DTM_CLEAR]) | $new->{trace}->[DTM_SET]; my $clear = ($flag->{trace}->[DTM_CLEAR] & ~$new->{trace}->[DTM_SET]) | $new->{trace}->[DTM_CLEAR]; $flag->{trace}->[DTM_SET] = $set; $flag->{trace}->[DTM_CLEAR] = $clear; } # merge args level unless (defined $flag->{args}) { $flag->{args} = -1; } if (defined $new->{args}) { $flag->{args} = $new->{args}; } } sub less { my $flag = shift; return ($flag - 1); } sub less_or_equal { my $flag = shift; return less($flag) | $flag; } sub greater { return ~(less_or_equal(@_)); } sub greater_or_equal { my $flag = shift; return greater_or_equal($flag) | $flag; } 1; Carp-Datum-0.1.3/Datum/Strip.pm0100644000605300000120000001371507421373501015515 0ustar dhooverstaff# # $Id: Strip.pm,v 0.1 2001/03/31 10:04:36 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Strip.pm,v $ # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package Carp::Datum::Strip; require Exporter; use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw(datum_strip); use Log::Agent; # # datum_strip # # Strip all Datum assertions in file and flow control tracing. # Also turn Datum off by stripping the "use" line. # # Let all DTRACE statements pass through. # # Arguments: # file old file path, to strip # fnew new file, stripped # ext when defined, renames fnew as file upon success and file with ext # # Returns 1 if OK, undef otherwise. # sub datum_strip { my ($file, $fnew, $ext) = @_; local *OLD; local *NEW; if ($file eq '-') { logdie "can't dup stdin: $!" unless open(OLD, '<&STDIN'); } else { unless (open(OLD, $file)) { logerr "can't open $file: $!"; return; } } if ($fnew eq '-') { logdie "can't dup stdout: $!" unless open(NEW, '>&STDOUT'); } else { unless (open(NEW, ">$fnew")) { logerr "can't create $fnew: $!"; close OLD; return; } } eval { strip(\*OLD, \*NEW) }; if (chop $@) { logerr "can't write to $fnew: $@"; close NEW; close OLD; return; } if ($file ne '-' && $fnew ne '-') { my $mode = (stat(OLD))[2] & 07777; chmod $mode, $fnew or logwarn "can't propagate mode %04o on $fnew: $!"; } unless (close NEW) { logerr "can't flush $fnew: $!"; close OLD; return; } close OLD; return 1 if $file eq '-' || $fnew eq '-'; return 1 unless defined $ext; unless (rename($file, "$file$ext")) { logwarn "can't rename $file as $file$ext: $!"; return; } unless (rename($fnew, $file)) { logwarn "can't rename $fnew as $file: $!"; return; } return 1; # OK } # # strip # # Lexical stripping of assertions, and return tracing routines. # We don't have the pretention of handling all the possible cases. # That would be foolish, because we'd have to write a Perl parser! # # Therefore, unless the conventions documented in the Carp::Datum manpage # are strictly followed, stripping will be incorret. # # Note: we don't remove DTRACE, they will be remapped to Log::Agent calls # dynamically. We can't do that statically because the syntax is not # compatible. # sub strip { my ($old, $new) = @_; local $_; my $last_was_nl = 0; while (<$old>) { next if s/^(\s*use Carp::Datum).*;/$1;/; # Turns it off next if s/^(\s*)(?:DVOID|DVAL|DARY)\b/$1/; next if s/^(\s*return)\s+DVOID\b/$1/; next if s/^(\s*return\s+)(?:(?:DVAL|DARY)\s*)/$1/; if (s/^(\s*)(?:DFEATURE|DREQUIRE|DENSURE|DASSERT)\b//) { my $indent = $1; $_ = skip_to_sc($old, $_); s/^\s+//; $_ = /^\s*$/ ? '' : ($indent . $_); # Keep leading indent next; } } continue { my $is_nl = /^\s*$/; unless ($last_was_nl && $is_nl) { print $new $_ or CORE::die "$!\n"; } $last_was_nl = $is_nl; } } # # skip_to_sc # # Strip to next ';' outside any string. # We don't handle regexps, here docs, nor syntactic sugar for quotes. # # Returns anything after the final ';'. # sub skip_to_sc { my ($fd, $str) = @_; my $str_end = ''; for (;;) { if ($str =~ /^\s*$/) { $str = <$fd>; return '' unless defined $str; # EOF } if ($str_end) { # Within string $str =~ s/\\(?:\\\\)*['"`]//g; # Remove escaped quotes $str_end = '' if $str =~ s/.*$str_end//; if ($str_end) { # Still not reached the end $str = ''; next; } } $str =~ s/^[^'"`;]*//; return substr($str, 1) if substr($str, 0, 1) eq ";"; next if $str =~ /^\s*$/; if ($str =~ s/^(['"`])//) { # Found a string $str_end = $1; next; } } } 1; =head1 NAME Carp::Datum::Strip - strips most Carp::Datum calls lexically =head1 SYNOPSIS use Carp::Datum::Strip qw(datum_strip); datum_strip("-", "-"); datum_strip($file, "$file.new", ".bak"); =head1 DESCRIPTION This module exports a single routine, datum_strip(), whose purpose is to remove calls to C routines lexically. Because stripping is done lexically, there are some restrictions about what is actually supported. Unless the conventions documented in L are followed, stripping will be incorrect. The general guidelines are: =over 4 =item * Do not use here documents or generalized quotes (qq) within assertion expression or tags. Write assertions using '' or "", as appropriate. =item * Assertions can be safely put on several lines, but must end with a semi-colon, outside any string. =back There are two calls that will never be stripped: VERIFY() and DTRACE(). The VERIFY() is meant to be preserved (or C would have been used). C, when called, will be remapped dynamically to some C routine, depending on the trace level. See L for details. =head1 INTERFACE The interface of the datum_strip() routine is: =over 4 =item C I, I, [I] The I specifies the old file path, the one to be stripped. The stripped version will be written to I. If the optional third argument I is given (e.g. ".bak"), then I will be renamed with the supplied extension, and I will be renamed I. Renaming only occurs if stripping was successful (i.e. the new file was correctly written to disk). The lowest nine "rwx" mode bits from I are preserved when creating I. Both I and I can be set to "-", in which case STDIN and STDOUT are used, respectively, and no renaming can occur, nor any mode bit propagation. Returns true on success, C on error. =back =head1 AUTHORS Christophe Dehaudt and Raphael Manfredi are the original authors. Send bug reports, hints, tips, suggestions to Dave Hoover at . =head1 SEE ALSO Carp::Datum(3). =cut Carp-Datum-0.1.3/Datum/Makefile0100644000605300000120000000162307323625311015511 0ustar dhooverstaff# -*- Mode: Makefile -*- # # $Id: Makefile,v 0.1 2001/03/31 10:04:36 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Makefile,v $ # Revision 0.1 2001/03/31 10:04:36 ram # Baseline for first Alpha release. # # $EndLog$ # BYACC = pbyacc BYACC_P = Parser BYACC_OPT = -P $(BYACC_P) BYACC_FILE = ./Parser.y BYACC_TARGET = ./$(BYACC_P).pm RM = /bin/rm $(BYACC_TARGET): $(BYACC_FILE) @if test -e $(BYACC_TARGET) -a ! -w $(BYACC_TARGET); then \ @echo "$(BYACC_TARGET) is not writable"; \ else echo "$(BYACC) $(BYACC_OPT) $(BYACC_FILE)"; \ $(BYACC) $(BYACC_OPT) $(BYACC_FILE) && \ perl -pi \ -e 's/[^\\](\$$\$$1)/\\$$1/g;' \ -e 's/\$$\$$1/\$$\\\$$1/g' $(BYACC_TARGET); \ fi; clean:: $(RM) -f $(BYACC_TARGET) Carp-Datum-0.1.3/Makefile.PL0100644000605300000120000000206407323625311014751 0ustar dhooverstaff# # $Id: Makefile.PL,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Makefile.PL,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # use ExtUtils::MakeMaker; print < 'Carp::Datum', 'VERSION_FROM' => 'Datum.pm', # finds $VERSION 'PL_FILES' => \%PL_FILES, 'EXE_FILES' => [ values %PL_FILES ], 'PREREQ_PM' => { 'Log::Agent' => '0.207', 'Getargs::Long' => '0.103', }, 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' ); Carp-Datum-0.1.3/scripts/0040700000605300000120000000000007323625311014455 5ustar dhooverstaffCarp-Datum-0.1.3/scripts/datum_strip.PL0100644000605300000120000000261207323625311017255 0ustar dhooverstaff# -*- perl -*- use strict; use Config; use File::Basename qw(basename dirname); use Cwd; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. my $origdir = cwd; chdir dirname($0); my $script = basename($0, '.PL'); $script .= '.com' if $^O eq 'VMS'; unlink($script); open OUT, ">$script" or die "open for writing $script: $!"; print OUT <<"!GROK!THIS!"; $Config{startperl} !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; # # $Id: datum_strip.PL,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: datum_strip.PL,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; use Log::Agent; logconfig(-prefix => $0); use Carp::Datum::Strip qw(datum_strip); if (@ARGV == 0) { datum_strip("-", "-"); } else { foreach my $file (@ARGV) { datum_strip($file, "$file.new", ".bak"); } } !NO!SUBS! close OUT or die "Can't close $script: $!"; chmod 0755, $script or die "Can't reset permissions for $script: $!\n"; exec("$Config{'eunicefix'} $script") if $Config{'eunicefix'} ne ':'; chdir $origdir; Carp-Datum-0.1.3/t/0040700000605300000120000000000007323625311013231 5ustar dhooverstaffCarp-Datum-0.1.3/t/basic_dflt.t0100644000605300000120000000123107323625311015514 0ustar dhooverstaff# # $Id: basic_dflt.t,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: basic_dflt.t,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # print "1..2\n"; require 't/test.pl'; require 't/code.pl'; sub ok; use Carp::Datum; DFEATURE(my $f); test::square(1); test::wrap_square(1); DVOID; # Force destruction ok 1, 0 == -s "t/file.out"; ok 2, 0 == -s "t/file.err"; unlink 't/file.out', 't/file.err'; Carp-Datum-0.1.3/t/basic_off.t0100644000605300000120000000124407323625311015341 0ustar dhooverstaff# # $Id: basic_off.t,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: basic_off.t,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # print "1..2\n"; require 't/test.pl'; require 't/code.pl'; sub ok; use Carp::Datum qw(:all off); DFEATURE(my $f); test::square(1); test::wrap_square(1); DVOID; # Force destruction ok 1, 0 == -s "t/file.out"; ok 2, 0 == -s "t/file.err"; unlink 't/file.out', 't/file.err'; Carp-Datum-0.1.3/t/basic_on.t0100644000605300000120000000203007323625311015175 0ustar dhooverstaff# # $Id: basic_on.t,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: basic_on.t,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # print "1..5\n"; require 't/test.pl'; require 't/code.pl'; sub ok; use Carp::Datum qw(:all on); my $line = __LINE__ + 1; DFEATURE(my $f); my $file = "t/file.err"; ok 1, contains($file, "^ \\+-> global \\[t/basic_on.t:$line\\]"); $line = __LINE__ + 1; test::square(1); ok 2, contains($file, "test::square\\(1\\) from global at t/basic_on.t:$line"); test::wrap_square(1); ok 3, contains($file, "test::square\\(1\\) from test::wrap_square\\(\\) at t/test.pl"); $line = __LINE__ + 1; DVOID; # Force destruction ok 4, contains($file, "^ \\| Returning \\[t/basic_on.t:$line\\]"); ok 5, 0 == -s "t/file.out"; unlink 't/file.out', 't/file.err'; Carp-Datum-0.1.3/t/code.pl0100644000605300000120000000135407323625311014512 0ustar dhooverstaff# # $Id: code.pl,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: code.pl,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # sub ok { my ($num, $ok) = @_; print "not " unless $ok; print "ok $num\n"; } sub contains { my ($file, $pattern) = @_; local *FILE; local $_; open(FILE, $file) || die "can't open $file: $!\n"; my $found = 0; my $line = 0; while () { $line++; if (/$pattern/) { $found = 1; last; } } close FILE; return $found ? $line : 0; } 1; Carp-Datum-0.1.3/t/test.pl0100644000605300000120000000275007323625311014560 0ustar dhooverstaff# # $Id: test.pl,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: test.pl,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # open(ORIG_STDOUT, ">&STDOUT") || die "can't dup STDOUT: $!\n"; select(ORIG_STDOUT); open(STDOUT, ">t/file.out") || die "can't redirect STDOUT: $!\n"; select((select(STDOUT), $|=1)[0]); open(STDERR, ">t/file.err") || die "can't redirect STDERR: $!\n"; select((select(STDERR), $|=1)[0]); package test; use Carp::Datum; use Log::Agent; sub square { DFEATURE(my $f); my ($x) = @_; DREQUIRE(defined $x, "x=$x is defined"); my $r = $x * $x; DENSURE($r == $x * $x, "$x was squared"); return DVAL $r; } sub wrap_square { DFEATURE(my $f); my $r = □ return DVAL $r; } sub trace { DFEATURE(my $f); DTRACE(TRC_WARNING, "this is a DTRACE warning"); logwarn "this is a Log::Agent warning"; DTRACE("this is a regular DTRACE message"); logsay "this is a Log::Agent message"; return DVOID; } sub fail { DFEATURE my $f, "foo"; my ($which) = @_; DREQUIRE $which > 1, "first require"; DREQUIRE $which > 2 , "second require"; DREQUIRE( $which > 3, "third " . "require" ); DASSERT $which > 4; DENSURE(implies($which == 5, undef), "postcondition"); return DVAL 1; } 1; Carp-Datum-0.1.3/t/trace_off.t0100644000605300000120000000136307323625311015360 0ustar dhooverstaff# # $Id: trace_off.t,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: trace_off.t,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # print "1..4\n"; require 't/test.pl'; require 't/code.pl'; sub ok; use Carp::Datum qw(:all off); test::trace(); ok 1, contains("t/file.err", "Log::Agent message"); my $file = "t/file.err"; ok 2, contains($file, "DTRACE warning"); ok 3, contains($file, "Log::Agent warning"); ok 4, !contains($file, "DTRACE message"); unlink 't/file.out', 't/file.err'; Carp-Datum-0.1.3/t/trace_on.t0100644000605300000120000000154307323625311015222 0ustar dhooverstaff# # $Id: trace_on.t,v 0.1 2001/03/31 10:04:37 ram Exp $ # # Copyright (c) 2000-2001, Christophe Dehaudt & Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: trace_on.t,v $ # Revision 0.1 2001/03/31 10:04:37 ram # Baseline for first Alpha release. # # $EndLog$ # print "1..5\n"; require 't/test.pl'; require 't/code.pl'; sub ok; use Carp::Datum qw(:all on); test::trace(); ok 1, contains("t/file.err", "Log::Agent warning"); my $file = "t/file.err"; ok 2, contains($file, "DTRACE warning"); ok 3, contains($file, '^>> \| WARNING: this is a Log::Agent warning'); ok 4, contains($file, '^ \| this is a regular DTRACE message'); ok 5, contains($file, '^>> \| this is a Log::Agent message'); unlink 't/file.out', 't/file.err';