110 lines
2.9 KiB
Perl
110 lines
2.9 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# bases
|
|
# Author: Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
|
|
package bases;
|
|
|
|
use strict 'subs', 'vars';
|
|
|
|
sub import {
|
|
my $class = shift;
|
|
my $pkg = caller;
|
|
my $hsh = {@_};
|
|
my @indices = map { $_[$_ * 2] } 0 .. $#_ * 0.5;
|
|
foreach my $base (@indices) {
|
|
next if $pkg->isa($base);
|
|
push @{"$pkg\::ISA"}, $base;
|
|
my $args = '';
|
|
if (my $ref = ref $hsh->{$base}) {
|
|
require GT::Dumper;
|
|
if ($ref eq 'ARRAY') {
|
|
$args = '(@{' . GT::Dumper->dump_structure($hsh->{$base}) . '})';
|
|
}
|
|
else {
|
|
$args = '(' . GT::Dumper->dump_structure($hsh->{$base}) . ')';
|
|
}
|
|
}
|
|
elsif (defined $hsh->{$base}) {
|
|
$args = $hsh->{$base} eq '' ? '()' : "qw($hsh->{$base})";
|
|
}
|
|
my $dcl = qq|
|
|
package $pkg;
|
|
use $base $args;
|
|
|;
|
|
eval $dcl;
|
|
die "$@: $dcl" if $@ && $@ !~ /^Can't locate .*? at \(eval /;
|
|
unless (%{"$base\::"}) {
|
|
require Carp;
|
|
Carp::croak(
|
|
qq|Base class package "$base" is empty.
|
|
String:
|
|
$dcl
|
|
\t(Perhaps you need to 'use' the module which defines that package first.)|
|
|
);
|
|
}
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
base - Establish IS-A relationship with base class at compile time.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
package Baz;
|
|
use bases
|
|
Foo => ':all',
|
|
Bar => ''
|
|
Bat => undef;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Roughly similar in effect to
|
|
|
|
package Baz;
|
|
use Foo qw(:all);
|
|
use Bar();
|
|
use Bat;
|
|
BEGIN { @ISA = qw(Foo Bar Bat) }
|
|
|
|
This is very similar to C<base> pragma except %FIELDS is not
|
|
supported and you are able to pass parameters to import on the
|
|
module that is used in this way.
|
|
|
|
If the value specified is undef, the module being used import method
|
|
will be called if it exists. If the value is an empty string, import
|
|
will not be called.
|
|
|
|
When strict 'vars' is in scope I<bases> also let you assign to @ISA
|
|
without having to declare @ISA with the 'vars' pragma first.
|
|
|
|
If any of the base classes are not loaded yet, I<bases> silently
|
|
C<use>s them. Whether to C<use> a base class package is
|
|
determined by the absence of a global $VERSION in the base package.
|
|
If $VERSION is not detected even after loading it, <base> will
|
|
define $VERSION in the base package, setting it to the string
|
|
C<-1, set by bases.pm>.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $
|
|
|
|
=cut
|
|
|