#=====================================================================
+====================
package Ensure ;
#=====================================================================
+====================
use 5.006 ; use v5.8.8 ; # Not tested for anything less
use strict ;
use warnings ;
our $VERSION = '1.01' ; # POD embedded below END
#=====================================================================
+====================
use Exporter () ; # Exporter::import used explicitly
our @EXPORT = qw(import) ;
#=====================================================================
+====================
# Tables of packages and variables known to Ensure
my %packages = () ; # Keys = packages registered for Ensure INIT
+ check
# Values = ref:Stash for registered packages
my %exporters = () ; # Keys = packages which we've seen export st
+uff
# Values = true => package includes IMPLICIT t
+ag
my %no_Ensure = () ; # Keys = packages with things declared no_En
+sure
# Values = [name, name, ...]
my $ensure_errors = 0 ; # Count of errors. Dies at end of Ensure INIT
+ if != 0.
#=====================================================================
+====================
# Manual registration
register(__PACKAGE__) ; # Register ourselves
sub register { # May be used, eg, to register 'main'
my ($p) = @_ ;
$packages{$p} ||= stash($p) ;
} ;
#=====================================================================
+====================
# Two small utilities
sub err { # Issue warning message and increment $ensure_
+errors
warn '+++ ', @_, "\n" ; return $ensure_errors++ ;
} ;
sub suq { # Sort given list and ensure all entries are u
+nique
my %l = map { ($_, undef) } @_ ;
return sort keys %l ;
} ;
#=====================================================================
+====================
# Ensure import
# =============
#
# This will be invoked:
#
# a. when a package does 'use Ensure', which:
#
# - registers the package for the Ensure INIT block checks.
#
# - imports into the package the Ensure::import function.
#
# b. when a package which has done 'use Ensure' is itself used:
#
# - the first time this happens, the package's exports are check
+ed.
#
# - in all cases the import list extensions (:ALL :NONE :IMPLICI
+T) are
# implemented, before jumping to the standard Exporter::import
+.
#
# Requires: $ep -- package which is being imported from ) pa
+ssed to...
# @imports -- import list, from "use Fred (@import) ;" ) ..
+.Exporter::import
#
# Returns: nothing
sub import {
my $ep = $_[0] ;
# If we are running the import on behalf of ourselves, we register i
+mporting package.
if ($ep eq __PACKAGE__) { register(scalar(caller)) ; } ;
# If this is the first time we have seen this package export stuff,
+we run checks
# across the export declarations.
my $implicit = exists($exporters{$ep}) ? $exporters{$ep} : check_exp
+orts($ep) ;
# Now we deal with the import list, if it is not empty
if (scalar(@_) > 1) {
if ($_[1] eq ':ALL') {
# Importing ':ALL' -- replace ':ALL' by contents of @EXPORT and
+@EXPORT_OK
my $st = $packages{$ep} ;
splice( @_, 1, 1, suq(@{stash_value($st, '@EXPORT' ) || []},
@{stash_value($st, '@EXPORT_OK') || []}) )
+ ;
}
elsif ( ($_[1] eq ':NONE') || (!$implicit && ($_[1] eq ':IMPLICIT'
+)) ) {
# Importing ':NONE' or ':IMPLICIT' when no IMPLICIT tag exists.
my $i = 2 ;
while (defined($_[$i]) && ($_[$i] =~ m/^!/)) { $i++ ; } ;
splice(@_, 1, $i-1) ; # Drop :NONE/:IMPLICIT and following '
+!'
# Give up now if nothing left of list
if (scalar(@_) == 1) { return ; } ; # Give up now if nothing lef
+t of list
}
elsif ( $implicit && ($_[1] ne ':IMPLICIT') && ($_[1] !~ m/^!/) )
+{
# Exporting package has 'IMPLICIT' tag and import list a) is not
+ empty,
# and b) does n
+ot start ':IMPLICIT'
# and c) does n
+ot start '!...'
splice(@_, 1, 0, ':IMPLICIT') ;
} ;
} ;
# Now we can proceed to standard import !
goto &Exporter::import ; # As if called in the first place
} ;
#=====================================================================
+====================
# check_exports: run checks across exports & establish whether has 'IM
+PLICIT' tag.
#
# Checks that:
#
# a) everything in @EXPORT & @EXPORT_OK is defined, except where dec
+lared 'no Ensure'
#
# b) everything in %EXPORT_TAGS must appear in @EXPORT or @EXPORT_OK
+.
#
# c) everything in any 'IMPLICIT' tag must appear in @EXPORT.
#
# d) everything in @EXPORT_FAIL must appear in @EXPORT or @EXPORT_OK
+.
#
# Sets $exporters{$ep} = true iff there is an 'IMPLICIT' tag, false ot
+herwise.
#
# NB: to be called the first time the package is seen exporting stuff.
#
# Requires: $ep -- name of package which is exporting stuff -- defa
+ult is caller !
#
# Returns: true => exporting package has an 'IMPLICIT' tag
sub check_exports {
my ($ep) = @_ ;
#-------------------------------------------------------------------
+---------------
# Get the stash for the exporting package -- must be registered alre
+ady !!
my $st = $packages{$ep}
or die "*** Ensure\:\:check_exports: package $ep no
+t registered" ;
#-------------------------------------------------------------------
+---------------
# a) check contents of @EXPORT & @EXPORT_OK, given any 'no Ensure' d
+eclarations
#
# Names in @EXPORT & @EXPORT_OK are checked thus:
#
# * name -- requires: glob{CODE}, SCALAR or REF
# * $name -- requires: glob{SCALAR} to have a defined value
# * @name -- requires: glob{ARRAY}
# * %name -- requires: glob{HASH}
# * &name -- requires: glob{CODE}
# * *name -- requires: the name to exist as glob
#
# Note that the undecorated name works for 5.10.0 and onwards cons
+tant values.
#
# Note that for $name this means that it must have some value othe
+r than 'undef'.
# (This is because it is not possible to distinguish no $name decl
+aration at all
# from a declaration which leaves the value undefined.)
#
# Names declared 'no Ensure' *must* fail the above.
my $exp = stash_value($st, '@EXPORT' ) || [] ;
my $eok = stash_value($st, '@EXPORT_OK') || [] ;
my $nen = $no_Ensure{$ep} || [] ;
# Collect all exports (from EXPORT and EXPORT_OK) & all 'no Ensure'
+names.
my %all_exports = map { ($_, 1) } @$exp, @$eok ;
my %undefined = map { ($_, 1) } @$nen ;
foreach my $name (sort keys %all_exports) {
my ($id, $t) = undecorate($name) ;
my $rv = $st->{$id} ;
if (defined($rv)) {
if (!ref($rv)) {
if ($t eq 'SCALAR') { $rv = *$rv{$t} ; $rv = $$rv ; }
elsif ($t ne 'GLOB') { $rv = *$rv{$t || 'CODE'} ; } ;
}
else {
if ($t ne '') { $rv = undef ; } ;
} ;
} ;
if (exists($undefined{$name})) {
if (defined($rv))
{ err "'$name' in '$ep\' is declared 'no Ensure', but is defin
+ed" ; } ;
}
else {
if (!defined($rv))
{ err "'$name' is exported by '$ep', but is not defined" ; } ;
} ;
} ;
#-------------------------------------------------------------------
+---------------
# b) check that everything in the %EXPORT_TAGS is in @EXPORT or @EXP
+ORT_OK
my $etg = stash_value($st, '%EXPORT_TAGS') ;
if ($etg) {
foreach my $name (suq(map { @$_ } values %$etg)) {
if (!exists($all_exports{$name})) {
err "'$name' is in '$ep\'s \%EXPORT_TAGS, but not in \@EXPORT
+or \@EXPORT_OK\n" ;
} ;
} ;
} ;
#-------------------------------------------------------------------
+---------------
# c) check that everything in any %EXPORT_TAGS{IMPLICIT} is in @EXPO
+RT
my $implicit = defined($etg) && exists($$etg{IMPLICIT}) ; # Is there
+ an 'IMPLICIT' tag ?
if ($implicit) {
my %default = map { ($_, 1) } @$exp ; # That which is in @EXPORT
foreach my $name (suq @{$$etg{IMPLICIT}}) {
if (!exists($default{$name})) {
err "'$name' is in '$ep\'s IMPLICIT tag list, but not in \@EXP
+ORT\n" ;
} ;
} ;
} ;
#-------------------------------------------------------------------
+---------------
# d) check that everything in the @EXPORT_FAIL is in @EXPORT or @EXP
+ORT_OK
if ( my $ef = stash_value($st, '@EXPORT_FAIL') ) {
foreach my $name (suq(@$ef)) {
if (!exists($all_exports{$name})) {
err "'$name' is in '$ep\'s \@EXPORT_FAIL, but not in \@EXPORT
+or \@EXPORT_OK\n" ;
} ;
} ;
} ;
#-------------------------------------------------------------------
+---------------
# Done -- record exporting package and whether it has an 'IMPLICIT'
+tag
return $exporters{$ep} = $implicit ;
} ;
#=====================================================================
+====================
# Ensure unimport
# ===============
#
# unimport: mechanics for no Ensure qw(....) ;
#
# no Ensure qw(name $name @name %name &name *name)
#
# The export checks use the full name, complete with decoration. So i
+f you want to
# export an undefined '@name' (for example) you need to be specific.
#
# The INIT checks ignore the decoration. You can say, for example, th
+at you expect
# '$name' to be undefined, the effect is that it is deemed OK if nothi
+ng at all is
# defined for 'name'.
#
# Requires: $self = ourselves (__PACKAGE__) !
# list of possibly decorated names
#
# Returns: nothing
sub unimport {
shift(@_) ; # Discard self
push @{$no_Ensure{scalar(caller)} ||= []}, @_ ;
return 1 ;
} ;
#=====================================================================
+====================
# Post Compile-Time Checks -- the Ensure INIT block
# =================================================
#
# For all packages that have been registered, we look for any complete
+ly undefined
# simple names -- which we treat as undefined subroutine errors, unles
+s declared
# 'no Ensure'.
#
# By simple we mean names starting '_' or alphabetic, excluding a smal
+l number of
# well known names.
INIT {
# These may appear undefined in the stash or are otherwise not worth
+ checking.
# a and b appear if sort is used ?
# MODIFY_xxx_ATTRIBUTES appear and are undefined if a variable is de
+clared ': shared'.
my %except = map { ($_, 1) } (qw(a b BEGIN UNITCHECK CHECK INIT END
DESTROY AUTOLOAD __ANON__
MODIFY_SCALAR_ATTRIBUTES
MODIFY_ARRAY_ATTRIBUTES
MODIFY_HASH_ATTRIBUTES)) ;
# ENV INC ARGV ARGVOUT SIG STDIN STDO
+UT STDERR _)) ;
# Run checks across all registered packages
foreach my $pkg (sort keys(%packages)) {
# Collect any 'no Ensure' names
my %undefined = () ;
if (exists($no_Ensure{$pkg})) {
%undefined = map { s/^[\$@%&*]// ; ($_, 1) } @{$no_Ensure{$pkg}}
+ ;
} ;
# Check the stash for this package
my $stash = $packages{$pkg} ; # Stash for package
NAME: foreach my $name (sort keys %$stash) {
if (($name !~ m/^\w/) || ($name =~ m/^\d/) # Ignore names which
+ are not simple...
|| $except{$name} # ...or which are ex
+ceptional
|| $undefined{$name}) # ...or which are de
+clared 'no Ensure'
{ next NAME ; } ;
my $rv = $stash->{$name} ; # Get the stash entry
# OK if stash entry is ref() -- is 5.10.0 or later 'constant'
if (ref($rv)) { next NAME ; } ;
# OK if glob has a defined {SCALAR} value.
my $rs = *$rv{SCALAR} ;
if (defined($rs) && defined($$rs)) { next NAME ; } ;
# OK if glob has at least one defined type of value.
foreach my $type (qw(ARRAY HASH CODE IO FORMAT)) {
if (defined(*$rv{$type})) { next NAME ; } ;
} ;
# Generate error for name with no defined value
err "$pkg\:\:$name is undefined" ;
} ;
} ;
# Now... if any errors seen by Ensure, give up !
if ($ensure_errors) { die "*** $ensure_errors Ensure errors\n" ; } ;
} ;
#=====================================================================
+====================
# Stash Access
#---------------------------------------------------------------------
+--------------------
# stash: get ref:Stash for given package
#
# Requires: $pkg -- package name -- no trailing '::' -- ASSUMED VAL
+ID
#
# Returns: ref:Stash -- i.e. hash containing symbols for given packag
+e
sub stash {
my ($pkg) = @_ ;
no strict qw(refs) ;
return *{$pkg.'::'}{HASH} or die "\*\*\* Ensure cannot find packag
+e '$pkg'" ;
} ;
#---------------------------------------------------------------------
+--------------------
# stash_value: get value of SCALAR, ARRAY or HASH from given package/s
+tash
#
# Requires: $st -- ref:Stash (as returned by stash())
# $name -- decorated name of value
#
# Returns: value -- if SCALAR and scalar is defined
# ref:Value -- if ARRAY, HASH and value is defined
# undef -- name not found or value not defined
sub stash_value {
my ($st, $name) = @_ ;
my ($id, $type) = undecorate($name) ;
my $rv = $st->{$id} ;
if (defined($rv)) {
if (!ref($rv)) {
$rv = *$rv{$type} ;
if (defined($rv) && ($type eq 'SCALAR')) { $rv = $$rv ; } ;
}
else {
$rv = undef ; # ref:SCALAR or ref:REF => 5.10.0 type constan
+t
} ;
} ;
return $rv ;
} ;
#---------------------------------------------------------------------
+--------------------
# undecorate: remove decoration from name and return explicit type, if
+ any
#
# Requires: $name -- possibly decorated name
#
# Returns: ($id, $type) -- $id = name less any decoration
# $type = if decorated: SCALAR, ARRAY, HAS
+H, CODE or GLOB
# otherwise: ''
my %TYPE = qw($ SCALAR @ ARRAY % HASH & CODE * GLOB) ;
sub undecorate {
my ($id) = @_ ;
my $type = '' ;
if ($id =~ s/^([\$@%&*])//) { $type = $TYPE{$1} ; } ;
return ($id, $type) ;
} ;
#_____________________________________________________________________
+____________________
1 ; # OK -- end of Ensure
__END__
#=====================================================================
+====================
=head1 NAME
Ensure - Perl extension to ensure that things, particularly subroutine
+s, are defined before
a program runs -- to avoid being bitten by C<Undefined subroutine &mai
+n::foo ...>
run-time errors.
C<use strict> will find undefined variables, but not undefined subrout
+ines (except for
bareword subroutine references). You could argue that C<use strict> i
+s incomplete, and
I wouldn't disagree. But in the meantime...
=head1 VERSION
Version 1.01.
=head1 SYNOPSIS
use Ensure ;
which, in a package, is intended to replace:
use Exporter qw(import) ;
=head1 DESCRIPTION
The objective of the Ensure package is to ensure that things are defin
+ed before a program
runs:
=over
=item *
check for undefined subroutines before program runs (as far as possibl
+e).
=item *
check exports are defined when package is used.
=back
First, C<use Ensure> creates an C<INIT> block to check that registered
+ packages are
"complete": looks for names which have no part defined -- probably as
+the result of a
missing subroutine definition or a misspelling of a subroutine name.
All packages which C<use Ensure> are registered for this check.
Second, C<use Ensure> imports the C<Ensure::import> function. This si
+ts on top of the
C<Exporter::import> function, and has two effects:
=over
=item *
the first time the package is itself used, the package's exports are c
+hecked.
(See below for what is checked).
=item *
every time the package is used the import list extensions (C<:ALL>, C<
+:NONE> &
C<:IMPLICIT>) are implemented, before jumping to the standard C<Export
+er::import>.
(See below for what these extensions do.)
=back
Packages that C<use Ensure> do not need to import the C<Exporter::impo
+rt> (and must not).
NB: it would be perverse to C<use Ensure ()>, because that inhibits al
+l of the above.
C<no Ensure> may be used to declare things which are not expected to b
+e defined when
the INIT block checks and the export checks are run.
=head2 The C<INIT> block check
The check scans the registered packages' symbol tables, looking for na
+mes which have no
part defined. This will find most undefined subroutines.
However, a reference to an undefined subroutine, eg C<fred()>, can be
+masked by any other
package (C<our>) variable of the same name -- but not by private (C<my
+>) variables.
This means that:
sub freda { .... } ;
sub bill {
...
fred(...) ;
...
} ;
will be generally be picked up, trapping (a) a missing definition for
+C<fred()>,
or (b) a spelling mistake in C<sub freda>, or (c) a spelling mistake i
+n C<fred(...)>.
However the presence of (for example):
our @fred ;
will mask the use of the undefined subroutine C<fred()>, so the error
+is not trapped.
The effect of:
our $fred ;
is more complicated, because in the special case of C<SCALAR> variable
+s, it is not
possible to tell the difference between a variable that has not been d
+efined at all, and
a variable that has been defined but whose value is C<undef>. So, if
+the value of
C<$fred> is C<undef> when the C<INIT> block is run, it will B<not> mas
+k the presence of
an undefined subroutine C<fred>, but it will if it has any other value
+.
I<[This could be improved if I knew how to spot subroutine names that
+have
been used, but not defined.]>
The check ignores names that do not start with an alphabetic character
+ or C<'_'>. It also
ignores a number of names which appear in package symbol tables and ar
+e often undefined:
a b
BEGIN UNITCHECK CHECK INIT END DESTROY AUTOLOAD __ANON__
MODIFY_SCALAR_ATTRIBUTES MODIFY_ARRAY_ATTRIBUTES MODIFY_HASH_ATT
+RIBUTES
=head3 C<main> package C<SCALAR> variables
Any package (C<our>) C<SCALAR> variables in C<main> need to be declare
+d C<no Ensure>
(unless assigned a value in a C<BEGIN> block).
I<[This could be improved if I knew how to spot scalars that have been
+ declared
but are yet to be assigned a value.]>
=head2 The export checks
The export checks examine the exporting package's C<@EXPORT>, C<@EXPOR
+T_OK>,
C<%EXPORT_TAGS> and C<@EXPORT_FAIL> to ensure that:
=over
=item *
everything in C<@EXPORT> and C<@EXPORT_OK> is defined by the time the
+package is
first used -- or declared C<no Ensure>.
I<This check for definition might have been left to the Ensure> C<INIT
+> I<block.
However, it seems that> C<Exporter::import> I<manages to define things
+, even
if there is no mention of them in the package itself -- so it is essen
+tial
to check before the first use of> C<Exporter::import>I<.>
=item *
everything in C<%EXPORT_TAGS> and in C<@EXPORT_FAIL> must appear in ei
+ther
C<@EXPORT> or C<@EXPORT_OK>.
=item *
if there is a C<IMPLICIT> tag in C<%EXPORT_TAGS>, everything in that t
+ag must
appear in C<@EXPORT> (ie C<IMPLICIT> must be a subset of C<DEFAULT>).
=back
=head2 The import list extensions
The import list extensions are:
=over
=item 1.
C<:NONE> pseudo tag
This is expected to be the B<only> item in the import list. In any ca
+se it should
be the B<first> item.
The purpose of the C<:NONE> tag is to allow for nothing to be imported
+, while still
invoking the C<Ensure::import> function to implement the export checks
+.
When the import list is processed, if the first tag is C<:NONE> it is
+removed, along
with any following '!' items (which are redundant, and would otherwise
+ pull in the
C<:DEFAULT> set).
If the result is an empty list, then C<Exporter::import> will not be i
+nvoked !
It is slightly clearer than C<!:DEFAULT>, though essentially equivalen
+t.
NB: C<!:NONE> has no meaning and will generate an error (unless an act
+ual C<NONE>
tag exists in C<%EXPORT_TAGS>). Similarly C<:NONE> as second or subse
+quent item.
=item 2.
C<:ALL> pseudo tag
If the B<first> item in the import list is C<:ALL>, it will be replace
+d by the
entirity of C<@EXPORT> and C<@EXPORT_OK>.
NB: C<!:ALL> has no meaning and will generate an error (unless an actu
+al C<ALL>
tag exists in C<%EXPORT_TAGS>). Similarly C<:ALL> as second or subseq
+uent item.
=item 3.
C<IMPLICIT> tag -- specifies a minimum, required set of imports/export
+s.
When a package is used the items named in @C<EXPORTS> (aka the C<:DEFA
+ULT> exports) are
automatically exported, except for:
=over
=item 1.
C<use Foo () ; > -- imports nothing. C<Foo-<gt>import> is not
+called at all.
=item 2.
C<use Foo qw(a ...) ;> -- explicitly imports only the named items.
=back
If the exporting package has some subset of the C<:DEFAULT> exports wh
+ich it wants to
export even in case (2), then it can add an C<IMPLICIT> tag to C<%EXPO
+RT_TAGS>,
containing that subset of C<@EXPORTS>.
If the importing package requires the absolute minimum of imports it c
+an do:
use Foo qw(:IMPLICIT) ;
Note that C<:IMPLICIT> can appear as the B<first> tag even if the pack
+age has no
C<IMPLICIT> tag, and will behave as if there was an empty C<IMPLICIT>
+tag.
Note that C<:NONE> will import nothing, not even C<:IMPLICIT> stuff.
NB: C<!:IMPLICIT> has no meaning and will generate an error (unless an
+ actual
C<IMPLICIT> tag exists in C<%EXPORT_TAGS>). Similarly C<:IMPLICIT> as
+ second or
subsequent item.
Any package that uses C<IMPLICIT> should advertise the fact B<clearly>
+.
=back
=head2 no Ensure
Names may be declared as C<no Ensure>, thus:
no Ensure qw(a $a @a %a &a *a ...)
A package may contain a number of C<no Ensure> declarations, each addi
+ng to its list of
C<no Ensure> names.
For the C<INIT> check the decoration is ignored. Any name declared in
+ C<no Ensure> is not
checked when the relevant package is checked.
For the export check the decoration is significant. It is not an erro
+r to export
something which is undefined if that something is declared C<no Ensure
+>. On the other
hand, it is an error to export something which is defined but is also
+declared
C<no Ensure>.
=head1 EXPORT
Exports C<import>. Suggest replacing C<use Exporter qw(import) ;> by
+C<use Ensure ;>.
=head1 SUBROUTINES/METHODS
C<Ensure::register(>I<package>C<)> may be used to register a given I<p
+ackage> for the
C<Ensure INIT> check.
=head1 DIAGNOSTICS
Generates various C<warn> messages when it finds:
=over
=item *
C<'>I<name>C<' in '>I<package>C<' is declared 'no Ensure', but is defi
+ned>
=item *
C<'>I<name>C<' is exported by '>I<package>C<' but is not defined>
=item *
C<'>I<name>C<' is in '>I<package>C<'s %EXPORT_TAGS, but not in @EXPORT
+ or @EXPORT_OK>
=item *
C<'>I<name>C<' is in '>I<package>C<'s IMPLICIT tag list, but not in @E
+XPORT>
=item *
C<'>I<name>C<' is in '>I<package>C<'s @EXPORT_FAIL, but not in @EXPORT
+ or @EXPORT_OK>
=item *
C<'>I<package>C<::>I<name>C<' is undefined>
=back
If any such warnings are issued, the C<Ensure INIT> will C<die> once a
+ll registered
packages have been checked:
=over
=item *
I<n>C< Ensure errors>
=back
=head1 DEPENDENCIES
The C<Ensure::import> function uses the C<Exporter::import> function.
=head1 INCOMPATIBILITIES
None known, but tested only on Perl v5.8.8 and v5.10.0.
=head1 BUGS AND LIMITATIONS
None known.
=head1 AUTHOR
Chris Hall <chris.hall@highwayman.com>
=head1 LICENSE AND COPYRIGHT
Copyright (C) 2008 by Highwayman Associates Ltd. All rights reserved
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
|