File Coverage

blib/lib/Detect/Module.pm

Criterion	Covered	Total	%
statement	44	54	81.4
branch	17	36	47.2
condition	5	12	41.6
subroutine	11	14	78.5
pod	6	6	100.0
total	83	122	68.0

#!/usr/bin/perl -w

#    Detect::Module - allows autodetection of Perl modules.
#    Copyright (C) 2001  Rudolf Polzer
#
#    This library is free software; you can redistribute it and/or
#    modify it under the terms of the GNU Library General Public
#    License as published by the Free Software Foundation; either
#    version 2 of the License, or (at your option) any later version.
#
#    This library is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#    Library General Public License for more details.
#
#    You should have received a copy of the GNU Library General Public
#    License along with this library; if not, write to the Free
#    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

package Detect::Module;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = ();
@EXPORT_OK = qw(Use Require NewRef Load);
%EXPORT_TAGS = (standard => [@EXPORT_OK]);
$VERSION = '1.2';

my $DEBUG = 0;

sub Debug ($)
{
 $DEBUG = $_[0] ? 1 : 0;
}

my %FAIL;

sub Reset
{
 %FAIL = ();
}

sub Use (@)
{
 for (@_)
 {
  if (exists $FAIL{$_})
  {
   print STDERR "Not trying $_ any more\n"
    if $DEBUG;
   next;
  }
  print STDERR "Trying $_\n"
   if $DEBUG;
  if (/[^A-Za-z0-9\_\:\.]/)
  {
   print STDERR "$_ rejected - invalid characters\n"
    if $DEBUG;
   next;
  }
  my $s = $_;
  return $_
   if eval "require $_;";
  $FAIL{$s} = 1;
  print STDERR "$@\n"
   if $DEBUG;
 }
 die "No module of @{[join ', ', @_]} could be found\n";
}

sub Require (@)
{
 goto &Use;
}

sub NewRef (@)
{
 my $constructor = Use @_;
 return sub (@)
 {
  return eval ('new ' . $constructor . ' @_');
 }
}

sub Load (@)
{
 my $name = Use @_;
 $name or                                                  # new in 1.2
  return undef;
 return bless sub ($$)
 {
  no strict 'refs';
  my $n = "${name}::$_[1]";
  if ($_[0] eq 'CODECHECK')                            # changed in 1.2
  {
   eval
   q{
    require 5.6.1;
    return undef unless exists &$n;
    1;
   }
   or do
   {
    return undef unless exists "${name}::"->{$_[1]};
    # not perfect, but works with pre-5.6.1 versions.
   }
  }
  return \&$n if $_[0] eq 'CODE' || $_[0] eq 'CODECHECK';
  return \%$n if $_[0] eq 'HASH';
  return \@$n if $_[0] eq 'ARRAY';
  return \*$n if $_[0] eq 'GLOB' || $_[0] eq 'HANDLE';
  return \$$n if $_[0] eq 'SCALAR';
  die 'Valid type arguments to Detect::Module::Load()-> are SCALAR,GLOB,HANDLE,ARRAY,HASH,CODE,CODECHECK';
 }, 'Detect::Module::Internal';
}

package Detect::Module::Internal;

use strict;
use vars qw($AUTOLOAD);

sub AUTOLOAD (@)
{
 my @l = caller (1);
 my $o = shift;
 my $f;
 die "Undefined subroutine $AUTOLOAD called from $l[1] at line $l[2].\n"
  unless ref ($o) eq __PACKAGE__
     and $AUTOLOAD =~ /^@{[__PACKAGE__]}::(.*)$/
     and $f = $o->('CODECHECK', $1, 1);
 goto &$f;
}

1;

__END__