File Coverage

blib/lib/Module/AutoLoad.pm

Criterion	Covered	Total	%
statement	105	113	92.9
branch	41	68	60.2
condition	5	10	50.0
subroutine	10	10	100.0
pod	0	5	0.0
total	161	206	78.1

package Module::AutoLoad;

use strict;
use warnings;
use base qw(Exporter);

our $VERSION = '0.03';

our $last_fetched = "";
our $lib = "lib";

sub import {
  warn "Congratulations! Module::AutoLoad has been loaded.\n" if $ENV{AUTOLOAD_DEBUG};
  $lib = $ENV{AUTOLOAD_LIB} if $ENV{AUTOLOAD_LIB};
  if ($lib =~ m{^[^/]}) {
    eval {
      require Cwd;
      $lib = Cwd::abs_path($lib);
    };
  }
  push @INC, $lib, \&inc;
}

sub mkbase {
  my $path = shift;
  if ($path =~ s{/+[^/]*$ }{}x) {
    return 1 if -d $path;
  }
  die "$path: Not a directory\n" if lstat $path;
  if (mkbase($path)) {
    warn "DEBUG: mkbase: Creating [$path] ...\n" if $ENV{AUTOLOAD_DEBUG};
    return mkdir $path, 0755;
  }
  return 0;
}

sub fetch {
  my $url = shift;
  my $recurse = shift || {};
  $url = full($url) unless $url =~ m{^\w+://};
  my $contents = get url $url;
  $last_fetched = $url;
  if ($contents =~ m{The document has moved }) {
    my $bounce = $1;
    if ($recurse->{$bounce} && $recurse->{$bounce} > 2) {
      return $contents;
    }
    $recurse->{$bounce}++;
    return fetch($bounce, $recurse) if $recurse->{total}++<20;
  }
  return $contents;
}

# full
# Turn a relative URL into a full URL
sub full {
  my $rel = shift;
  if ($rel =~ m{http://} || $last_fetched !~ m{^(http://[^/]+)(/?.*)}) {
    return $rel;
  }
  my $h = $1;
  my $p = $2;
  if ($rel =~ m{^/}) {
    return "$h$rel";
  }
  $p =~ s{[^/]*$ }{}x;
  return "$h$p$rel";
}

# fly
# Create a stub module to load the real file on-the-fly if needed.
sub fly {
  my $inc = shift;
  my $url = shift;
  my $write = shift;
  warn "DEBUG: Creating stub for [$inc] in order to download [$url] later if needed.\n" if $ENV{AUTOLOAD_DEBUG};
  my $contents = q{
    my $url = q{$URL};
    my $myself = $INC{"$inc"} || __FILE__;
    warn "DEBUG: Downloading [$url] right now ...\n" if $ENV{AUTOLOAD_DEBUG};
    my $m = Module::AutoLoad::fetch($url);
    if ($m =~ /package/) {
      warn "DEBUG: Contents appear fine. Commencing BRICK OVER ...\n" if $ENV{AUTOLOAD_DEBUG};
      if (open my $fh, ">", $myself) {
        print $fh $m;
        close $fh;
      }
      else {
        warn "$myself: WARNING: Unable to repair! $!\n";
      }
      warn "DEBUG: Forcing re-evaluation of fresh module contents ...\n" if $ENV{AUTOLOAD_DEBUG};
      my $e = eval $m;
      if ($e) {
        $INC{"$inc"} = $url;
        $e;
      }
      else {
        die "$url: $@\n";
      }
    }
    else {
      die "$url: STANKY! $m\n";
    }
  };
  $contents =~ s/\s+/ /g;
  $contents =~ s/([\;\{]+)\s+/$1\n/g;
  $contents =~ s/^\s+//;
  $contents =~ s/\s*$/\n/;
  # Fake interpolation
  $contents =~ s/\$URL/$url/g;
  $contents =~ s/\$inc/$inc/g;
  if ($write) {
    mkbase($write);
    $contents =~ s/(\$myself)\s*=.*?;/$1 = "$write";/;
    open my $fh, ">", $write or die "$write: open: OUCH! $!";
    print $fh $contents;
    close $fh;
  }
  return $contents;
}

sub inc {
  my $i = shift;
  my $f = shift;
  my $cache_file = "$lib/$f";
  if (-f $cache_file) {
    warn "$cache_file: Broken module. Can't continue.\n";
    return ();
  }
  mkbase($cache_file) or die "$cache_file: Unable to create! $!\n";
  pop @INC if $INC[-1] eq \&botstrap::inc;

  if ($f =~ m{^([\w/]+)\.pm}) {
    my $dist = $1;
    my $mod  = $1;
    $f = "$1.pm";
    $dist =~ s{/+}{-}g;
    $mod  =~ s{/+}{::}g;

    my $mapper = $ENV{AUTOLOAD_SRC} || "http://search.cpan.org/dist";
    my $search = fetch("$mapper/$dist/");
    if ($search =~ m{href="([^<>]+)">Browse<}) {
      my $src = full($1);
      if (my $MANIFEST = fetch "$src/MANIFEST") {
        $src = $1 if $last_fetched =~ m{^(.*?)/+MANIFEST};
        if ($MANIFEST =~ m{^lib/}m) {
          warn "DEBUG: YEY! Found a lib/ somewhere!\n" if $ENV{AUTOLOAD_DEBUG};
          while ($MANIFEST =~ s{^lib/(\S+\.pm)}{ }m) {
            my $remote = $1;
            warn "DEBUG: MATCH [lib/$remote] RIPPED OUT\n" if $ENV{AUTOLOAD_DEBUG};
            $last_fetched = "$src/MANIFEST";
            my $cache = "$lib/$remote";
            if (!-f $cache) {
              my $full = full("lib/$remote");
              fly($remote,$full,$cache);
            }
          }
        }
        else {
          warn "DEBUG: Oh, too bad there is no magic lib folder in the MANIFEST [$MANIFEST]\n" if $ENV{AUTOLOAD_DEBUG};
        }
        if (!-f $cache_file) {
          # Old versions of h2xs used to toss the end module right into the base folder?
          if ($f =~ m{(\w+\.pm)}) {
            my $stub = $1;
            if ($MANIFEST =~ /^(.*$stub)$/m) {
              my $stab = $1;
              $last_fetched = "$src/MANIFEST";
              $stab = full($stab);
              fly($f, $stab, $cache_file);
            }
            else {
              warn "WARNING: No [$stub] in $src/MANIFEST? [$MANIFEST]" if $ENV{AUTOLOAD_DEBUG};
              die "No [$stub] in $src/MANIFEST";
            }
          }
          else {
            warn "WARNING: Unable to extract stub from file [$f] ??\n";
          }
        }
      }
      else {
        warn "$src: Incomplete distribution! Broken MANIFEST file?\n";
      }
    }
  }

  if (open my $fh, "<", $cache_file) {
    $INC{$f} = $cache_file;
    return $fh;
  }

  return ();
}

$INC{"Module/AutoLoad.pm"} ||= __FILE__;
# Dummy AutoLoad wrapper module for RCX Framework.
package AutoLoad;
use base qw(Module::AutoLoad);

$INC{"AutoLoad.pm"} ||= __FILE__;

1;
__END__