lib/assertions.pm

   1 package assertions;
   2
   3 our $VERSION = '0.04';
   4
   5 # use strict;
   6 # use warnings;
   7
   8 my $hint = 1;
   9 my $seen_hint = 2;
  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{assertions} & $seen_hint) {
  71                         _carp "assertion status '_' referenced but not previously defined";
  72                     }
  73                     $t=($^H{assertions} & $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{assertions} &= ~$hint;
 113             $^H{assertions} |= $seen_hint;
 114             return;
 115         }
 116     }
 117     # print STDERR "assertions actived";
 118     $^H{assertions} |= $hint|$seen_hint;
 119 }
 120
 121 sub unimport {
 122     @_ > 1
 123         and _carp($_[0]."->unimport arguments are being ignored");
 124     $^H{assertions} &= ~$hint;
 125 }
 126
 127 sub enabled {
 128     if (@_) {
 129         if ($_[0]) {
 130             $^H{assertions} |= $hint;
 131         }
 132         else {
 133             $^H{assertions} &= ~$hint;
 134         }
 135         $^H{assertions} |= $seen_hint;
 136     }
 137     return $^H{assertions} & $hint ? 1 : 0;
 138 }
 139
 140 sub seen {
 141     if (@_) {
 142         if ($_[0]) {
 143             $^H{assertions} |= $seen_hint;
 144         }
 145         else {
 146             $^H{assertions} &= ~$seen_hint;
 147         }
 148     }
 149     return $^H{assertions} & $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   *** WARNING: assertion support is only available from perl version
 188   *** 5.9.0 and upwards. Check assertions::compat (also available from
 189   *** this package) for an alternative backwards compatible module.
 190
 191 The C<assertions> pragma specifies the tags used to enable and disable
 192 the execution of assertion subroutines.
 193
 194 An assertion subroutine is declared with the C<:assertion> attribute.
 195 This subroutine is not normally executed: it's optimized away by perl
 196 at compile-time.
 197
 198 The C<assertions> pragma associates to its lexical scope one or
 199 several assertion tags. Then, to activate the execution of the
 200 assertions subroutines in this scope, these tags must be given to perl
 201 via the B<-A> command-line option. For instance, if...
 202
 203   use assertions 'foobar';
 204
 205 is used, assertions on the same lexical scope will only be executed
 206 when perl is called as...
 207
 208   perl -A=foobar script.pl
 209
 210 Regular expressions can also be used within the -A
 211 switch. For instance...
 212
 213   perl -A='foo.*' script.pl
 214
 215 will activate assertions tagged as C<foo>, C<foobar>, C<foofoo>, etc.
 216
 217 =head2 Selecting assertions
 218
 219 Selecting which tags are required to activate assertions inside a
 220 lexical scope, is done with the arguments passed on the C<use
 221 assertions> sentence.
 222
 223 If no arguments are given, the package name is used as the assertion tag:
 224
 225   use assertions;
 226
 227 is equivalent to
 228
 229   use assertions __PACKAGE__;
 230
 231 When several tags are given, all of them have to be activated via the
 232 C<-A> switch to activate assertion execution on that lexical scope,
 233 i.e.:
 234
 235   use assertions qw(Foo Bar);
 236
 237 Constants C<1> and C<0> can be used to force unconditional activation
 238 or deactivation respectively:
 239
 240   use assertions '0';
 241   use assertions '1';
 242
 243 Operators C<&&> and C<||> and parenthesis C<(...)> can be used to
 244 construct logical expressions:
 245
 246   use assertions 'foo && bar';
 247   use assertions 'foo || bar';
 248   use assertions 'foo && (bar || doz)';
 249
 250 (note that the logical operators and the parens have to be included
 251 inside the quoted string).
 252
 253 Finally, the special tag C<_> refers to the current assertion
 254 activation state:
 255
 256   use assertions 'foo';
 257   use assertions '_ && bar;
 258
 259 is equivalent to
 260
 261   use assertions 'foo && bar';
 262
 263 =head2 Handling assertions your own way
 264
 265 The C<assertions> module also provides a set of low level functions to
 266 allow for custom assertion handling modules.
 267
 268 Those functions are not exported and have to be fully qualified with
 269 the package name when called, for instance:
 270
 271   require assertions;
 272   assertions::enabled(1);
 273
 274 (note that C<assertions> is loaded with the C<require> keyword
 275 to avoid calling C<assertions::import()>).
 276
 277 Those functions have to be called at compile time (they are
 278 useless at runtime).
 279
 280 =over 4
 281
 282 =item enabled($on)
 283
 284 activates or deactivates assertion execution. For instance:
 285
 286   package assertions::always;
 287
 288   require assertions;
 289   sub import { assertions::enabled(1) }
 290
 291   1;
 292
 293 This function calls C<assertion::seen(1)> also (see below).
 294
 295 =item enabled()
 296
 297 returns a true value when assertion execution is active.
 298
 299 =item seen($on)
 300
 301 A warning is generated when an assertion subroutine is found before
 302 any assertion selection code. This function is used to just tell perl
 303 that assertion selection code has been seen and that the warning is
 304 not required for the currently compiling lexical scope.
 305
 306 =item seen()
 307
 308 returns true if any assertion selection module (or code) has been
 309 called before on the currently compiling lexical scope.
 310
 311 =back
 312
 313 =head1 COMPATIBILITY
 314
 315 Support for assertions is only available in perl from version 5.9. On
 316 previous perl versions this module will do nothing, though it will not
 317 harm either.
 318
 319 L<assertions::compat> provides an alternative way to use assertions
 320 compatible with lower versions of perl.
 321
 322
 323 =head1 SEE ALSO
 324
 325 L<perlrun>, L<assertions::activate>, L<assertions::compat>.
 326
 327 =head1 AUTHOR
 328
 329 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 330
 331 =head1 COPYRIGHT AND LICENSE
 332
 333 Copyright 2002, 2005 by Salvador FandiE<ntilde>o
 334
 335 This library is free software; you can redistribute it and/or modify
 336 it under the same terms as Perl itself.
 337
 338 =cut