t/distro/file_metadata.t

   1 #!perl
   2 # Copyright (C) 2006-2007, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8
   9 use Test::More;
  10 use File::Basename qw( fileparse );
  11 use File::Spec::Functions qw( catfile splitpath splitdir );
  12 use File::Spec::Unix;
  13 use Parrot::Config;
  14 use ExtUtils::Manifest qw( maniread );
  15
  16 =head1 NAME
  17
  18 t/distro/file_metadata.t - verify that file metadata matches expectations
  19
  20 =head1 SYNOPSIS
  21
  22  % prove t/distro/file_metadata.t
  23
  24 =head1 DESCRIPTION
  25
  26 Makes sure that file metadata meets our expectations. For example, checks
  27 include 'all test files have "text/plain" mime-type',
  28 and 'all "text/plain" files have keyword expansion enabled'.  Also checks
  29 that all "text/plain" files have their svn:eol-style set to 'native'.
  30
  31 Note: These tests would benefit from judicial application of Iterators.
  32
  33 =cut
  34
  35 BEGIN {
  36     unless ( -e 'DEVELOPING' ) {
  37         plan skip_all => "Don't bother running these in a tarball.";
  38         exit(0);
  39     }
  40 }
  41
  42
  43 my $cmd = 'svn';
  44 my @git_svn_metadata;    # set in BEGIN block
  45
  46 # how many files to check at a time. May have to lower this when we run
  47 # this on systems with finicky command lines.
  48 my $chunk_size = 100;
  49
  50 # get files listed in MANIFEST
  51 my @manifest_files =
  52     sort keys %{ maniread( catfile $PConfig{build_dir}, 'MANIFEST' ) };
  53
  54 my $mime_types = get_attribute( 'svn:mime-type', @manifest_files );
  55
  56 ## only certain mime types are expected.
  57
  58
  59 VALID_MIME: {
  60
  61     my $test        = 'svn:mime-type';
  62     my @expected    = qw[
  63         text/css
  64         text/plain
  65         text/script
  66         text/xml
  67         application/octet-stream
  68         application/postscript
  69         image/gif
  70         image/png
  71     ];
  72     push @expected, 'text/plain; charset=UTF-8';
  73
  74     my $expected    = join '|', @expected, "";
  75     my $expected_re = qr{^(${expected})$};
  76
  77     my @failed      = verify_attributes( $test, $expected_re, 0, $mime_types, \@manifest_files, 1 );
  78
  79     if (@failed) {
  80         my $failure = join q{}, "Invalid svn:mime-types found in the following files:\n",
  81             map { "$_\n" } @failed;
  82         is( $failure, '', $test );
  83     }
  84     else {
  85         pass($test);
  86     }
  87 }    # VALID_MIME
  88
  89 ## all test files must have "text/plain" mime-type. Assume anything in the
  90 ## repository with a .t is test file.
  91
  92 TEST_MIME: {
  93
  94     # find test files
  95     my $test_suffix = '.t';
  96     my @test_files  = grep { m/\Q$test_suffix\E$/ } @manifest_files;
  97     my $test        = 'svn:mime-type';
  98     my $expected    = 'text/plain';
  99     my @failed      = verify_attributes( $test, $expected, 0, $mime_types, \@test_files );
 100     my $test_name   = "$test for .t files";
 101
 102     if (@failed) {
 103         my $failure = join q{}, "Set $test with:\n",
 104             map { " $cmd ps $test '$expected' $_\n" } @failed;
 105         $failure = "git svn metadata $test incorrect for @failed" if -d '.git';
 106         is( $failure, '', $test_name );
 107     }
 108     else {
 109         pass($test_name);
 110     }
 111 }    # TEST_MIME
 112
 113 ## keyword expansion must be set for any manifest files with an explicit
 114 ## mime type of text/plain. Assume a default of text/plain if not specified
 115
 116 KEYWORD_EXP: {
 117
 118     # we only want those files whose mime types that start with text/plain
 119
 120     my @plain_files;
 121     foreach my $file ( keys %$mime_types ) {
 122         if ( !defined( $mime_types->{$file} )
 123             || $mime_types->{$file} =~ qr{^text/plain} )
 124         {
 125             push @plain_files, $file;
 126         }
 127     }
 128
 129     my $test     = 'svn:keywords';
 130     my $expected = 'Author Date Id Revision';
 131     my $keywords = get_attribute( $test, @plain_files );
 132
 133     my @failed = verify_attributes( $test, $expected, 1, $keywords );
 134
 135     if (@failed) {
 136         my $failure = join q{}, "Set $test with:\n",
 137             map { " $cmd ps $test \"$expected\" $_\n" } @failed;
 138         $failure = "git svn metadata $test incorrect for @failed" if -d '.git';
 139         is( $failure, '', $test );
 140     }
 141     else {
 142         pass($test);
 143     }
 144
 145 }    # KEYWORD_EXP
 146
 147 ## eol-style must be set to 'native' for any manifest files with an explicit
 148 ## mime type of text/plain. Assume a default of text/plain if not specified.
 149 ## This is, however, *not* true for many files.  Some text files need to
 150 ## have a single LF character as the EOL character on *all* platforms due to
 151 ## Parrot's current IO mechanism.  Therefore, we need to check that the
 152 ## files with LF are the ones we expect, and that the rest are native.
 153
 154 our $lf_files_regexp = qr{
 155     ^examples/shootout/.*\.pir_input$ |
 156     ^examples/shootout/.*\.pir_output$ |
 157     ^t/compilers/pge/p5regex/re_tests$ |
 158     ^t/library/perlhist\.txt$ |
 159     ^t/op/sprintf_tests$
 160      }x;
 161
 162 NATIVE_EOL_STYLE: {
 163
 164     # we need to skip the files which *should* have LF as the eol-style
 165     # we only want those files whose mime types that start with text/plain
 166     ## collect the files to test
 167     my @plain_files;
 168     foreach my $file ( keys %$mime_types ) {
 169         if ( !defined( $mime_types->{$file} )
 170             || $mime_types->{$file} =~ qr{^text/plain} )
 171         {
 172             push @plain_files, $file
 173                 unless $file =~ $lf_files_regexp;
 174         }
 175     }
 176
 177     my $test      = 'svn:eol-style';
 178     my $expected  = 'native';
 179     my $test_name = $test . "=" . $expected;
 180     my $keywords  = get_attribute( $test, @plain_files );
 181
 182     my @failed = verify_attributes( $test, $expected, 1, $keywords );
 183
 184     if (@failed) {
 185         my $failure = join q{}, "Set $test with:\n",
 186             map { " $cmd ps $test $expected $_\n" } @failed;
 187         $failure = "git svn metadata $test incorrect for @failed" if -d '.git';
 188         is( $failure, '', $test_name );
 189     }
 190     else {
 191         pass($test_name);
 192     }
 193
 194 }    # NATIVE_EOL_STYLE
 195
 196 LF_EOL_STYLE: {
 197
 198     ## collect the files to test
 199     my @lf_files;
 200     foreach my $file ( keys %$mime_types ) {
 201         if ( !defined( $mime_types->{$file} )
 202             || $mime_types->{$file} =~ qr{^text/plain} )
 203         {
 204             push @lf_files, $file
 205                 if $file =~ $lf_files_regexp;
 206         }
 207     }
 208
 209     my $test      = 'svn:eol-style';
 210     my $expected  = 'LF';
 211     my $test_name = $test . "=" . $expected;
 212     my $keywords  = get_attribute( $test, @lf_files );
 213
 214     my @failed = verify_attributes( $test, $expected, 1, $keywords );
 215
 216     if (@failed) {
 217         my $failure = join q{}, "Set $test with:\n",
 218             map { " $cmd ps $test $expected $_\n" } @failed;
 219         $failure = "git svn metadata $test incorrect for @failed" if -d '.git';
 220         is( $failure, '', $test_name );
 221     }
 222     else {
 223         pass($test_name);
 224     }
 225
 226 }    # LF_EOL_STYLE
 227
 228 BEGIN {
 229     if ( -d '.git' ) {
 230         my $git_svn_metadata = catfile(qw/.git svn git-svn unhandled.log/);
 231         if ( -e $git_svn_metadata ) {
 232             diag 'Checking git svn metadata';
 233             plan tests => 5;
 234
 235             # Read the file once and store lines
 236             if ( !open my $git_svn_metadata_fh, '<', $git_svn_metadata ) {
 237                 diag "trouble opening metadata file: $git_svn_metadata";
 238             }
 239             else {
 240                 @git_svn_metadata = <$git_svn_metadata_fh>;
 241                 close $git_svn_metadata_fh;
 242             }
 243         }
 244         else {
 245             plan skip_all => q{git svn file metadata not retained};
 246         }
 247     }
 248     elsif ( ! (-d '.svn' && `svn info .`) ) {
 249         plan skip_all => 'not a working copy';
 250     }
 251     else { plan tests => 5 }
 252 }
 253
 254 #
 255 # Given a list, a count, and a sub, process that list count elements
 256 # at a time. (do this to speed up execution for the svn commands)
 257 #
 258
 259 sub at_a_time {
 260     my $count = shift;
 261     my $sub   = shift;
 262     my @list  = @_;
 263
 264     return unless $sub;
 265     return unless @list;
 266
 267     while (@list) {
 268         $count = @list if $count > @list;
 269         my @sublist = splice @list, 0, $count;
 270         $sub->(@sublist);
 271     }
 272
 273     return;
 274 }
 275
 276 # Given an attribute and a list of files, return a hashref
 277 # containing filenames/values.
 278 sub get_attribute {
 279     my $attribute = shift;
 280     my @list      = @_;
 281
 282     diag "Collecting $attribute attributes...\n";
 283
 284     my %results = map { $_ => undef } @list;
 285
 286     if ( -d '.git' ) {
 287         return git_svn_metadata( $attribute, \%results );
 288     }
 289
 290     # choose a chunk size such that we don't end calling svn on
 291     # a single file (which causes the output format to change).
 292     my $csize = $chunk_size;
 293     $csize-- while ( ( $csize > 1 ) && ( @list % $csize == 1 ) );
 294
 295     at_a_time(
 296         $csize,
 297         sub {
 298             my @partial_list = @_;
 299
 300             foreach my $result (qx($cmd pg $attribute @partial_list)) {
 301
 302                 # This RE may be a little wonky.
 303                 if ( $result =~ m{(.*) - (.*)} ) {
 304                     my ( $full_path, $attribute ) = ( $1, $2 );
 305
 306                     # split the path
 307                     my ( $volume, $directories, $file ) = splitpath $full_path;
 308                     my @directories = splitdir $directories;
 309
 310                     # put it back together as a unix path (to match MANIFEST)
 311                     $full_path =
 312                         File::Spec::Unix->catpath( $volume, File::Spec::Unix->catdir(@directories),
 313                         $file );
 314
 315                     # store the attribute into the results hash
 316                     $results{$full_path} = $attribute;
 317                 }
 318             }
 319
 320         },
 321         @list
 322     );
 323     return \%results;
 324 }
 325
 326 sub verify_attributes {
 327     my $attribute = shift;    # name of the attribute
 328     my $expected  = shift;    # the expected value
 329     my $exact     = shift;    # should this be an exact match?
 330     my $results   = shift;    # the results hash ref: file -> value
 331     my $files     = shift;    # an arrayref of files we care about. (undef->all)
 332     my $allow_empty = shift;  # should we allow blank values? (default: no)
 333
 334     $allow_empty = 0 unless defined $allow_empty;
 335
 336     my @files;
 337     if ( defined($files) ) {
 338         @files = @$files;
 339     }
 340     else {
 341         @files = keys %$results;
 342     }
 343
 344     my @failures;
 345     foreach my $file ( sort @files ) {
 346         my $actual = $results->{$file};
 347         if ($allow_empty && ! defined $actual) {
 348             $actual = "";
 349         }
 350         if ( !defined $actual ) {
 351             push @failures, $file;
 352             next;
 353         }
 354         if ($exact) {
 355             if ( $actual ne $expected ) {
 356                 push @failures, $file;
 357             }
 358         }
 359         else {
 360             if ( $actual !~ /^$expected/ ) {
 361                 push @failures, $file;
 362             }
 363         }
 364     }
 365
 366     return @failures;
 367 }
 368
 369 sub git_svn_metadata {
 370     my $attribute   = shift;
 371     my $results_ref = shift;
 372
 373 GIT_SVN:
 374     for my $line (@git_svn_metadata) {
 375
 376         # Determine file name and attribute value for the files we want
 377         my ( $filename, $value ) = $line =~ m/prop: (\S+) $attribute (\S+)/;
 378         next GIT_SVN unless $filename && exists $results_ref->{$filename};
 379
 380         # Unescape hex values that are in git-svn log and remove any newlines
 381         $value =~ s/%([0-9A-F]{2})/chr(hex($1))/gie;
 382         chomp($value);
 383
 384         $results_ref->{$filename} = $value;
 385     }
 386     return $results_ref;
 387 }
 388
 389 # Local Variables:
 390 #   mode: cperl
 391 #   cperl-indent-level: 4
 392 #   fill-column: 100
 393 # End:
 394 # vim: expandtab shiftwidth=4: