local-lib5/lib/perl5/Carp/Assert.pm

   1 package Carp::Assert;
   2
   3 require 5.004;
   4
   5 use strict qw(subs vars);
   6 use Exporter;
   7
   8 use vars qw(@ISA $VERSION %EXPORT_TAGS);
   9
  10 BEGIN {
  11     $VERSION = '0.20';
  12
  13     @ISA = qw(Exporter);
  14
  15     %EXPORT_TAGS = (
  16                     NDEBUG => [qw(assert affirm should shouldnt DEBUG)],
  17                    );
  18     $EXPORT_TAGS{DEBUG} = $EXPORT_TAGS{NDEBUG};
  19     Exporter::export_tags(qw(NDEBUG DEBUG));
  20 }
  21
  22 # constant.pm, alas, adds too much load time (yes, I benchmarked it)
  23 sub REAL_DEBUG  ()  { 1 }       # CONSTANT
  24 sub NDEBUG      ()  { 0 }       # CONSTANT
  25
  26 # Export the proper DEBUG flag according to if :NDEBUG is set.
  27 # Also export noop versions of our routines if NDEBUG
  28 sub noop { undef }
  29 sub noop_affirm (&;$) { undef };
  30
  31 sub import {
  32     my $env_ndebug = exists $ENV{PERL_NDEBUG} ? $ENV{PERL_NDEBUG}
  33                                               : $ENV{'NDEBUG'};
  34     if( grep(/^:NDEBUG$/, @_) or $env_ndebug ) {
  35         my $caller = caller;
  36         foreach my $func (grep !/^DEBUG$/, @{$EXPORT_TAGS{'NDEBUG'}}) {
  37             if( $func eq 'affirm' ) {
  38                 *{$caller.'::'.$func} = \&noop_affirm;
  39             } else {
  40                 *{$caller.'::'.$func} = \&noop;
  41             }
  42         }
  43         *{$caller.'::DEBUG'} = \&NDEBUG;
  44     }
  45     else {
  46         *DEBUG = *REAL_DEBUG;
  47         Carp::Assert->_export_to_level(1, @_);
  48     }
  49 }
  50
  51
  52 # 5.004's Exporter doesn't have export_to_level.
  53 sub _export_to_level
  54 {
  55       my $pkg = shift;
  56       my $level = shift;
  57       (undef) = shift;                  # XXX redundant arg
  58       my $callpkg = caller($level);
  59       $pkg->export($callpkg, @_);
  60 }
  61
  62
  63 sub unimport {
  64     *DEBUG = *NDEBUG;
  65     push @_, ':NDEBUG';
  66     goto &import;
  67 }
  68
  69
  70 # Can't call confess() here or the stack trace will be wrong.
  71 sub _fail_msg {
  72     my($name) = shift;
  73     my $msg = 'Assertion';
  74     $msg   .= " ($name)" if defined $name;
  75     $msg   .= " failed!\n";
  76     return $msg;
  77 }
  78
  79
  80 =head1 NAME
  81
  82 Carp::Assert - executable comments
  83
  84 =head1 SYNOPSIS
  85
  86     # Assertions are on.
  87     use Carp::Assert;
  88
  89     $next_sunrise_time = sunrise();
  90
  91     # Assert that the sun must rise in the next 24 hours.
  92     assert(($next_sunrise_time - time) < 24*60*60) if DEBUG;
  93
  94     # Assert that your customer's primary credit card is active
  95     affirm {
  96         my @cards = @{$customer->credit_cards};
  97         $cards[0]->is_active;
  98     };
  99
 100
 101     # Assertions are off.
 102     no Carp::Assert;
 103
 104     $next_pres = divine_next_president();
 105
 106     # Assert that if you predict Dan Quayle will be the next president
 107     # your crystal ball might need some polishing.  However, since
 108     # assertions are off, IT COULD HAPPEN!
 109     shouldnt($next_pres, 'Dan Quayle') if DEBUG;
 110
 111
 112 =head1 DESCRIPTION
 113
 114 =begin testing
 115
 116 BEGIN {
 117     local %ENV = %ENV;
 118     delete @ENV{qw(PERL_NDEBUG NDEBUG)};
 119     require Carp::Assert;
 120     Carp::Assert->import;
 121 }
 122
 123 local %ENV = %ENV;
 124 delete @ENV{qw(PERL_NDEBUG NDEBUG)};
 125
 126 =end testing
 127
 128     "We are ready for any unforseen event that may or may not
 129     occur."
 130         - Dan Quayle
 131
 132 Carp::Assert is intended for a purpose like the ANSI C library
 133 assert.h.  If you're already familiar with assert.h, then you can
 134 probably skip this and go straight to the FUNCTIONS section.
 135
 136 Assertions are the explict expressions of your assumptions about the
 137 reality your program is expected to deal with, and a declaration of
 138 those which it is not.  They are used to prevent your program from
 139 blissfully processing garbage inputs (garbage in, garbage out becomes
 140 garbage in, error out) and to tell you when you've produced garbage
 141 output.  (If I was going to be a cynic about Perl and the user nature,
 142 I'd say there are no user inputs but garbage, and Perl produces
 143 nothing but...)
 144
 145 An assertion is used to prevent the impossible from being asked of
 146 your code, or at least tell you when it does.  For example:
 147
 148 =for example begin
 149
 150     # Take the square root of a number.
 151     sub my_sqrt {
 152         my($num) = shift;
 153
 154         # the square root of a negative number is imaginary.
 155         assert($num >= 0);
 156
 157         return sqrt $num;
 158     }
 159
 160 =for example end
 161
 162 =for example_testing
 163 is( my_sqrt(4),  2,            'my_sqrt example with good input' );
 164 ok( !eval{ my_sqrt(-1); 1 },   '  and pukes on bad' );
 165
 166 The assertion will warn you if a negative number was handed to your
 167 subroutine, a reality the routine has no intention of dealing with.
 168
 169 An assertion should also be used as something of a reality check, to
 170 make sure what your code just did really did happen:
 171
 172     open(FILE, $filename) || die $!;
 173     @stuff = <FILE>;
 174     @stuff = do_something(@stuff);
 175
 176     # I should have some stuff.
 177     assert(@stuff > 0);
 178
 179 The assertion makes sure you have some @stuff at the end.  Maybe the
 180 file was empty, maybe do_something() returned an empty list... either
 181 way, the assert() will give you a clue as to where the problem lies,
 182 rather than 50 lines down at when you wonder why your program isn't
 183 printing anything.
 184
 185 Since assertions are designed for debugging and will remove themelves
 186 from production code, your assertions should be carefully crafted so
 187 as to not have any side-effects, change any variables, or otherwise
 188 have any effect on your program.  Here is an example of a bad
 189 assertation:
 190
 191     assert($error = 1 if $king ne 'Henry');  # Bad!
 192
 193 It sets an error flag which may then be used somewhere else in your
 194 program. When you shut off your assertions with the $DEBUG flag,
 195 $error will no longer be set.
 196
 197 Here's another example of B<bad> use:
 198
 199     assert($next_pres ne 'Dan Quayle' or goto Canada);  # Bad!
 200
 201 This assertion has the side effect of moving to Canada should it fail.
 202 This is a very bad assertion since error handling should not be
 203 placed in an assertion, nor should it have side-effects.
 204
 205 In short, an assertion is an executable comment.  For instance, instead
 206 of writing this
 207
 208     # $life ends with a '!'
 209     $life = begin_life();
 210
 211 you'd replace the comment with an assertion which B<enforces> the comment.
 212
 213     $life = begin_life();
 214     assert( $life =~ /!$/ );
 215
 216 =for testing
 217 my $life = 'Whimper!';
 218 ok( eval { assert( $life =~ /!$/ ); 1 },   'life ends with a bang' );
 219
 220
 221 =head1 FUNCTIONS
 222
 223 =over 4
 224
 225 =item B<assert>
 226
 227     assert(EXPR) if DEBUG;
 228     assert(EXPR, $name) if DEBUG;
 229
 230 assert's functionality is effected by compile time value of the DEBUG
 231 constant, controlled by saying C<use Carp::Assert> or C<no
 232 Carp::Assert>.  In the former case, assert will function as below.
 233 Otherwise, the assert function will compile itself out of the program.
 234 See L<Debugging vs Production> for details.
 235
 236 =for testing
 237 {
 238   package Some::Other;
 239   no Carp::Assert;
 240   ::ok( eval { assert(0) if DEBUG; 1 } );
 241 }
 242
 243 Give assert an expression, assert will Carp::confess() if that
 244 expression is false, otherwise it does nothing.  (DO NOT use the
 245 return value of assert for anything, I mean it... really!).
 246
 247 =for testing
 248 ok( eval { assert(1); 1 } );
 249 ok( !eval { assert(0); 1 } );
 250
 251 The error from assert will look something like this:
 252
 253     Assertion failed!
 254             Carp::Assert::assert(0) called at prog line 23
 255             main::foo called at prog line 50
 256
 257 =for testing
 258 eval { assert(0) };
 259 like( $@, '/^Assertion failed!/',       'error format' );
 260 like( $@, '/Carp::Assert::assert\(0\) called at/',      '  with stack trace' );
 261
 262 Indicating that in the file "prog" an assert failed inside the
 263 function main::foo() on line 23 and that foo() was in turn called from
 264 line 50 in the same file.
 265
 266 If given a $name, assert() will incorporate this into your error message,
 267 giving users something of a better idea what's going on.
 268
 269     assert( Dogs->isa('People'), 'Dogs are people, too!' ) if DEBUG;
 270     # Result - "Assertion (Dogs are people, too!) failed!"
 271
 272 =for testing
 273 eval { assert( Dogs->isa('People'), 'Dogs are people, too!' ); };
 274 like( $@, '/^Assertion \(Dogs are people, too!\) failed!/', 'names' );
 275
 276 =cut
 277
 278 sub assert ($;$) {
 279     unless($_[0]) {
 280         require Carp;
 281         Carp::confess( _fail_msg($_[1]) );
 282     }
 283     return undef;
 284 }
 285
 286
 287 =item B<affirm>
 288
 289     affirm BLOCK if DEBUG;
 290     affirm BLOCK $name if DEBUG;
 291
 292 Very similar to assert(), but instead of taking just a simple
 293 expression it takes an entire block of code and evaluates it to make
 294 sure its true.  This can allow more complicated assertions than
 295 assert() can without letting the debugging code leak out into
 296 production and without having to smash together several
 297 statements into one.
 298
 299 =for example begin
 300
 301     affirm {
 302         my $customer = Customer->new($customerid);
 303         my @cards = $customer->credit_cards;
 304         grep { $_->is_active } @cards;
 305     } "Our customer has an active credit card";
 306
 307 =for example end
 308
 309 =for testing
 310 my $foo = 1;  my $bar = 2;
 311 eval { affirm { $foo == $bar } };
 312 like( $@, '/\$foo == \$bar/' );
 313
 314
 315 affirm() also has the nice side effect that if you forgot the C<if DEBUG>
 316 suffix its arguments will not be evaluated at all.  This can be nice
 317 if you stick affirm()s with expensive checks into hot loops and other
 318 time-sensitive parts of your program.
 319
 320 If the $name is left off and your Perl version is 5.6 or higher the
 321 affirm() diagnostics will include the code begin affirmed.
 322
 323 =cut
 324
 325 sub affirm (&;$) {
 326     unless( eval { &{$_[0]}; } ) {
 327         my $name = $_[1];
 328
 329         if( !defined $name ) {
 330             eval {
 331                 require B::Deparse;
 332                 $name = B::Deparse->new->coderef2text($_[0]);
 333             };
 334             $name =
 335               'code display non-functional on this version of Perl, sorry'
 336                 if $@;
 337         }
 338
 339         require Carp;
 340         Carp::confess( _fail_msg($name) );
 341     }
 342     return undef;
 343 }
 344
 345 =item B<should>
 346
 347 =item B<shouldnt>
 348
 349     should  ($this, $shouldbe)   if DEBUG;
 350     shouldnt($this, $shouldntbe) if DEBUG;
 351
 352 Similar to assert(), it is specially for simple "this should be that"
 353 or "this should be anything but that" style of assertions.
 354
 355 Due to Perl's lack of a good macro system, assert() can only report
 356 where something failed, but it can't report I<what> failed or I<how>.
 357 should() and shouldnt() can produce more informative error messages:
 358
 359     Assertion ('this' should be 'that'!) failed!
 360             Carp::Assert::should('this', 'that') called at moof line 29
 361             main::foo() called at moof line 58
 362
 363 So this:
 364
 365     should($this, $that) if DEBUG;
 366
 367 is similar to this:
 368
 369     assert($this eq $that) if DEBUG;
 370
 371 except for the better error message.
 372
 373 Currently, should() and shouldnt() can only do simple eq and ne tests
 374 (respectively).  Future versions may allow regexes.
 375
 376 =cut
 377
 378 sub should ($$) {
 379     unless($_[0] eq $_[1]) {
 380         require Carp;
 381         &Carp::confess( _fail_msg("'$_[0]' should be '$_[1]'!") );
 382     }
 383     return undef;
 384 }
 385
 386 sub shouldnt ($$) {
 387     unless($_[0] ne $_[1]) {
 388         require Carp;
 389         &Carp::confess( _fail_msg("'$_[0]' shouldn't be that!") );
 390     }
 391     return undef;
 392 }
 393
 394 # Sorry, I couldn't resist.
 395 sub shouldn't ($$) {     # emacs cperl-mode madness #' sub {
 396     my $env_ndebug = exists $ENV{PERL_NDEBUG} ? $ENV{PERL_NDEBUG}
 397                                               : $ENV{'NDEBUG'};
 398     if( $env_ndebug ) {
 399         return undef;
 400     }
 401     else {
 402         shouldnt($_[0], $_[1]);
 403     }
 404 }
 405
 406 =back
 407
 408 =head1 Debugging vs Production
 409
 410 Because assertions are extra code and because it is sometimes necessary to
 411 place them in 'hot' portions of your code where speed is paramount,
 412 Carp::Assert provides the option to remove its assert() calls from your
 413 program.
 414
 415 So, we provide a way to force Perl to inline the switched off assert()
 416 routine, thereby removing almost all performance impact on your production
 417 code.
 418
 419     no Carp::Assert;  # assertions are off.
 420     assert(1==1) if DEBUG;
 421
 422 DEBUG is a constant set to 0.  Adding the 'if DEBUG' condition on your
 423 assert() call gives perl the cue to go ahead and remove assert() call from
 424 your program entirely, since the if conditional will always be false.
 425
 426     # With C<no Carp::Assert> the assert() has no impact.
 427     for (1..100) {
 428         assert( do_some_really_time_consuming_check ) if DEBUG;
 429     }
 430
 431 If C<if DEBUG> gets too annoying, you can always use affirm().
 432
 433     # Once again, affirm() has (almost) no impact with C<no Carp::Assert>
 434     for (1..100) {
 435         affirm { do_some_really_time_consuming_check };
 436     }
 437
 438 Another way to switch off all asserts, system wide, is to define the
 439 NDEBUG or the PERL_NDEBUG environment variable.
 440
 441 You can safely leave out the "if DEBUG" part, but then your assert()
 442 function will always execute (and its arguments evaluated and time
 443 spent).  To get around this, use affirm().  You still have the
 444 overhead of calling a function but at least its arguments will not be
 445 evaluated.
 446
 447
 448 =head1 Differences from ANSI C
 449
 450 assert() is intended to act like the function from ANSI C fame.
 451 Unfortunately, due to Perl's lack of macros or strong inlining, it's not
 452 nearly as unobtrusive.
 453
 454 Well, the obvious one is the "if DEBUG" part.  This is cleanest way I could
 455 think of to cause each assert() call and its arguments to be removed from
 456 the program at compile-time, like the ANSI C macro does.
 457
 458 Also, this version of assert does not report the statement which
 459 failed, just the line number and call frame via Carp::confess.  You
 460 can't do C<assert('$a == $b')> because $a and $b will probably be
 461 lexical, and thus unavailable to assert().  But with Perl, unlike C,
 462 you always have the source to look through, so the need isn't as
 463 great.
 464
 465
 466 =head1 EFFICIENCY
 467
 468 With C<no Carp::Assert> (or NDEBUG) and using the C<if DEBUG> suffixes
 469 on all your assertions, Carp::Assert has almost no impact on your
 470 production code.  I say almost because it does still add some load-time
 471 to your code (I've tried to reduce this as much as possible).
 472
 473 If you forget the C<if DEBUG> on an C<assert()>, C<should()> or
 474 C<shouldnt()>, its arguments are still evaluated and thus will impact
 475 your code.  You'll also have the extra overhead of calling a
 476 subroutine (even if that subroutine does nothing).
 477
 478 Forgetting the C<if DEBUG> on an C<affirm()> is not so bad.  While you
 479 still have the overhead of calling a subroutine (one that does
 480 nothing) it will B<not> evaluate its code block and that can save
 481 alot.
 482
 483 Try to remember the B<if DEBUG>.
 484
 485
 486 =head1 ENVIRONMENT
 487
 488 =over 4
 489
 490 =item NDEBUG
 491
 492 Defining NDEBUG switches off all assertions.  It has the same effect
 493 as changing "use Carp::Assert" to "no Carp::Assert" but it effects all
 494 code.
 495
 496 =item PERL_NDEBUG
 497
 498 Same as NDEBUG and will override it.  Its provided to give you
 499 something which won't conflict with any C programs you might be
 500 working on at the same time.
 501
 502 =back
 503
 504
 505 =head1 BUGS, CAVETS and other MUSINGS
 506
 507 =head2 Conflicts with C<POSIX.pm>
 508
 509 The C<POSIX> module exports an C<assert> routine which will conflict with C<Carp::Assert> if both are used in the same namespace.  If you are using both together, prevent C<POSIX> from exporting like so:
 510
 511     use POSIX ();
 512     use Carp::Assert;
 513
 514 Since C<POSIX> exports way too much, you should be using it like that anyway.
 515
 516 =head2 C<affirm> and C<$^S>
 517
 518 affirm() mucks with the expression's caller and it is run in an eval
 519 so anything that checks $^S will be wrong.
 520
 521 =head2 C<shouldn't>
 522
 523 Yes, there is a C<shouldn't> routine.  It mostly works, but you B<must>
 524 put the C<if DEBUG> after it.
 525
 526 =head2 missing C<if DEBUG>
 527
 528 It would be nice if we could warn about missing C<if DEBUG>.
 529
 530
 531 =head1 SEE ALSO
 532
 533 L<assertions> is a new module available in 5.9.0 which provides assertions which can be enabled/disabled at compile time for real, no C<if DEBUG> necessary.
 534
 535
 536 =head1 COPYRIGHT
 537
 538 Copyright 2001-2007 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 539
 540 This program is free software; you can redistribute it and/or
 541 modify it under the same terms as Perl itself.
 542
 543 See F<http://dev.perl.org/licenses/>
 544
 545
 546 =head1 AUTHOR
 547
 548 Michael G Schwern <schwern@pobox.com>
 549
 550 =cut
 551
 552 return q|You don't just EAT the largest turnip in the world!|;