t/lib/DBICTest/AuthorCheck.pm

   1 package # hide from PAUSE
   2     DBICTest::AuthorCheck;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Path::Class qw/file dir/;
   8
   9 _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION};
  10
  11 # Die if the author did not update his makefile
  12 #
  13 # This is pretty heavy handed, so the check is pretty solid:
  14 #
  15 # 1) Assume that this particular module is loaded from -I <$root>/t/lib
  16 # 2) Make sure <$root>/Makefile.PL exists
  17 # 3) Make sure we can stat() <$root>/Makefile.PL
  18 #
  19 # If all of the above is satisfied
  20 #
  21 # *) die if <$root>/inc does not exist
  22 # *) die if no stat() results for <$root>/Makefile (covers no Makefile)
  23 # *) die if Makefile.PL mtime > Makefile mtime
  24 #
  25 sub _check_author_makefile {
  26
  27   my $root = _find_co_root()
  28     or return;
  29
  30   my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm');
  31
  32   # not using file->stat as it invokes File::stat which in turn breaks stat(_)
  33   my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map
  34     { (stat ($root->file ($_)) )[9] || undef }  # stat returns () on nonexistent files
  35     (qw|Makefile.PL  Makefile|, $optdeps)
  36   );
  37
  38   return unless $mf_pl_mtime;   # something went wrong during co_root detection ?
  39
  40   my @fail_reasons;
  41
  42   if(not -d $root->subdir ('inc')) {
  43     push @fail_reasons, "Missing ./inc directory";
  44   }
  45
  46   if(not $mf_mtime) {
  47     push @fail_reasons, "Missing ./Makefile";
  48   }
  49   else {
  50     if($mf_mtime < $mf_pl_mtime) {
  51       push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
  52     }
  53     if($mf_mtime < $optdeps_mtime) {
  54       push @fail_reasons, "./$optdeps is newer than ./Makefile";
  55     }
  56   }
  57
  58   if (@fail_reasons) {
  59     print STDERR <<'EOE';
  60
  61
  62 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  63 ======================== FATAL ERROR ===========================
  64 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  65
  66 We have a number of reasons to believe that this is a development
  67 checkout and that you, the user, did not run `perl Makefile.PL`
  68 before using this code. You absolutely _must_ perform this step,
  69 and ensure you have all required dependencies present. Not doing
  70 so often results in a lot of wasted time for other contributors
  71 trying to assit you with spurious "its broken!" problems.
  72
  73 If you are seeing this message unexpectedly (i.e. you are in fact
  74 attempting a regular installation be it through CPAN or manually),
  75 please report the situation to either the mailing list or to the
  76 irc channel as described in
  77
  78 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT
  79
  80 The DBIC team
  81
  82
  83 Reasons you received this message:
  84
  85 EOE
  86
  87     foreach my $r (@fail_reasons) {
  88       print STDERR "  * $r\n";
  89     }
  90     print STDERR "\n\n\n";
  91
  92     exit 1;
  93   }
  94 }
  95
  96 # Mimic $Module::Install::AUTHOR
  97 sub is_author {
  98
  99   my $root = _find_co_root()
 100     or return undef;
 101
 102   return (
 103     ( not -d $root->subdir ('inc') )
 104       or
 105     ( -e $root->subdir ('inc')->file ($^O eq 'VMS' ? '_author' : '.author') )
 106   );
 107 }
 108
 109 # Try to determine the root of a checkout/untar if possible
 110 # or return undef
 111 sub _find_co_root {
 112
 113     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 114     my $rel_path = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 115
 116     return undef unless ($INC{$rel_path});
 117
 118     # a bit convoluted, but what we do here essentially is:
 119     #  - get the file name of this particular module
 120     #  - do 'cd ..' as many times as necessary to get to t/lib/../..
 121
 122     my $root = dir ($INC{$rel_path});
 123     for (1 .. @mod_parts + 2) {
 124         $root = $root->parent;
 125     }
 126
 127     return (-f $root->file ('Makefile.PL') )
 128       ? $root
 129       : undef
 130     ;
 131 }
 132
 133 1;