| Commit | Line | Data |
|---|
| b974984a |
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 | # not using file->stat as it invokes File::stat which in turn breaks stat(_) |
| 31 | my ($mf_pl_mtime, $mf_mtime) = ( map |
| 32 | { (stat ($root->file ($_)) )[9] } |
| 33 | qw/Makefile.PL Makefile/ |
| 34 | ); |
| 35 | |
| 36 | return unless $mf_pl_mtime; # something went wrong during co_root detection ? |
| 37 | |
| 38 | if ( |
| 39 | not -d $root->subdir ('inc') |
| 40 | or |
| 41 | not $mf_mtime |
| 42 | or |
| 43 | $mf_mtime < $mf_pl_mtime |
| 44 | ) { |
| 45 | print STDERR <<'EOE'; |
| 46 | |
| 47 | |
| 48 | |
| 49 | |
| 50 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
| 51 | ======================== FATAL ERROR =========================== |
| 52 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
| 53 | |
| 54 | We have a number of reasons to believe that this is a development |
| 55 | checkout and that you, the user, did not run `perl Makefile.PL` |
| 56 | before using this code. You absolutely _must_ perform this step, |
| 57 | and ensure you have all required dependencies present. Not doing |
| 58 | so often results in a lot of wasted time for other contributors |
| 59 | trying to assit you with spurious "its broken!" problems. |
| 60 | |
| 61 | If you are seeing this message unexpectedly (i.e. you are in fact |
| 62 | attempting a regular installation be it through CPAN or manually), |
| 63 | please report the situation to either the mailing list or to the |
| 64 | irc channel as described in |
| 65 | |
| 66 | http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT |
| 67 | |
| 68 | The DBIC team |
| 69 | |
| 70 | |
| 71 | |
| 72 | EOE |
| 73 | |
| 74 | exit 1; |
| 75 | } |
| 76 | } |
| 77 | |
| 78 | # Mimic $Module::Install::AUTHOR |
| 79 | sub is_author { |
| 80 | |
| 81 | my $root = _find_co_root() |
| 82 | or return undef; |
| 83 | |
| 84 | return ( |
| 85 | ( not -d $root->subdir ('inc') ) |
| 86 | or |
| 87 | ( -e $root->subdir ('inc')->file ($^O eq 'VMS' ? '_author' : '.author') ) |
| 88 | ); |
| 89 | } |
| 90 | |
| 91 | # Try to determine the root of a checkout/untar if possible |
| 92 | # or return undef |
| 93 | sub _find_co_root { |
| 94 | |
| 95 | my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); |
| 96 | my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS |
| 97 | |
| 98 | return undef unless ($INC{$rel_path}); |
| 99 | |
| 100 | # a bit convoluted, but what we do here essentially is: |
| 101 | # - get the file name of this particular module |
| 102 | # - do 'cd ..' as many times as necessary to get to t/lib/../.. |
| 103 | |
| 104 | my $root = dir ($INC{$rel_path}); |
| 105 | for (1 .. @mod_parts + 2) { |
| 106 | $root = $root->parent; |
| 107 | } |
| 108 | |
| 109 | return (-f $root->file ('Makefile.PL') ) |
| 110 | ? $root |
| 111 | : undef |
| 112 | ; |
| 113 | } |
| 114 | |
| 115 | 1; |
projects / dbsrgits/DBIx-Class-DeploymentHandler.git / blame