File Coverage

blib/lib/deferred.pm

Criterion	Covered	Total	%
statement	45	50	90.0
branch	18	22	81.8
condition	2	3	66.6
subroutine	8	8	100.0
pod			n/a
total	73	83	87.9

package deferred;
use strict;

our $VERSION = "0.01";

# Modules the user has requested to defer
my @enabled;
# Modules we've half loaded
my %half_loaded;

sub import {
  my $class = shift;

  push @enabled, map { ref $_ ? $_ : qr/^$_$/ } @_;
}

sub unimport {
  my $class = shift;

  my $discard = @_ && $_[0] eq '-discard' ? pop : 0;

  if(@_) {
    my @disable = map { ref $_ ? $_ : qr/^$_$/ } @_;

    for my $disable(@disable) {
      @enabled = grep { $_ ne $disable } @enabled;
    }
  } else {
    @enabled = ();

    if(!$discard) {
      for my $class(keys %half_loaded) {
        _load($class);
      }
    }

    %half_loaded = ();
  }
}

unshift @INC, my $inc_ref = sub {
  my(undef, $file) = @_;

  # We get a filename here, we let the user specify a module name, so convert
  # it back.
  (my $module = $file) =~ s{/}{::}g;
  $module =~ s/\.pm$//;

  if(caller =~ /^(?:base|parent)/) {
    # When these modules load something they really do mean it
    return;
  }

  for my $enabled(@enabled) {
    if($module =~ $enabled) {
      $half_loaded{$module} = join ":", (caller)[1,2];

      open my $fh, "<", \"1";
      return $fh;
    }
  }

  return;
};

sub UNIVERSAL::AUTOLOAD {
  my $load = $UNIVERSAL::AUTOLOAD;

  my($class, $method) = ($load =~ /^(.*)::(.*)$/);
  return if $method eq 'DESTROY';

  _load($class) if exists $half_loaded{$class};

  no warnings 'once';
  no strict 'refs';

  if(*{$load}{CODE}) {
    goto &$load;
  } elsif(my $can = $class->can($method)) {
    goto &$can;
  } else {
    # Really doesn't exist
    require Carp;
    Carp::croak("Undefined subroutine/method called ($load)");
  }
}

sub _load {
  my $class = shift;

  # Avoid the need to reimplement @INC searching
  local @INC = grep { !ref || $_ != $inc_ref } @INC;

  (my $file = $class) =~ s{::}{/}g;
  $file .= ".pm";
  local %INC = %INC;
  delete $INC{$file};

  my $orig = delete $half_loaded{$class};
  my $ok = eval { require $file };

  die "deferred load of $class failed (originally loaded at $orig):\n$@"
    if !$ok;
  $ok;
}

1;

__END__