File Coverage

blib/lib/Acme/AutoLoad.pm

Criterion	Covered	Total	%
statement	50	126	39.6
branch	16	80	20.0
condition	2	10	20.0
subroutine	8	11	72.7
pod	0	7	0.0
total	76	234	32.4

package Acme::AutoLoad;

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

our $VERSION = '0.09';

our $last_fetched = "";
our $lib = "lib";
our $hook = \&inc;

sub ignore {}
sub import {
  warn "DEBUG: Congratulations! Acme::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, $hook if $hook;
  $hook = undef;
  return \&ignore;
}

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);
  $last_fetched = $url;
  if ($contents =~ m{The document has moved }) {
    my $bounce = $1;
    return $contents if ++$recurse->{$bounce} > 3;
    return fetch($bounce, $recurse) if ++$recurse->{total} < 21;
  }
  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 = Acme::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";
  shift @INC if $INC[0] eq \&ignore;

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

    my $mapper = $ENV{AUTOLOAD_SRC} || "http://fastapi.metacpan.org/v1/module";
    my $search = fetch("$mapper/$mod/");
    warn "DEBUG: Probed: $last_fetched\n" if $ENV{AUTOLOAD_DEBUG};
    if ($search =~ m{download_url.*?(\w+/[\w\-\.]+)\.tar.gz}) {
      my $src = full("/source/$1/");
      if ($search =~ m{"distribution"\s*:\s*"(.*?)"} && $dist ne $1) {
        warn "DEBUG: Found module [$mod] as part of [$1] instead of [$dist]\n" if $ENV{AUTOLOAD_DEBUG};
        $dist = $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 ();
}

sub get {
  local $_ = shift;
  s{^http(s|)://}{}i;
  s{^([\w\-\.\:]+)$}{$1/};
  s{^([\w\-\.]+)/}{$1:80/};
  if (m{^([\w\-\.]+:\d+)(/.*)}) {
    my $host = $1;
    my $path = $2;
    my $r = new IO::Socket::INET $host or return warn "$host$!\n";
    $host =~ s/:\d+$//;
    print $r "GET $path HTTP/1.0\r\nUser-Agent: Acme::AutoLoad/url::get\r\nHost: $host\r\n\r\n";
    local $/;
    return [split/[\r\n]{3,}/,<$r>,2]->[1];
  }
  return "";
}

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

warn "DEBUG: Congratulations! Acme::AutoLoad was compiled fine.\n" if $ENV{AUTOLOAD_DEBUG};

1;
__END__