Source/t/lib/Test/File.pm

   1 # $Id: File.pm,v 1.1 2007/01/16 23:01:44 gumpu Exp $
   2 package Test::File;
   3 use strict;
   4
   5 use base qw(Exporter);
   6 use vars qw(@EXPORT $VERSION);
   7
   8 use File::Spec;
   9 use Test::Builder;
  10
  11 @EXPORT = qw(
  12         file_exists_ok file_not_exists_ok
  13         file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok
  14         file_min_size_ok file_readable_ok file_not_readable_ok file_writeable_ok
  15         file_not_writeable_ok file_executable_ok file_not_executable_ok
  16         file_mode_is file_mode_isnt
  17         file_is_symlink_ok
  18         symlink_target_exists_ok
  19         symlink_target_dangles_ok
  20         link_count_is_ok link_count_gt_ok link_count_lt_ok
  21         owner_is owner_isnt
  22         group_is group_isnt
  23         );
  24
  25 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  26
  27 my $Test = Test::Builder->new();
  28
  29 =head1 NAME
  30
  31 Test::File -- test file attributes
  32
  33 =head1 SYNOPSIS
  34
  35 use Test::File;
  36
  37 =head1 DESCRIPTION
  38
  39 This modules provides a collection of test utilities for file
  40 attributes.
  41
  42 Some file attributes depend on the owner of the process testing the
  43 file in the same way the file test operators do.  For instance, root
  44 (or super-user or Administrator) may always be able to read files no
  45 matter the permissions.
  46
  47 Some attributes don't make sense outside of Unix, either, so some
  48 tests automatically skip if they think they won't work on the
  49 platform.  If you have a way to make these functions work on Windows,
  50 for instance, please send me a patch. :)
  51
  52 =head2 Functions
  53
  54 =cut
  55
  56 sub _normalize
  57         {
  58         my $file = shift;
  59         return unless defined $file;
  60
  61         return $file =~ m|/|
  62                 ? File::Spec->catfile( split m|/|, $file )
  63                 : $file;
  64         }
  65
  66 sub _win32
  67         {
  68         return 0 if $^O eq 'darwin';
  69         return $^O =~ m/Win/;
  70         }
  71
  72 sub _no_symlinks_here { ! eval { symlink("",""); 1 } }
  73
  74 # owner_is and owner_isn't should skip on OS where the question makes no
  75 # sence.  I really don't know a good way to test for that, so I'm going
  76 # to skip on the two OS's that I KNOW aren't multi-user.  I'd love to add
  77 # more if anyone knows of any
  78 #   Note:  I don't have a dos or mac os < 10 machine to test this on
  79 sub _obviously_non_multi_user
  80         {
  81         ($^O eq 'dos')   ?
  82                 return 1
  83                         :
  84         ($^O eq 'MacOS') ?
  85                 return 1
  86                         :
  87                 return;
  88
  89         eval { my $holder = getpwuid(0) };
  90         return 1 if $@;
  91
  92         eval { my $holder = getgrgid(0) };
  93         return 1 if $@;
  94
  95         return 0;
  96         }
  97
  98 =over 4
  99
 100 =item file_exists_ok( FILENAME [, NAME ] )
 101
 102 Ok if the file exists, and not ok otherwise.
 103
 104 =cut
 105
 106 sub file_exists_ok($;$)
 107         {
 108         my $filename = _normalize( shift );
 109         my $name     = shift || "$filename exists";
 110
 111         my $ok = -e $filename;
 112
 113         if( $ok )
 114                 {
 115                 $Test->ok(1, $name);
 116                 }
 117         else
 118                 {
 119                 $Test->diag("File [$filename] does not exist");
 120                 $Test->ok(0, $name);
 121                 }
 122         }
 123
 124 =item file_not_exists_ok( FILENAME [, NAME ] )
 125
 126 Ok if the file does not exist, and not okay if it does exist.
 127
 128 =cut
 129
 130 sub file_not_exists_ok($;$)
 131         {
 132         my $filename = _normalize( shift );
 133         my $name     = shift || "$filename does not exist";
 134
 135         my $ok = not -e $filename;
 136
 137         if( $ok )
 138                 {
 139                 $Test->ok(1, $name);
 140                 }
 141         else
 142                 {
 143                 $Test->diag("File [$filename] exists");
 144                 $Test->ok(0, $name);
 145                 }
 146         }
 147
 148 =item file_empty_ok( FILENAME [, NAME ] )
 149
 150 Ok if the file exists and has empty size, not ok if the
 151 file does not exist or exists with non-zero size.
 152
 153 =cut
 154
 155 sub file_empty_ok($;$)
 156         {
 157         my $filename = _normalize( shift );
 158         my $name     = shift || "$filename is empty";
 159
 160         my $ok = -z $filename;
 161
 162         if( $ok )
 163                 {
 164                 $Test->ok(1, $name);
 165                 }
 166         else
 167                 {
 168                 if( -e $filename )
 169                         {
 170                         my $size = -s $filename;
 171                         $Test->diag( "File exists with non-zero size [$size] b");
 172                         }
 173                 else
 174                         {
 175                         $Test->diag( 'File does not exist');
 176                         }
 177
 178                 $Test->ok(0, $name);
 179                 }
 180         }
 181
 182 =item file_not_empty_ok( FILENAME [, NAME ] )
 183
 184 Ok if the file exists and has non-zero size, not ok if the
 185 file does not exist or exists with zero size.
 186
 187 =cut
 188
 189 sub file_not_empty_ok($;$)
 190         {
 191         my $filename = _normalize( shift );
 192         my $name     = shift || "$filename is not empty";
 193
 194         my $ok = not -z $filename;
 195
 196         if( $ok )
 197                 {
 198                 $Test->ok(1, $name);
 199                 }
 200         else
 201                 {
 202                 if( -e $filename and -z $filename )
 203                         {
 204                         $Test->diag( "File [$filename] exists with zero size" );
 205                         }
 206                 else
 207                         {
 208                         $Test->diag( "File [$filename] does not exist" );
 209                         }
 210
 211                 $Test->ok(0, $name);
 212                 }
 213         }
 214
 215 =item file_size_ok( FILENAME, SIZE [, NAME ]  )
 216
 217 Ok if the file exists and has SIZE size in bytes (exactly), not ok if
 218 the file does not exist or exists with size other than SIZE.
 219
 220 =cut
 221
 222 sub file_size_ok($$;$)
 223         {
 224         my $filename = _normalize( shift );
 225         my $expected = int shift;
 226         my $name     = shift || "$filename has right size";
 227
 228         my $ok = ( -s $filename ) == $expected;
 229
 230         if( $ok )
 231                 {
 232                 $Test->ok(1, $name);
 233                 }
 234         else
 235                 {
 236                 unless( -e $filename )
 237                         {
 238                         $Test->diag( "File [$filename] does not exist" );
 239                         }
 240                 else
 241                         {
 242                         my $actual = -s $filename;
 243                         $Test->diag(
 244                                 "File [$filename] has actual size [$actual] not [$expected]" );
 245                         }
 246
 247                 $Test->ok(0, $name);
 248                 }
 249         }
 250
 251 =item file_max_size_ok( FILENAME, MAX [, NAME ] )
 252
 253 Ok if the file exists and has size less than or equal to MAX bytes, not
 254 ok if the file does not exist or exists with size greater than MAX
 255 bytes.
 256
 257 =cut
 258
 259 sub file_max_size_ok($$;$)
 260         {
 261         my $filename = _normalize( shift );
 262         my $max      = int shift;
 263         my $name     = shift || "$filename is under $max bytes";
 264
 265         my $ok = ( -s $filename ) <= $max;
 266
 267         if( $ok )
 268                 {
 269                 $Test->ok(1, $name);
 270                 }
 271         else
 272                 {
 273                 unless( -e $filename )
 274                         {
 275                         $Test->diag( "File [$filename] does not exist" );
 276                         }
 277                 else
 278                         {
 279                         my $actual = -s $filename;
 280                         $Test->diag(
 281                                 "File [$filename] has actual size [$actual] " .
 282                                 "greater than [$max]"
 283                                 );
 284                         }
 285
 286                 $Test->ok(0, $name);
 287                 }
 288         }
 289
 290 =item file_min_size_ok( FILENAME, MIN [, NAME ] )
 291
 292 Ok if the file exists and has size greater than or equal to MIN bytes,
 293 not ok if the file does not exist or exists with size less than MIN
 294 bytes.
 295
 296 =cut
 297
 298 sub file_min_size_ok($$;$)
 299         {
 300         my $filename = _normalize( shift );
 301         my $min      = int shift;
 302         my $name     = shift || "$filename is over $min bytes";
 303
 304         my $ok = ( -s $filename ) >= $min;
 305
 306         if( $ok )
 307                 {
 308                 $Test->ok(1, $name);
 309                 }
 310         else
 311                 {
 312                 unless( -e $filename )
 313                         {
 314                         $Test->diag( "File [$filename] does not exist" );
 315                         }
 316                 else
 317                         {
 318                         my $actual = -s $filename;
 319                         $Test->diag(
 320                                 "File [$filename] has actual size ".
 321                                 "[$actual] less than [$min]"
 322                                 );
 323                         }
 324
 325                 $Test->ok(0, $name);
 326                 }
 327         }
 328
 329 =item file_readable_ok( FILENAME [, NAME ] )
 330
 331 Ok if the file exists and is readable, not ok
 332 if the file does not exist or is not readable.
 333
 334 =cut
 335
 336 sub file_readable_ok($;$)
 337         {
 338         my $filename = _normalize( shift );
 339         my $name     = shift || "$filename is readable";
 340
 341         my $ok = -r $filename;
 342
 343         if( $ok )
 344                 {
 345                 $Test->ok(1, $name);
 346                 }
 347         else
 348                 {
 349                 $Test->diag( "File [$filename] is not readable" );
 350                 $Test->ok(0, $name);
 351                 }
 352         }
 353
 354 =item file_not_readable_ok( FILENAME [, NAME ] )
 355
 356 Ok if the file exists and is not readable, not ok
 357 if the file does not exist or is readable.
 358
 359 =cut
 360
 361 sub file_not_readable_ok($;$)
 362         {
 363         my $filename = _normalize( shift );
 364         my $name     = shift || "$filename is not readable";
 365
 366         my $ok = not -r $filename;
 367
 368         if( $ok )
 369                 {
 370                 $Test->ok(1, $name);
 371                 }
 372         else
 373                 {
 374                 $Test->diag( "File [$filename] is readable" );
 375                 $Test->ok(0, $name);
 376                 }
 377         }
 378
 379 =item file_writeable_ok( FILENAME [, NAME ] )
 380
 381 Ok if the file exists and is writeable, not ok
 382 if the file does not exist or is not writeable.
 383
 384 =cut
 385
 386 sub file_writeable_ok($;$)
 387         {
 388         my $filename = _normalize( shift );
 389         my $name     = shift || "$filename is writeable";
 390
 391         my $ok = -w $filename;
 392
 393         if( $ok )
 394                 {
 395                 $Test->ok(1, $name);
 396                 }
 397         else
 398                 {
 399                 $Test->diag( "File [$filename] is not writeable" );
 400                 $Test->ok(0, $name);
 401                 }
 402         }
 403
 404 =item file_not_writeable_ok( FILENAME [, NAME ] )
 405
 406 Ok if the file exists and is not writeable, not ok
 407 if the file does not exist or is writeable.
 408
 409 =cut
 410
 411 sub file_not_writeable_ok($;$)
 412         {
 413         my $filename = _normalize( shift );
 414         my $name     = shift || "$filename is not writeable";
 415
 416         my $ok = not -w $filename;
 417
 418         if( $ok )
 419                 {
 420                 $Test->ok(1, $name);
 421                 }
 422         else
 423                 {
 424                 $Test->diag("File [$filename] is writeable");
 425                 $Test->ok(0, $name);
 426                 }
 427         }
 428
 429 =item file_executable_ok( FILENAME [, NAME ] )
 430
 431 Ok if the file exists and is executable, not ok
 432 if the file does not exist or is not executable.
 433
 434 This test automatically skips if it thinks it is on a
 435 Windows platform.
 436
 437 =cut
 438
 439 sub file_executable_ok($;$)
 440         {
 441     if( _win32() )
 442                 {
 443                 $Test->skip( "file_executable_ok doesn't work on Windows" );
 444                 return;
 445                 }
 446
 447         my $filename = _normalize( shift );
 448         my $name     = shift || "$filename is executable";
 449
 450         my $ok = -x $filename;
 451
 452         if( $ok )
 453                 {
 454                 $Test->ok(1, $name);
 455                 }
 456         else
 457                 {
 458                 $Test->diag("File [$filename] is not executable");
 459                 $Test->ok(0, $name);
 460                 }
 461         }
 462
 463 =item file_not_executable_ok( FILENAME [, NAME ] )
 464
 465 Ok if the file exists and is not executable, not ok
 466 if the file does not exist or is executable.
 467
 468 This test automatically skips if it thinks it is on a
 469 Windows platform.
 470
 471 =cut
 472
 473 sub file_not_executable_ok($;$)
 474         {
 475         if( _win32() )
 476                 {
 477                 $Test->skip( "file_not_executable_ok doesn't work on Windows" );
 478                 return;
 479                 }
 480
 481         my $filename = _normalize( shift );
 482         my $name     = shift || "$filename is not executable";
 483
 484         my $ok = not -x $filename;
 485
 486         if( $ok )
 487                 {
 488                 $Test->ok(1, $name);
 489                 }
 490         else
 491                 {
 492                 $Test->diag("File [$filename] is executable");
 493                 $Test->ok(0, $name);
 494                 }
 495         }
 496
 497 =item file_mode_is( FILENAME, MODE [, NAME ] )
 498
 499 Ok if the file exists and the mode matches, not ok
 500 if the file does not exist or the mode does not match.
 501
 502 This test automatically skips if it thinks it is on a
 503 Windows platform.
 504
 505 Contributed by Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >>
 506
 507 =cut
 508
 509 sub file_mode_is($$;$)
 510         {
 511     if( _win32() )
 512                 {
 513                 $Test->skip( "file_mode_is doesn't work on Windows" );
 514                 return;
 515                 }
 516
 517         my $filename = _normalize( shift );
 518         my $mode     = shift;
 519
 520         my $name     = shift || sprintf("%s mode is %04o", $filename, $mode);
 521
 522         my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode;
 523
 524         if( $ok )
 525                 {
 526                 $Test->ok(1, $name);
 527                 }
 528         else
 529                 {
 530                 $Test->diag(sprintf("File [%s] mode is not %04o", $filename, $mode) );
 531                 $Test->ok(0, $name);
 532                 }
 533         }
 534
 535 =item file_mode_isnt( FILENAME, MODE [, NAME ] )
 536
 537 Ok if the file exists and mode does not match, not ok
 538 if the file does not exist or mode does match.
 539
 540 This test automatically skips if it thinks it is on a
 541 Windows platform.
 542
 543 Contributed by Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >>
 544
 545 =cut
 546
 547 sub file_mode_isnt($$;$)
 548         {
 549     if( _win32() )
 550                 {
 551                 $Test->skip( "file_mode_isnt doesn't work on Windows" );
 552                 return;
 553                 }
 554
 555         my $filename = _normalize( shift );
 556         my $mode     = shift;
 557
 558         my $name     = shift || sprintf("%s mode is not %04o",$filename,$mode);
 559
 560         my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode);
 561
 562         if( $ok )
 563                 {
 564                 $Test->ok(1, $name);
 565                 }
 566         else
 567                 {
 568                 $Test->diag(sprintf("File [%s] mode is %04o",$filename,$mode));
 569                 $Test->ok(0, $name);
 570                 }
 571         }
 572
 573 =item file_is_symlink_ok( FILENAME [, NAME] )
 574
 575 Ok is FILENAME is a symlink, even if it points to a non-existent
 576 file. This test automatically skips if the operating system does
 577 not support symlinks. If the file does not exist, the test fails.
 578
 579 The optional NAME parameter is the name of the test.
 580
 581 =cut
 582
 583 sub file_is_symlink_ok
 584         {
 585     if( _no_symlinks_here() )
 586                 {
 587                 $Test->skip(
 588                         "file_is_symlink_ok doesn't work on systems without symlinks" );
 589                 return;
 590                 }
 591
 592         my $file = shift;
 593         my $name = shift || "$file is a symlink";
 594
 595         if( -l $file )
 596                 {
 597                 $Test->ok(1, $name)
 598                 }
 599         else
 600                 {
 601                 $Test->diag( "File [$file] is not a symlink!" );
 602                 $Test->ok(0, $name);
 603                 }
 604         }
 605
 606 =item symlink_target_exists_ok( SYMLINK [, TARGET] [, NAME] )
 607
 608 Ok is FILENAME is a symlink and it points to a existing file. With the
 609 optional TARGET argument, the test fails if SYMLINK's target is not
 610 TARGET. This test automatically skips if the operating system does not
 611 support symlinks. If the file does not exist, the test fails.
 612
 613 The optional NAME parameter is the name of the test.
 614
 615 =cut
 616
 617 sub symlink_target_exists_ok
 618         {
 619     if( _no_symlinks_here() )
 620                 {
 621                 $Test->skip(
 622                         "symlink_target_exists_ok doesn't work on systems without symlinks"
 623                         );
 624                 return;
 625                 }
 626
 627         my $file = shift;
 628         my $dest = shift || readlink( $file );
 629         my $name = shift || "$file is a symlink";
 630
 631         unless( -l $file )
 632                 {
 633                 $Test->diag( "File [$file] is not a symlink!" );
 634                 return $Test->ok( 0, $name );
 635                 }
 636
 637         unless( -e $dest )
 638                 {
 639                 $Test->diag( "Symlink [$file] points to non-existent target [$dest]!" );
 640                 return $Test->ok( 0, $name );
 641                 }
 642
 643         my $actual = readlink( $file );
 644         unless( $dest eq $actual )
 645                 {
 646                 $Test->diag(
 647                         "Symlink [$file] points to\n\t$actual\nexpected\n\t$dest\n\n" );
 648                 return $Test->ok( 0, $name );
 649                 }
 650
 651         $Test->ok( 1, $name );
 652         }
 653
 654 =item symlink_target_dangles_ok( SYMLINK [, NAME] )
 655
 656 Ok if FILENAME is a symlink and if it doesn't point to a existing
 657 file. This test automatically skips if the operating system does not
 658 support symlinks. If the file does not exist, the test fails.
 659
 660 The optional NAME parameter is the name of the test.
 661
 662 =cut
 663
 664 sub symlink_target_dangles_ok
 665         {
 666     if( _no_symlinks_here() )
 667                 {
 668                 $Test->skip(
 669                         "symlink_target_exists_ok doesn't work on systems without symlinks" );
 670                 return;
 671                 }
 672
 673         my $file = shift;
 674         my $dest = readlink( $file );
 675         my $name = shift || "$file is a symlink";
 676
 677         unless( -l $file )
 678                 {
 679                 $Test->diag( "File [$file] is not a symlink!" );
 680                 return $Test->ok( 0, $name );
 681                 }
 682
 683         if( -e $dest )
 684                 {
 685                 $Test->diag(
 686                         "Symlink [$file] points to existing file [$dest] but shouldn't!" );
 687                 return $Test->ok( 0, $name );
 688                 }
 689
 690         $Test->ok( 1, $name );
 691         }
 692
 693 =item link_count_is_ok( FILE, LINK_COUNT [, NAME] )
 694
 695 Ok if the link count to FILE is LINK_COUNT. LINK_COUNT is interpreted
 696 as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file
 697 does not exist. This test automatically skips if the operating system
 698 does not support symlinks. If the file does not exist, the test fails.
 699
 700 The optional NAME parameter is the name of the test.
 701
 702
 703 =cut
 704
 705 sub link_count_is_ok
 706         {
 707     if( _no_symlinks_here() )
 708                 {
 709                 $Test->skip(
 710                         "link_count_is_ok doesn't work on systems without symlinks" );
 711                 return;
 712                 }
 713
 714         my $file   = shift;
 715         my $count  = int( 0 + shift );
 716
 717         my $name   = shift || "$file has a link count of [$count]";
 718
 719         my $actual = (stat $file )[3];
 720
 721         unless( $actual == $count )
 722                 {
 723                 $Test->diag(
 724                         "File [$file] points has [$actual] links: expected [$count]!" );
 725                 return $Test->ok( 0, $name );
 726                 }
 727
 728         $Test->ok( 1, $name );
 729         }
 730
 731 =item link_count_gt_ok( FILE, LINK_COUNT [, NAME] )
 732
 733 Ok if the link count to FILE is greater than LINK_COUNT. LINK_COUNT is
 734 interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
 735 if the file has at least one link. This test automatically skips if
 736 the operating system does not support symlinks. If the file does not
 737 exist, the test fails.
 738
 739 The optional NAME parameter is the name of the test.
 740
 741 =cut
 742
 743 sub link_count_gt_ok
 744         {
 745     if( _no_symlinks_here() )
 746                 {
 747                 $Test->skip(
 748                         "link_count_gt_ok doesn't work on systems without symlinks" );
 749                 return;
 750                 }
 751
 752         my $file   = shift;
 753         my $count  = int( 0 + shift );
 754
 755         my $name   = shift || "$file has a link count of [$count]";
 756
 757         my $actual = (stat $file )[3];
 758
 759         unless( $actual > $count )
 760                 {
 761                 $Test->diag(
 762                         "File [$file] points has [$actual] links: ".
 763                         "expected more than [$count]!" );
 764                 return $Test->ok( 0, $name );
 765                 }
 766
 767         $Test->ok( 1, $name );
 768         }
 769
 770 =item link_count_lt_ok( FILE, LINK_COUNT [, NAME] )
 771
 772 Ok if the link count to FILE is less than LINK_COUNT. LINK_COUNT is
 773 interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
 774 if the file has at least one link. This test automatically skips if
 775 the operating system does not support symlinks. If the file does not
 776 exist, the test fails.
 777
 778 The optional NAME parameter is the name of the test.
 779
 780 =cut
 781
 782 sub link_count_lt_ok
 783         {
 784     if( _no_symlinks_here() )
 785                 {
 786                 $Test->skip(
 787                         "link_count_lt_ok doesn't work on systems without symlinks" );
 788                 return;
 789                 }
 790
 791         my $file   = shift;
 792         my $count  = int( 0 + shift );
 793
 794         my $name   = shift || "$file has a link count of [$count]";
 795
 796         my $actual = (stat $file )[3];
 797
 798         unless( $actual < $count )
 799                 {
 800                 $Test->diag(
 801                         "File [$file] points has [$actual] links: ".
 802                         "expected more than [$count]!" );
 803                 return $Test->ok( 0, $name );
 804                 }
 805
 806         $Test->ok( 1, $name );
 807         }
 808
 809
 810 # owner_is, owner_isnt, group_is and group_isnt are almost
 811 # identical in the beginning, so I'm writing a skeleton they can all use.
 812 # I can't think of a better name...
 813 sub _dm_skeleton
 814         {
 815         if( _obviously_non_multi_user() )
 816                 {
 817                 my $calling_sub = (caller(1))[3];
 818                 $Test->skip( $calling_sub . " only works on a multi-user OS" );
 819                 return 'skip';
 820                 }
 821
 822         my $filename      = _normalize( shift );
 823         my $testing_for   = shift;
 824         my $name          = shift;
 825
 826         unless( defined $filename )
 827                 {
 828                 $Test->diag( "File name not specified" );
 829                 return $Test->ok( 0, $name );
 830                 }
 831
 832         unless( -e $filename )
 833                 {
 834                 $Test->diag( "File [$filename] does not exist" );
 835                 return $Test->ok( 0, $name );
 836                 }
 837
 838         return;
 839         }
 840
 841 =item owner_is( FILE , OWNER [, NAME] )
 842
 843 Ok if FILE's owner is the same as OWNER.  OWNER may be a text user name
 844 or a numeric userid.  Test skips on Dos, and Mac OS <= 9.
 845 If the file does not exist, the test fails.
 846
 847 The optional NAME parameter is the name of the test.
 848
 849 Contributed by Dylan Martin
 850
 851 =cut
 852
 853 sub owner_is
 854         {
 855         my $filename      = shift;
 856         my $owner         = shift;
 857         my $name          = shift || "$filename belongs to $owner";
 858
 859         my $err = _dm_skeleton( $filename, $owner, $name );
 860         return if( defined( $err ) && $err eq 'skip' );
 861         return $err if defined($err);
 862
 863         my $owner_uid = _get_uid( $owner );
 864
 865         my $file_uid = ( stat $filename )[4];
 866
 867         unless( defined $file_uid )
 868                 {
 869                 $Test->skip("stat failed to return owner uid for $filename");
 870                 return;
 871                 }
 872
 873         return $Test->ok( 1, $name ) if $file_uid == $owner_uid;
 874
 875         my $real_owner = ( getpwuid $file_uid )[0];
 876         unless( defined $real_owner )
 877                 {
 878                 $Test->diag("File does not belong to $owner");
 879                 return $Test->ok( 0, $name );
 880                 }
 881
 882         $Test->diag( "File [$filename] belongs to $real_owner ($file_uid), ".
 883                         "not $owner ($owner_uid)" );
 884         return $Test->ok( 0, $name );
 885         }
 886
 887 =item owner_isnt( FILE, OWNER [, NAME] )
 888
 889 Ok if FILE's owner is not the same as OWNER.  OWNER may be a text user name
 890 or a numeric userid.  Test skips on Dos and Mac OS <= 9.  If the file
 891 does not exist, the test fails.
 892
 893 The optional NAME parameter is the name of the test.
 894
 895 Contributed by Dylan Martin
 896
 897 =cut
 898
 899 sub owner_isnt
 900         {
 901         my $filename      = shift;
 902         my $owner         = shift;
 903         my $name          = shift || "$filename belongs to $owner";
 904
 905         my $err = _dm_skeleton( $filename, $owner, $name );
 906         return if( defined( $err ) && $err eq 'skip' );
 907         return $err if defined($err);
 908
 909         my $owner_uid = _get_uid( $owner );
 910         my $file_uid  = ( stat $filename )[4];
 911
 912         return $Test->ok( 1, $name ) if $file_uid != $owner_uid;
 913
 914         $Test->diag( "File [$filename] belongs to $owner ($owner_uid)" );
 915         return $Test->ok( 0, $name );
 916         }
 917
 918 =item group_is( FILE , GROUP [, NAME] )
 919
 920 Ok if FILE's group is the same as GROUP.  GROUP may be a text group name or
 921 a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
 922 systems that do not support getpwuid() and friends.  If the file does not
 923 exist, the test fails.
 924
 925 The optional NAME parameter is the name of the test.
 926
 927 Contributed by Dylan Martin
 928
 929 =cut
 930
 931 sub group_is
 932         {
 933         my $filename      = shift;
 934         my $group         = shift;
 935         my $name          = ( shift || "$filename belongs to group $group" );
 936
 937         my $err = _dm_skeleton( $filename, $group, $name );
 938         return if( defined( $err ) && $err eq 'skip' );
 939         return $err if defined($err);
 940
 941         my $group_gid = _get_gid( $group );
 942         my $file_gid  = ( stat $filename )[5];
 943
 944         unless( defined $file_gid )
 945                 {
 946                 $Test->skip("stat failed to return group gid for $filename");
 947                 return;
 948                 }
 949
 950         return $Test->ok( 1, $name ) if $file_gid == $group_gid;
 951
 952         my $real_group = ( getgrgid $file_gid )[0];
 953         unless( defined $real_group )
 954                 {
 955                 $Test->diag("File does not belong to $group");
 956                 return $Test->ok( 0, $name );
 957                 }
 958
 959         $Test->diag( "File [$filename] belongs to $real_group ($file_gid), ".
 960                         "not $group ($group_gid)" );
 961
 962         return $Test->ok( 0, $name );
 963         }
 964
 965 =item group_isnt( FILE , GROUP [, NAME] )
 966
 967 Ok if FILE's group is not the same as GROUP.  GROUP may be a text group name or
 968 a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
 969 systems that do not support getpwuid() and friends.  If the file does not
 970 exist, the test fails.
 971
 972 The optional NAME parameter is the name of the test.
 973
 974 Contributed by Dylan Martin
 975
 976 =cut
 977
 978 sub group_isnt
 979         {
 980         my $filename      = shift;
 981         my $group         = shift;
 982         my $name          = shift || "$filename does not belong to group $group";
 983
 984         my $err = _dm_skeleton( $filename, $group, $name );
 985         return if( defined( $err ) && $err eq 'skip' );
 986         return $err if defined($err);
 987
 988         my $group_gid = _get_gid( $group );
 989         my $file_gid  = ( stat $filename )[5];
 990
 991         unless( defined $file_gid )
 992                 {
 993                 $Test->skip("stat failed to return group gid for $filename");
 994                 return;
 995                 }
 996
 997         return $Test->ok( 1, $name ) if $file_gid != $group_gid;
 998
 999         $Test->diag( "File [$filename] belongs to $group ($group_gid)" );
1000                 return $Test->ok( 0, $name );
1001         }
1002
1003 sub _get_uid
1004         {
1005         my $owner = shift;
1006         my $owner_uid;
1007
1008         if ($owner =~ /^\d+/)
1009                 {
1010                 $owner_uid = $owner;
1011                 $owner = ( getpwuid $owner )[0];
1012                 }
1013         else
1014                 {
1015                 $owner_uid = (getpwnam($owner))[2];
1016                 }
1017
1018         $owner_uid;
1019         }
1020
1021 sub _get_gid
1022         {
1023         my $group = shift;
1024         my $group_uid;
1025
1026         if ($group =~ /^\d+/)
1027                 {
1028                 $group_uid = $group;
1029                 $group = ( getgrgid $group )[0];
1030                 }
1031         else
1032                 {
1033                 $group_uid = (getgrnam($group))[2];
1034                 }
1035
1036         $group_uid;
1037         }
1038
1039 =back
1040
1041 =head1 TO DO
1042
1043 * check properties for other users (readable_by_root, for instance)
1044
1045 * check times
1046
1047 * check number of links to file
1048
1049 * check path parts (directory, filename, extension)
1050
1051 =head1 SEE ALSO
1052
1053 L<Test::Builder>,
1054 L<Test::More>
1055
1056 =head1 SOURCE AVAILABILITY
1057
1058 This source is part of a SourceForge project which always has the
1059 latest sources in CVS, as well as all of the previous releases.
1060
1061         http://sourceforge.net/projects/brian-d-foy/
1062
1063 If, for some reason, I disappear from the world, one of the other
1064 members of the project can shepherd this module appropriately.
1065
1066 =head1 AUTHOR
1067
1068 brian d foy, C<< <bdfoy@cpan.org> >>
1069
1070 =head1 CREDITS
1071
1072 Shawn Sorichetti C<< <ssoriche@coloredblocks.net> >> provided
1073 some functions.
1074
1075 Tom Metro helped me figure out some Windows capabilities.
1076
1077 Dylan Martin added C<owner_is> and C<owner_isnt>
1078
1079 =head1 COPYRIGHT
1080
1081 Copyright 2002-2007, brian d foy, All Rights Reserved
1082
1083 =head1 LICENSE
1084
1085 You may use, modify, and distribute this under the same terms
1086 as Perl itself.
1087
1088 =cut
1089
1090 "The quick brown fox jumped over the lazy dog";