lib/assertions.pm

   1 package assertions;
   2
   3 our $VERSION = '0.02';
   4
   5 # use strict;
   6 # use warnings;
   7
   8 my $hint=0x01000000;
   9 my $seen_hint=0x02000000;
  10
  11 sub _syntax_error ($$) {
  12     my ($expr, $why)=@_;
  13     require Carp;
  14     Carp::croak("syntax error on assertion filter '$expr' ($why)");
  15 }
  16
  17 sub _carp {
  18     require warnings;
  19     if (warnings::enabled('assertions')) {
  20         require Carp;
  21         Carp::carp(@_);
  22     }
  23 }
  24
  25 sub _calc_expr {
  26     my $expr=shift;
  27     my @tokens=split / \s*
  28                        ( &&     # and
  29                        | \|\|   # or
  30                        | \(     # parents
  31                        | \) )
  32                        \s*
  33                        | \s+    # spaces out
  34                      /x, $expr;
  35
  36     # print STDERR "tokens: -", join('-',@tokens), "-\n";
  37
  38     my @now=1;
  39     my @op='start';
  40
  41     for my $t (@tokens) {
  42         next if (!defined $t or $t eq '');
  43
  44         if ($t eq '(') {
  45             unshift @now, 1;
  46             unshift @op, 'start';
  47         }
  48         else {
  49             if ($t eq '||') {
  50                 defined $op[0]
  51                     and _syntax_error $expr, 'consecutive operators';
  52                 $op[0]='||';
  53             }
  54             elsif ($t eq '&&') {
  55                 defined $op[0]
  56                     and _syntax_error $expr, 'consecutive operators';
  57                 $op[0]='&&';
  58             }
  59             else {
  60                 if ($t eq ')') {
  61                     @now==1 and
  62                         _syntax_error $expr, 'unbalanced parens';
  63                     defined $op[0] and
  64                         _syntax_error $expr, "key missing after operator '$op[0]'";
  65
  66                     $t=shift @now;
  67                     shift @op;
  68                 }
  69                 elsif ($t eq '_') {
  70                     unless ($^H & $seen_hint) {
  71                         _carp "assertion status '_' referenced but not previously defined";
  72                     }
  73                     $t=($^H & $hint) ? 1 : 0;
  74                 }
  75                 elsif ($t ne '0' and $t ne '1') {
  76                     $t = ( grep { ref $_ eq 'Regexp'
  77                                       ? $t=~$_
  78                                       : $_->check($t)
  79                                 } @{^ASSERTING} ) ? 1 : 0;
  80                 }
  81
  82                 defined $op[0] or
  83                     _syntax_error $expr, 'operator expected';
  84
  85                 if ($op[0] eq 'start') {
  86                     $now[0]=$t;
  87                 }
  88                 elsif ($op[0] eq '||') {
  89                     $now[0]||=$t;
  90                 }
  91                 else {
  92                     $now[0]&&=$t;
  93                 }
  94                 undef $op[0];
  95             }
  96         }
  97     }
  98     @now==1 or _syntax_error $expr, 'unbalanced parens';
  99     defined $op[0] and _syntax_error $expr, "expression ends on operator '$op[0]'";
 100
 101     return $now[0];
 102 }
 103
 104
 105 sub import {
 106     # print STDERR "\@_=", join("|", @_), "\n";
 107     shift;
 108     @_=(scalar(caller)) unless @_;
 109     foreach my $expr (@_) {
 110         unless (_calc_expr $expr) {
 111             # print STDERR "assertions deactived";
 112             $^H &= ~$hint;
 113             $^H |= $seen_hint;
 114             return;
 115         }
 116     }
 117     # print STDERR "assertions actived";
 118     $^H |= $hint|$seen_hint;
 119 }
 120
 121 sub unimport {
 122     @_ > 1
 123         and _carp($_[0]."->unimport arguments are being ignored");
 124     $^H &= ~$hint;
 125 }
 126
 127 sub enabled {
 128     if (@_) {
 129         if ($_[0]) {
 130             $^H |= $hint;
 131         }
 132         else {
 133             $^H &= ~$hint;
 134         }
 135         $^H |= $seen_hint;
 136     }
 137     return $^H & $hint ? 1 : 0;
 138 }
 139
 140 sub seen {
 141     if (@_) {
 142         if ($_[0]) {
 143             $^H |= $seen_hint;
 144         }
 145         else {
 146             $^H &= ~$seen_hint;
 147         }
 148     }
 149     return $^H & $seen_hint ? 1 : 0;
 150 }
 151
 152 1;
 153
 154 __END__
 155
 156
 157 =head1 NAME
 158
 159 assertions - select assertions in blocks of code
 160
 161 =head1 SYNOPSIS
 162
 163   sub assert (&) : assertion { &{$_[0]}() }
 164
 165   use assertions 'foo';
 166   assert { print "asserting 'foo'\n" };
 167
 168   {
 169       use assertions qw( foo bar );
 170       assert { print "asserting 'foo' and 'bar'\n" };
 171   }
 172
 173   {
 174       use assertions qw( bar );
 175       assert { print "asserting only 'bar'\n" };
 176   }
 177
 178   {
 179       use assertions '_ && bar';
 180       assert { print "asserting 'foo' && 'bar'\n" };
 181   }
 182
 183   assert { print "asserting 'foo' again\n" };
 184
 185 =head1 DESCRIPTION
 186
 187 The C<assertions> pragma specifies the tags used to enable and disable
 188 the execution of assertion subroutines.
 189
 190 An assertion subroutine is declared with the C<:assertion> attribute.
 191 This subroutine is not normally executed: it's optimized away by perl
 192 at compile-time.
 193
 194 The C<assertions> pragma associates to its lexical scope one or
 195 several assertion tags. Then, to activate the execution of the
 196 assertions subroutines in this scope, these tags must be given to perl
 197 via the B<-A> command-line option. For instance, if...
 198
 199   use assertions 'foobar';
 200
 201 is used, assertions on the same lexical scope will only be executed
 202 when perl is called as...
 203
 204   perl -A=foobar script.pl
 205
 206 Regular expressions can also be used within the -A
 207 switch. For instance...
 208
 209   perl -A='foo.*' script.pl
 210
 211 will activate assertions tagged as C<foo>, C<foobar>, C<foofoo>, etc.
 212
 213 =head2 Selecting assertions
 214
 215 Selecting which tags are required to activate assertions inside a
 216 lexical scope, is done with the arguments passed on the C<use
 217 assertions> sentence.
 218
 219 If no arguments are given, the package name is used as the assertion tag:
 220
 221   use assertions;
 222
 223 is equivalent to
 224
 225   use assertions __PACKAGE__;
 226
 227 When several tags are given, all of them have to be activated via the
 228 C<-A> switch to activate assertion execution on that lexical scope,
 229 i.e.:
 230
 231   use assertions qw(Foo Bar);
 232
 233 Constants C<1> and C<0> can be used to force unconditional activation
 234 or deactivation respectively:
 235
 236   use assertions '0';
 237   use assertions '1';
 238
 239 Operators C<&&> and C<||> and parenthesis C<(...)> can be used to
 240 construct logical expressions:
 241
 242   use assertions 'foo && bar';
 243   use assertions 'foo || bar';
 244   use assertions 'foo && (bar || doz)';
 245
 246 (note that the logical operators and the parens have to be included
 247 inside the quoted string).
 248
 249 Finally, the special tag C<_> refers to the current assertion
 250 activation state:
 251
 252   use assertions 'foo';
 253   use assertions '_ && bar;
 254
 255 is equivalent to
 256
 257   use assertions 'foo && bar';
 258
 259 =head2 Handling assertions your own way
 260
 261 The C<assertions> module also provides a set of low level functions to
 262 allow for custom assertion handling modules.
 263
 264 Those functions are not exported and have to be fully qualified with
 265 the package name when called, for instance:
 266
 267   require assertions;
 268   assertions::enabled(1);
 269
 270 (note that C<assertions> is loaded with the C<require> keyword
 271 to avoid calling C<assertions::import()>).
 272
 273 Those functions have to be called at compile time (they are
 274 useless at runtime).
 275
 276 =over 4
 277
 278 =item enabled($on)
 279
 280 activates or deactivates assertion execution. For instance:
 281
 282   package assertions::always;
 283
 284   require assertions;
 285   sub import { assertions::enabled(1) }
 286
 287   1;
 288
 289 This function calls C<assertion::seen(1)> also (see below).
 290
 291 =item enabled()
 292
 293 returns a true value when assertion execution is active.
 294
 295 =item seen($on)
 296
 297 A warning is generated when an assertion subroutine is found before
 298 any assertion selection code. This function is used to just tell perl
 299 that assertion selection code has been seen and that the warning is
 300 not required for the currently compiling lexical scope.
 301
 302 =item seen()
 303
 304 returns true if any assertion selection module (or code) has been
 305 called before on the currently compiling lexical scope.
 306
 307 =back
 308
 309 =head1 COMPATIBILITY
 310
 311 Support for assertions is only available in perl from version 5.9. On
 312 previous perl versions this module will do nothing, though it will not
 313 harm either.
 314
 315 L<assertions::compat> provides an alternative way to use assertions
 316 compatible with lower versions of perl.
 317
 318
 319 =head1 SEE ALSO
 320
 321 L<perlrun>, L<assertions::activate>, L<assertions::compat>.
 322
 323 =head1 AUTHOR
 324
 325 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 326
 327 =head1 COPYRIGHT AND LICENSE
 328
 329 Copyright 2002, 2005 by Salvador FandiE<ntilde>o
 330
 331 This library is free software; you can redistribute it and/or modify
 332 it under the same terms as Perl itself.
 333
 334 =cut