File Coverage

blib/lib/strict/ModuleName.pm

Criterion	Covered	Total	%
statement	34	46	73.9
branch	13	28	46.4
condition	5	9	55.5
subroutine	4	4	100.0
pod			n/a
total	56	87	64.3

require 5;
package strict::ModuleName;     # Pod at end
$VERSION = '0.04';
use strict;
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
use vars qw($DIE);
$DIE = 1 unless defined $DIE;

sub import {
  # Make sure that the calling package's name agrees with its filename
  if(@_ > 1) {
    require Carp;
    for my $msg (
     "Proper usage: use " . __PACKAGE__ . "; #(with no parameters) "
    ) { $DIE ? Carp::croak($msg) : Carp::carp($msg) }
  }
  my($package, $filename) = caller(0);

  unless($filename =~ m/.\.pm$/s) {  # catch this first off
    if($filename =~ m/.(\.pm)$/is) {
      for my $msg (
       "filename \"$filename\" should end in \".pm\", not \"$1\"\n"
      ) { return $DIE ? die($msg) : warn($msg) }
    } else {
      for my $msg (
       "filename \"$filename\" should end in \".pm\"!\n"
      ) { return $DIE ? die($msg) : warn($msg) }
    }
  }

  my $pre = quotemeta($package);
  $pre =~ s/(\\[\'\:])+/./g;  # Foo::Bar => Foo.Bar

  DEBUG and print ">>>>. $package in $filename\n";

  my $re = join '',
    '^(',
    join('|', map quotemeta($_),
      sort {length($b) <=> length($a)}
        @INC
    ),
    ')',
    '\W{0,2}',
       # generous RE matching trailing pathsep thing like / or \ or :
    $pre,
    '\.pm$',
  ;

  if(DEBUG) {
    DEBUG and print $re, "\n\n";
    for(0 .. 10) {
      print("\n"), last unless defined caller($_);
      print "caller($_) is ", join(" # ", map $_ || '', (caller($_))[0..7] ), "\n";
    }
  }

  if($filename =~ m/$re/s) {
    DEBUG and print "file \"$filename\" producing package \"$package\" is okay\n";

  } else {

    {
      # Jump thru hoops to check for a very common case:
      #  whether that package was like "perl -cw X.pm" or "perl -w X.pm"

      my @callstack;
      my $back_count = 0;
      my $real_depth = 0;
      while(1) {
        last unless defined caller($back_count);
        my $sub_name = (caller($back_count))[3];
        ++$real_depth
         unless $sub_name eq '(eval)' or $sub_name =~ m/\:\:BEGIN$/s;
        ++$back_count;
      }
      my $fn = $filename;
      $fn =~ s/\.pm$//s or die "WHAAAAAT?";

      if($real_depth == 1
        and length($fn) <= length($package)
        and substr($package, 0 - length($fn)) eq $fn
      ) {
        warn(   # yes, merely warn
         "Can't verify whether package name \"$package\" is good in \"$filename\""
         . "\n -- Instead try:  perl -M$package -e -1\n"
        );
        return;
      }
    }

    if(grep ref($_), @INC) {
      warn(
       "file \"$filename\" producing package \"$package\" may be bad,\n"
       . "  -- but I can't be sure, because there's coderefs in \@INC\n");
      return;
    }

    for my $msg (
     "file \"$filename\" producing package \"$package\" is bad\n"
    ) { return $DIE ? die($msg) : warn($msg) }
  }

  return;
}

&import(); # Yes, test myself!

1;

__END__