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

   1 package Carp::Assert::More;
   2
   3 use warnings;
   4 use strict;
   5 use Exporter;
   6 use Carp::Assert;
   7
   8 use vars qw( $VERSION @ISA @EXPORT );
   9
  10 *_fail_msg = *Carp::Assert::_fail_msg;
  11
  12
  13 =head1 NAME
  14
  15 Carp::Assert::More - convenience wrappers around Carp::Assert
  16
  17 =head1 VERSION
  18
  19 Version 1.12
  20
  21 =cut
  22
  23 BEGIN {
  24     $VERSION = '1.12';
  25     @ISA = qw(Exporter);
  26     @EXPORT = qw(
  27         assert_defined
  28         assert_exists
  29         assert_fail
  30         assert_hashref
  31         assert_in
  32         assert_integer
  33         assert_is
  34         assert_isa
  35         assert_isnt
  36         assert_lacks
  37         assert_like
  38         assert_listref
  39         assert_negative
  40         assert_negative_integer
  41         assert_nonblank
  42         assert_nonempty
  43         assert_nonnegative
  44         assert_nonnegative_integer
  45         assert_nonref
  46         assert_nonzero
  47         assert_nonzero_integer
  48         assert_positive
  49         assert_positive_integer
  50     );
  51 }
  52
  53 =head1 SYNOPSIS
  54
  55     use Carp::Assert::More;
  56
  57     my $obj = My::Object;
  58     assert_isa( $obj, 'My::Object', 'Got back a correct object' );
  59
  60 =head1 DESCRIPTION
  61
  62 Carp::Assert::More is a set of wrappers around the L<Carp::Assert> functions
  63 to make the habit of writing assertions even easier.
  64
  65 Everything in here is effectively syntactic sugar.  There's no technical
  66 reason to use
  67
  68     assert_isa( $foo, 'HTML::Lint' );
  69
  70 instead of
  71
  72     assert( defined $foo );
  73     assert( ref($foo) eq 'HTML::Lint' );
  74
  75 other than readability and simplicity of the code.
  76
  77 My intent here is to make common assertions easy so that we as programmers
  78 have no excuse to not use them.
  79
  80 =head1 CAVEATS
  81
  82 I haven't specifically done anything to make Carp::Assert::More be
  83 backwards compatible with anything besides Perl 5.6.1, much less back
  84 to 5.004.  Perhaps someone with better testing resources in that area
  85 can help me out here.
  86
  87 =head1 SIMPLE ASSERTIONS
  88
  89 =head2 assert_is( $string, $match [,$name] )
  90
  91 Asserts that I<$string> matches I<$match>.
  92
  93 =cut
  94
  95 sub assert_is($$;$) {
  96     my $string = shift;
  97     my $match = shift;
  98     my $name = shift;
  99
 100     # undef only matches undef
 101     return if !defined($string) && !defined($match);
 102     assert_defined( $string, $name );
 103     assert_defined( $match, $name );
 104
 105     return if $string eq $match;
 106
 107     require Carp;
 108     &Carp::confess( _fail_msg($name) );
 109 }
 110
 111 =head2 assert_isnt( $string, $unmatch [,$name] )
 112
 113 Asserts that I<$string> does NOT match I<$unmatch>.
 114
 115 =cut
 116
 117 sub assert_isnt($$;$) {
 118     my $string = shift;
 119     my $unmatch = shift;
 120     my $name = shift;
 121
 122     # undef only matches undef
 123     return if defined($string) xor defined($unmatch);
 124
 125     return if defined($string) && defined($unmatch) && ($string ne $unmatch);
 126
 127     require Carp;
 128     &Carp::confess( _fail_msg($name) );
 129 }
 130
 131 =head2 assert_like( $string, qr/regex/ [,$name] )
 132
 133 Asserts that I<$string> matches I<qr/regex/>.
 134
 135 =cut
 136
 137 sub assert_like($$;$) {
 138     my $string = shift;
 139     my $regex = shift;
 140     my $name = shift;
 141
 142     assert_nonref( $string, $name );
 143     assert_isa( $regex, 'Regexp', $name );
 144     return if $string =~ $regex;
 145
 146     require Carp;
 147     &Carp::confess( _fail_msg($name) );
 148 }
 149
 150 =head2 assert_defined( $this [, $name] )
 151
 152 Asserts that I<$this> is defined.
 153
 154 =cut
 155
 156 sub assert_defined($;$) {
 157     return if defined( $_[0] );
 158
 159     require Carp;
 160     &Carp::confess( _fail_msg($_[1]) );
 161 }
 162
 163 =head2 assert_nonblank( $this [, $name] )
 164
 165 Asserts that I<$this> is not blank and not a reference.
 166
 167 =cut
 168
 169 sub assert_nonblank($;$) {
 170     my $this = shift;
 171     my $name = shift;
 172
 173     assert_nonref( $this, $name );
 174     return if $this ne "";
 175
 176     require Carp;
 177     &Carp::confess( _fail_msg($_[1]) );
 178 }
 179
 180 =head1 NUMERIC ASSERTIONS
 181
 182 =head2 assert_integer( $this [, $name ] )
 183
 184 Asserts that I<$this> is an integer, which may be zero or negative.
 185
 186     assert_integer( 0 );    # pass
 187     assert_integer( -14 );  # pass
 188     assert_integer( '14.' );  # FAIL
 189
 190 =cut
 191
 192 sub assert_integer($;$) {
 193     my $this = shift;
 194     my $name = shift;
 195
 196     assert_nonref( $this, $name );
 197     return if $this =~ /^-?\d+$/;
 198
 199     require Carp;
 200     &Carp::confess( _fail_msg($name) );
 201 }
 202
 203 =head2 assert_nonzero( $this [, $name ] )
 204
 205 Asserts that the numeric value of I<$this> is not zero.
 206
 207     assert_nonzero( 0 );    # FAIL
 208     assert_nonzero( -14 );  # pass
 209     assert_nonzero( '14.' );  # pass
 210
 211 Asserts that the numeric value of I<$this> is not zero.
 212
 213 =cut
 214
 215 sub assert_nonzero($;$) {
 216     my $this = shift;
 217     my $name = shift;
 218
 219     no warnings;
 220     return if $this+0 != 0;
 221
 222     require Carp;
 223     &Carp::confess( _fail_msg($name) );
 224 }
 225
 226 =head2 assert_positive( $this [, $name ] )
 227
 228 Asserts that the numeric value of I<$this> is greater than zero.
 229
 230     assert_positive( 0 );    # FAIL
 231     assert_positive( -14 );  # FAIL
 232     assert_positive( '14.' );  # pass
 233
 234 =cut
 235
 236 sub assert_positive($;$) {
 237     my $this = shift;
 238     my $name = shift;
 239
 240     no warnings;
 241     return if $this+0 > 0;
 242
 243     require Carp;
 244     &Carp::confess( _fail_msg($name) );
 245 }
 246
 247 =head2 assert_nonnegative( $this [, $name ] )
 248
 249 Asserts that the numeric value of I<$this> is greater than or equal
 250 to zero.  Since non-numeric strings evaluate to zero, this means that
 251 any non-numeric string will pass.
 252
 253     assert_nonnegative( 0 );    # pass
 254     assert_nonnegative( -14 );  # FAIL
 255     assert_nonnegative( '14.' );  # pass
 256     assert_nonnegative( 'dog' );  # pass
 257
 258 =cut
 259
 260 sub assert_nonnegative($;$) {
 261     my $this = shift;
 262     my $name = shift;
 263
 264     no warnings;
 265     return if $this+0 >= 0;
 266
 267     require Carp;
 268     &Carp::confess( _fail_msg($name) );
 269 }
 270
 271 =head2 assert_negative( $this [, $name ] )
 272
 273 Asserts that the numeric value of I<$this> is less than zero.
 274
 275     assert_negative( 0 );       # FAIL
 276     assert_negative( -14 );     # pass
 277     assert_negative( '14.' );   # FAIL
 278
 279 =cut
 280
 281 sub assert_negative($;$) {
 282     my $this = shift;
 283     my $name = shift;
 284
 285     no warnings;
 286     return if $this+0 < 0;
 287
 288     require Carp;
 289     &Carp::confess( _fail_msg($name) );
 290 }
 291
 292 =head2 assert_nonzero_integer( $this [, $name ] )
 293
 294 Asserts that the numeric value of I<$this> is not zero, and that I<$this>
 295 is an integer.
 296
 297     assert_nonzero_integer( 0 );    # FAIL
 298     assert_nonzero_integer( -14 );  # pass
 299     assert_nonzero_integer( '14.' );  # FAIL
 300
 301 =cut
 302
 303 sub assert_nonzero_integer($;$) {
 304     my $this = shift;
 305     my $name = shift;
 306
 307     assert_nonzero( $this, $name );
 308     assert_integer( $this, $name );
 309 }
 310
 311 =head2 assert_positive_integer( $this [, $name ] )
 312
 313 Asserts that the numeric value of I<$this> is greater than zero, and
 314 that I<$this> is an integer.
 315
 316     assert_positive_integer( 0 );     # FAIL
 317     assert_positive_integer( -14 );   # FAIL
 318     assert_positive_integer( '14.' ); # FAIL
 319     assert_positive_integer( '14' );  # pass
 320
 321 =cut
 322
 323 sub assert_positive_integer($;$) {
 324     my $this = shift;
 325     my $name = shift;
 326
 327     assert_positive( $this, $name );
 328     assert_integer( $this, $name );
 329 }
 330
 331 =head2 assert_nonnegative_integer( $this [, $name ] )
 332
 333 Asserts that the numeric value of I<$this> is not less than zero, and
 334 that I<$this> is an integer.
 335
 336     assert_nonnegative_integer( 0 );    # pass
 337     assert_nonnegative_integer( -14 );  # pass
 338     assert_nonnegative_integer( '14.' );  # FAIL
 339
 340 =cut
 341
 342 sub assert_nonnegative_integer($;$) {
 343     my $this = shift;
 344     my $name = shift;
 345
 346     assert_nonnegative( $this, $name );
 347     assert_integer( $this, $name );
 348 }
 349
 350 =head2 assert_negative_integer( $this [, $name ] )
 351
 352 Asserts that the numeric value of I<$this> is less than zero, and that
 353 I<$this> is an integer.
 354
 355     assert_negative_integer( 0 );    # FAIL
 356     assert_negative_integer( -14 );  # pass
 357     assert_negative_integer( '14.' );  # FAIL
 358
 359 =cut
 360
 361 sub assert_negative_integer($;$) {
 362     my $this = shift;
 363     my $name = shift;
 364
 365     assert_negative( $this, $name );
 366     assert_integer( $this, $name );
 367 }
 368
 369 =head1 REFERENCE ASSERTIONS
 370
 371 =head2 assert_isa( $this, $type [, $name ] )
 372
 373 Asserts that I<$this> is an object of type I<$type>.
 374
 375 =cut
 376
 377 sub assert_isa($$;$) {
 378     my $this = shift;
 379     my $type = shift;
 380     my $name = shift;
 381
 382     assert_defined( $this, $name );
 383
 384     # The assertion is true if
 385     # 1) For objects, $this is of class $type or of a subclass of $type
 386     # 2) For non-objects, $this is a reference to a HASH, SCALAR, ARRAY, etc.
 387
 388     require Scalar::Util;
 389
 390     return if Scalar::Util::blessed( $this ) && $this->isa( $type );
 391     return if ref($this) eq $type;
 392
 393     require Carp;
 394     &Carp::confess( _fail_msg($name) );
 395 }
 396
 397
 398 =head2 assert_nonempty( $this [, $name ] )
 399
 400 I<$this> must be a ref to either a hash or an array.  Asserts that that
 401 collection contains at least 1 element.  Will assert (with its own message,
 402 not I<$name>) unless given a hash or array ref.   It is OK if I<$this> has
 403 been blessed into objecthood, but the semantics of checking an object to see
 404 if it has keys (for a hashref) or returns >0 in scalar context (for an array
 405 ref) may not be what you want.
 406
 407     assert_nonempty( 0 );       # FAIL
 408     assert_nonempty( 'foo' );   # FAIL
 409     assert_nonempty( undef );   # FAIL
 410     assert_nonempty( {} );      # FAIL
 411     assert_nonempty( [] );      # FAIL
 412     assert_nonempty( {foo=>1} );# pass
 413     assert_nonempty( [1,2,3] ); # pass
 414
 415 =cut
 416
 417 sub assert_nonempty($;$) {
 418     my $ref = shift;
 419     my $name = shift;
 420
 421     my $type = ref $ref;
 422     if ( $type eq "HASH" ) {
 423         assert_positive( scalar keys %$ref, $name );
 424     }
 425     elsif ( $type eq "ARRAY" ) {
 426         assert_positive( scalar @$ref, $name );
 427     }
 428     else {
 429         assert_fail( "Not an array or hash reference" );
 430     }
 431 }
 432
 433 =head2 assert_nonref( $this [, $name ] )
 434
 435 Asserts that I<$this> is not undef and not a reference.
 436
 437 =cut
 438
 439 sub assert_nonref($;$) {
 440     my $this = shift;
 441     my $name = shift;
 442
 443     assert_defined( $this, $name );
 444     return unless ref( $this );
 445
 446     require Carp;
 447     &Carp::confess( _fail_msg($name) );
 448 }
 449
 450 =head2 assert_hashref( $ref [,$name] )
 451
 452 Asserts that I<$ref> is defined, and is a reference to a (possibly empty) hash.
 453
 454 B<NB:> This method returns I<false> for objects, even those whose underlying
 455 data is a hashref. This is as it should be, under the assumptions that:
 456
 457 =over 4
 458
 459 =item (a)
 460
 461 you shouldn't rely on the underlying data structure of a particular class, and
 462
 463 =item (b)
 464
 465 you should use C<assert_isa> instead.
 466
 467 =back
 468
 469 =cut
 470
 471 sub assert_hashref($;$) {
 472     my $ref = shift;
 473     my $name = shift;
 474
 475     return assert_isa( $ref, 'HASH', $name );
 476 }
 477
 478 =head2 assert_listref( $ref [,$name] )
 479
 480 Asserts that I<$ref> is defined, and is a reference to a (possibly empty) list.
 481
 482 B<NB:> The same caveat about objects whose underlying structure is a
 483 hash (see C<assert_hashref>) applies here; this method returns false
 484 even for objects whose underlying structure is an array.
 485
 486 =cut
 487
 488 sub assert_listref($;$) {
 489     my $ref = shift;
 490     my $name = shift;
 491
 492     return assert_isa( $ref, 'ARRAY', $name );
 493 }
 494
 495 =head1 SET AND HASH MEMBERSHIP
 496
 497 =head2 assert_in( $string, \@inlist [,$name] );
 498
 499 Asserts that I<$string> is defined and matches one of the elements
 500 of I<\@inlist>.
 501
 502 I<\@inlist> must be an array reference of defined strings.
 503
 504 =cut
 505
 506 sub assert_in($$;$) {
 507     my $string = shift;
 508     my $arrayref = shift;
 509     my $name = shift;
 510
 511     assert_nonref( $string, $name );
 512     assert_isa( $arrayref, 'ARRAY', $name );
 513     foreach my $element (@{$arrayref}) {
 514         assert_nonref( $element, $name );
 515         return if $string eq $element;
 516     }
 517     require Carp;
 518     &Carp::confess( _fail_msg($name) );
 519 }
 520
 521 =head2 assert_exists( \%hash, $key [,$name] )
 522
 523 =head2 assert_exists( \%hash, \@keylist [,$name] )
 524
 525 Asserts that I<%hash> is indeed a hash, and that I<$key> exists in
 526 I<%hash>, or that all of the keys in I<@keylist> exist in I<%hash>.
 527
 528     assert_exists( \%custinfo, 'name', 'Customer has a name field' );
 529
 530     assert_exists( \%custinfo, [qw( name addr phone )],
 531                             'Customer has name, address and phone' );
 532
 533 =cut
 534
 535 sub assert_exists($$;$) {
 536     my $hash = shift;
 537     my $key = shift;
 538     my $name = shift;
 539
 540     assert_isa( $hash, 'HASH', $name );
 541     my @list = ref($key) ? @$key : ($key);
 542
 543     for ( @list ) {
 544         if ( !exists( $hash->{$_} ) ) {
 545             require Carp;
 546             &Carp::confess( _fail_msg($name) );
 547         }
 548     }
 549 }
 550
 551 =head2 assert_lacks( \%hash, $key [,$name] )
 552
 553 =head2 assert_lacks( \%hash, \@keylist [,$name] )
 554
 555 Asserts that I<%hash> is indeed a hash, and that I<$key> does NOT exist
 556 in I<%hash>, or that none of the keys in I<@keylist> exist in I<%hash>.
 557
 558     assert_lacks( \%users, 'root', 'Root is not in the user table' );
 559
 560     assert_lacks( \%users, [qw( root admin nobody )], 'No bad usernames found' );
 561
 562 =cut
 563
 564 sub assert_lacks($$;$) {
 565     my $hash = shift;
 566     my $key = shift;
 567     my $name = shift;
 568
 569     assert_isa( $hash, 'HASH', $name );
 570     my @list = ref($key) ? @$key : ($key);
 571
 572     for ( @list ) {
 573         if ( exists( $hash->{$_} ) ) {
 574             require Carp;
 575             &Carp::confess( _fail_msg($name) );
 576         }
 577     }
 578 }
 579
 580 =head1 UTILITY ASSERTIONS
 581
 582 =head2 assert_fail( [$name] )
 583
 584 Assertion that always fails.  C<assert_fail($msg)> is exactly the same
 585 as calling C<assert(0,$msg)>, but it eliminates that case where you
 586 accidentally use C<assert($msg)>, which of course never fires.
 587
 588 =cut
 589
 590 sub assert_fail(;$) {
 591     require Carp;
 592     &Carp::confess( _fail_msg($_[0]) );
 593 }
 594
 595
 596 =head1 COPYRIGHT
 597
 598 Copyright (c) 2005 Andy Lester. All rights reserved. This program is
 599 free software; you can redistribute it and/or modify it under the same
 600 terms as Perl itself.
 601
 602 =head1 ACKNOWLEDGEMENTS
 603
 604 Thanks to
 605 Bob Diss,
 606 Pete Krawczyk,
 607 David Storrs,
 608 Dan Friedman,
 609 and Allard Hoeve
 610 for code and fixes.
 611
 612 =cut
 613
 614 "I stood on the porch in a tie."