mysubs - lexical subroutines


mysubs documentation Contained in the mysubs distribution.

Index


Code Index:

NAME

Top

mysubs - lexical subroutines

SYNOPSIS

Top

    package MyPragma;

    use base qw(mysubs);

    sub import {
        my $class = shift;

        $class->SUPER::import(
             foo   => sub { ... },
             chomp => \&mychomp
        );
    }

    #!/usr/bin/env perl

    {
        use MyPragma;

        foo(...);
        chomp ...;
    }

    foo(...);  # error: Undefined subroutine &main::foo
    chomp ...; # builtin

DESCRIPTION

Top

mysubs is a lexically-scoped pragma that implements lexical subroutines i.e. subroutines whose use is restricted to the lexical scope in which they are imported or declared.

The use mysubs statement takes a list of key/value pairs in which the keys are subroutine names and the values are subroutine references or strings containing the package-qualified names of the subroutines. In addition, mysubs options may be passed.

The following example summarizes the type of keys and values that can be supplied.

    {
        use mysubs
            foo      => sub ($) { ... },     # anonymous sub value
            bar      => \&bar,               # code ref value
            chomp    => 'main::mychomp',     # sub name value
            dump     => '+Data::Dump::dump', # load Data::Dump
           'My::foo' => \&foo,               # package-qualified sub name
           -autoload => 1,                   # load modules for all sub name values
           -debug    => 1                    # show diagnostic messages
        ;

        foo(...);                            # OK
        prototype('foo')                     # '$'
        My::foo(...);                        # OK
        bar;                                 # OK
        chomp ...;                           # override builtin
        dump ...;                            # override builtin
    }

    foo(...);                                # error: Undefined subroutine &main::foo
    My::foo(...);                            # error: Undefined subroutine &My::foo
    prototype('foo')                         # undef
    chomp ...;                               # builtin
    dump ...;                                # builtin

OPTIONS

Top

mysubs options are prefixed with a hyphen to distinguish them from subroutine names. The following options are supported:

-autoload

If the value is a package-qualified subroutine name, then the module can be automatically loaded. This can either be done on a per-subroutine basis by prefixing the name with a +, or for all named values by supplying the -autoload option with a true value e.g.

    use mysubs
         foo      => 'MyFoo::foo',
         bar      => 'MyBar::bar',
         baz      => 'MyBaz::baz',
        -autoload => 1;
or

    use MyFoo;
    use MyBaz;

    use mysubs
         foo =>  'MyFoo::foo',
         bar => '+MyBar::bar', # autoload MyBar
         baz =>  'MyBaz::baz';

The -autoload option should not be confused with lexical AUTOLOAD subroutines, which are also supported. e.g.

    use mysubs AUTOLOAD => sub { ... };

    foo(); # OK - AUTOLOAD
    bar(); # ditto
    baz(); # ditto

-debug

A trace of the module's actions can be enabled or disabled lexically by supplying the -debug option with a true or false value. The trace is printed to STDERR.

e.g.

    use mysubs
         foo   => \&foo,
         bar   => sub { ... },
        -debug => 1;

METHODS

Top

import

mysubs::import can be called indirectly via use mysubs or can be overridden by subclasses to create lexically-scoped pragmas that export subroutines whose use is restricted to the calling scope e.g.

    package MyPragma;

    use base qw(mysubs);

    sub import {
        my $class = shift;

        $class->SUPER::import(
             foo   => sub { ... },
             chomp => \&mychomp
        );
    }

Client code can then import lexical subs from the module:

    #!/usr/bin/env perl

    {
        use MyPragma;

        foo(...);
        chomp ...;
    }

    foo(...);  # error: Undefined subroutine &main::foo
    chomp ...; # builtin

The import method is implemented as a wrapper around import_for.

import_for

mysubs methods are installed and uninstalled for a particular client of the mysubs library. Typically, this client is identified by its class name i.e. the first argument passed to the mysubs::import method. Note: if mysubs->import is called implicitly (via use mysubs ...) or explicitly, then the client identifier is "mysubs" i.e. mysubs can function as a client of itself.

The import_for method allows an identifier to be specified explicitly without subclassing mysubs e.g.

    package MyPragma;

    use base qw(Whatever); # we can't/don't want to subclass mysubs

    use mysubs (); # don't import anything

    sub import {
        my $class = shift;
        $class->SUPER::import(...); # call Whatever::import
        mysubs->import_for($class, foo => sub { ... }, ...);
    }

The installed subs can then be uninstalled by passing the same identifier to the unimport_for method.

Note that the import_for identifier has nothing to do with the package the lexical subs will be installed into. Lexical subs are always installed into the package specified in the package-qualified sub name, or the package of the currently-compiling scope.

mysubs->import is implemented as a call to mysubs->import_for i.e.

    package MyPragma;

    use base qw(mysubs);

    sub import {
        my $class = shift;
        $class->SUPER::import(foo => sub { ... });
    }

- is equivalent to:

    package MyPragma;

    use mysubs ();

    sub import {
        my $class = shift;
        mysubs->import_for($class, foo => sub { ... });
    }

unimport

mysubs::unimport removes the specified lexical subs from the current scope, or all lexical subs if no arguments are supplied.

    use mysubs foo => \&foo;

    {
        use mysubs
            bar => sub { ... },
            baz => 'Baz::baz';

        foo ...;
        bar(...);
        baz;

        no mysubs qw(foo);

        foo ...;  # error: Undefined subroutine &main::foo

        no mysubs;

        bar(...); # error: Undefined subroutine &main::bar
        baz;      # error: Undefined subroutine &main::baz
    }

    foo ...; # ok

Unimports are specific to the class supplied in the no statement, so pragmas that subclass mysubs inherit an unimport method that only removes the subs they installed e.g.

    {
        use MyPragma qw(foo bar baz);

        use mysubs quux => \&quux;

        foo;
        quux(...);

        no MyPragma qw(foo); # unimports foo
        no MyPragma;         # unimports bar and baz
        no mysubs;           # unimports quux
    }

As with the import method, unimport is implemented as a wrapper around unimport_for.

unimport_for

This method complements the import_for method. i.e. it allows the identifier for a group of lexical subs to be specified explicitly. The identifier should match the one supplied in the corresponding import_for method e.g.

    package MyPragma;

    use mysubs ();

    sub import {
        my $class = shift;
        mysubs->import_for($class, foo => sub { ... });
    }

    sub unimport {
        my $class = shift;
        mysubs->unimport_for($class, @_);
    }

As with the import_for method, the identifier is used to refer to a group of lexical subs, and has nothing to do with the package from which those subs will be uninstalled. As with the import methods, the unimport methods always operate on (i.e. uninstall lexical subs from) the package in the package-qualified sub name, or the package of the currently-compiling scope.

CAVEATS

Top

Lexical subs cannot be called by symbolic reference e.g.

This works:

    use mysubs
        foo      => sub { ... }, 
        AUTOLOAD => sub { ... }
    ;

    my $foo = \&foo;

    foo();    # OK - named
    bar();    # OK - AUTOLOAD
    $foo->(); # OK - reference

This doesn't work:

    use mysubs
        foo      => sub { ... }, 
        AUTOLOAD => sub { ... }
    ;

    my $foo = 'foo';
    my $bar = 'bar';

    no strict 'refs';

    &{$foo}(); # not foo
    &{$bar}(); # not AUTOLOAD

VERSION

Top

1.14

SEE ALSO

Top

* Sub::Lexical
* Method::Lexical

AUTHOR

Top

chocolateboy <chocolate@cpan.org>, with thanks to mst (Matt S Trout), phaylon (Robert Sedlacek), and Paul Fenwick for the idea.

COPYRIGHT AND LICENSE

Top


mysubs documentation Contained in the mysubs distribution.
package mysubs;

use 5.008001;

use strict;
use warnings;

use constant {
    UNDO    => 0,
    REDO    => 1,
};

use B::Hooks::EndOfScope;
use B::Hooks::OP::Annotation;
use B::Hooks::OP::Check;
use Carp qw(croak carp);
use Devel::Pragma qw(ccstash fqname my_hints new_scope on_require);
use Scalar::Util;
use XSLoader;

our $VERSION = '1.14';
our @CARP_NOT = qw(B::Hooks::EndOfScope);

XSLoader::load(__PACKAGE__, $VERSION);

my $DEBUG = xs_get_debug(); # flag indicating whether debug messages should be printed

# The key under which the $installed hash is installed in %^H i.e. 'mysubs'
# Defined as a preprocessor macro in mysubs.xs to ensure the Perl and XS are kept in sync
my $MYSUBS = xs_sig();

# accessors for the debug flags - note there is one for Perl ($DEBUG) and one defined
# in the XS (MYSUBS_DEBUG). The accessors ensure that the two are kept in sync
sub get_debug()   { $DEBUG }
sub set_debug($)  { xs_set_debug($DEBUG = shift || 0) }
sub start_trace() { set_debug(1) }
sub stop_trace()  { set_debug(0) }

# This logs glob transitions i.e. installations and uninstallations of globs - identified
# by their IDs (see below)
sub debug ($$$$$) {
    my ($class, $action, $fqname, $old, $new) = @_; 
    my $glold = glob_id($old);
    my $glnew = glob_id($new);
    carp "$class: $action $fqname ($glold => $glnew)";
}

# The unique identifier for a typeglob - formatted as a hex value
#
# There's a bit of indirection in the GV struct that means we have to reach inside
# it to get the moral equivalent of its Scalar::Util::refaddr(). That's done in XS,
# and this sub pretty-prints it as a hex value
sub glob_id($) {
    sprintf '0x%x', xs_glob_id($_[0]);
}

# return a deep copy of the $installed hash - a hash containing the installed
# subs after any invocation of mysubs::import or mysubs::unimport
#
# the hash is cloned to ensure that inner/nested scopes don't clobber/contaminate
# outer/previous scopes with their new bindings. Likewise, unimport installs
# a new hash to ensure that previous bindings aren't clobbered e.g.
#
#   {
#        package Foo;
#
#        use mysubs bar => sub { ... };
#
#        bar();
#
#        no mysubs; # don't clobber the bindings associated with the previous subroutine call
#   }
#
# The hash and array refs are copied, but the globs are preserved.

# XXX: for some reason, Clone's clone doesn't seem to work here
sub clone($) {
    my $orig = shift;
    return { map { $_ => [ @{$orig->{$_}} ] } keys %$orig };
}

# return true if $ref ISA $class - works with non-references, unblessed references and objects
sub _isa($$) {
    my ($ref, $class) = @_;
    return Scalar::Util::blessed(ref) ? $ref->isa($class) : ref($ref) eq $class;
}

# croak with the name of this package prefixed
sub pcroak(@) {
    croak __PACKAGE__, ': ', @_;
}

# load a perl module
sub load($) {
    my $symbol = shift;
    my $module = (fqname $symbol)[0];
    eval "require $module";
    pcroak "can't load $module: $@" if ($@);
}

# install a clone of the current typeglob for the supplied symbol and add a new CODE entry
# mst++ and phaylon++ for this idea
sub install_sub($$) {
    my ($symbol, $sub) = @_;
    my ($stash, $name) = fqname($symbol);

    no strict 'refs';

    my $old_glob = delete ${"$stash\::"}{$name};

    # create the new glob
    *{"$stash\::$name"} = $sub;

    # copy slots over from the old glob
    if ($old_glob) {
        for my $slot (qw(SCALAR ARRAY HASH IO FORMAT)) {
            *{"$stash\::$name"} = *{$old_glob}{$slot} if (defined *{$old_glob}{$slot});
        }
    }

    return wantarray ? ($old_glob, *{"$stash\::$name"}) : *{"$stash\::$name"};
}

# restore the typeglob that existed before the lexical sub was defined - or delete it if it didn't exist
sub glob_install($$) {
    my ($symbol, $glob) = @_;
    my ($stash, $name) = fqname($symbol);

    no strict 'refs';

    my $old_glob = delete ${"$stash\::"}{$name};
    ${"$stash\::"}{$name} = $glob if ($glob);

    return $old_glob;
}

# this function is used to enter or leave a lexical context, where "context" means a set of
# lexical bindings in the form of globs with or without subroutines in the CODE slot
#
# for each lexical sub, import() creates or augments a hash that stores globs in the UNDO and REDO slots.
# these globs represent the before and after state of the glob corresponding to the supplied
# (fully-qualified) sub name. The UNDO glob is the glob prior to any declaration of a lexical
# sub with that name, and the REDO glob is the currently-active glob, with the most-recently
# defined lexical sub in its CODE slot.
#
# This data is used to clean up around compile-time requires: install is called to uninstall the
# current globs (UNDO); require() is called; then install is called again to reinstall the active
# globs (REDO). this ensures lexical subs don't leak across file boundaries if the current package
# is re-opened in a required file

sub install($$) {
    my ($installed, $action_id) = @_;

    for my $fqname (keys %$installed) {
        my $action = [ 'uninstalling', 'installing' ]->[$action_id];
        my $old_glob = glob_install($fqname, $installed->{$fqname}->[$action_id]);

        debug('mysubs', $action, $fqname, $old_glob, $installed->{$fqname}->[$action_id]) if ($DEBUG);
    }
}

# install one or more lexical subs in the current scope
#
# import() has to keep track of three things:
#
# 1) $installed keeps track of *all* currently active lexical subs so that they can be
#    uninstalled before (compile-time) require() and reinstalled afterwards
# 2) $restore keeps track of *all* active lexical subs in the outer scope
#    so that they can be restored at the end of the current scope
# 3) $unimport keeps track of which subs have been installed by *this* class (which may be a subclass of
#    mysubs) in this scope, so that they can be unimported with "no MyPragma (...)"
#
# In theory, restoration is done in two passes, the first over $installed and the second over $restore:
#
#     1) new/overridden: reinstate all the subs in $installed to their previous state in $restore (if any)
#     2) deleted: reinstate all the subs in $restore that are not defined in $installed (because
#        they were explicitly unimported)
# 
# In practice, as an optimization, an auxilliary hash ($remainder) is used to keep track of the
# elements of $restore that were removed (via unimport) from $installed. This reduces the overhead
# of the second pass so that it doesn't redundantly traverse elements covered by the first pass.

sub import_for {
    my ($class, $namespace, %bindings) = @_;

    # return unless (%bindings);

    my $autoload = delete $bindings{-autoload};
    my $debug = delete $bindings{-debug};
    my $hints = my_hints;
    my $caller = ccstash();
    my $installed;

    if (defined $debug) {
        my $old_debug = get_debug();
        if ($debug != $old_debug) {
            set_debug($debug);
            on_scope_end { set_debug($old_debug) };
        }
    }

    if (new_scope($MYSUBS)) {
        my $top_level = 0;
        my $restore = $hints->{$MYSUBS};

        if ($restore) {
            $installed = $hints->{$MYSUBS} = clone($restore); # clone
        } else {
            $top_level = 1;
            $restore = {};
            $installed = $hints->{$MYSUBS} = {}; # create

            # when a compile-time require (or do FILE) is performed, uninstall all
            # lexical subs (UNDO) and the check hook (xs_leave) beforehand,
            # and reinstate the lexical subs and check hook afterwards

            on_require(
                sub { my $hash = shift; install($hash->{$MYSUBS}, UNDO); xs_leave() },
                sub { my $hash = shift; install($hash->{$MYSUBS}, REDO); xs_enter() }
            );

            xs_enter();
        }

        # keep it around for runtime i.e. prototype()
        xs_cache($installed);

        on_scope_end {
            my $hints = my_hints; # refresh the %^H reference - doesn't work without this
            my $installed = $hints->{$MYSUBS};

            # this hash records (or will record) the lexical subs unimported from
            # the current scope
            my $remainder = { %$restore };

            for my $fqname (keys %$installed) {
                if (exists $restore->{$fqname}) {
                    unless (xs_glob_eq($installed->{$fqname}->[REDO], $restore->{$fqname}->[REDO])) {
                        $class->debug(
                            'restoring (overridden)',
                            $fqname,
                            $installed->{$fqname}->[REDO],
                            $restore->{$fqname}->[REDO]
                        ) if ($DEBUG);
                        glob_install($fqname, $restore->{$fqname}->[REDO]);
                    }
                } else {
                    $class->debug(
                        'deleting',
                        $fqname,
                        $installed->{$fqname}->[REDO],
                        $installed->{$fqname}->[UNDO]
                    ) if ($DEBUG);
                    glob_install($fqname, $installed->{$fqname}->[UNDO]);
                }

                delete $remainder->{$fqname};
            }

            for my $fqname (keys %$remainder) {
                $class->debug(
                    'restoring (unimported)',
                    $fqname,
                    $restore->{$fqname}->[UNDO],
                    $restore->{$fqname}->[REDO]
                ) if ($DEBUG);
                glob_install($fqname, $restore->{$fqname}->[REDO]);
            }
        };

        # disable mysubs altogether when we leave the top-level scope in which it was enabled
        # XXX this must be done here i.e. *after* the scope restoration handler
        on_scope_end \&xs_leave if ($top_level);
    } else {
        $installed = $hints->{$MYSUBS}; # augment
    }

    # Note: the namespace-specific unimport data is stored under a mysubs-flavoured name (e.g. "mysubs(MyPragma)")
    # rather than the unadorned class name (e.g. "MyPragma"). The subclass might well have its own
    # uses for $^H{$namespace}, so we keep our mitts off it
    #
    # Also, the unadorned class name can't be used as the unimport key if the class being used is "mysubs"
    # itself (i.e. "use mysubs qw(...)" rather than "use MyPragma qw(...)") because
    # "mysubs" is already spoken for as the installed hash key ($MYSUBS)

    my $subclass = "$MYSUBS($namespace)";
    my $unimport;

    # never use the $namespace as the identifier for new_scope() - see above
    if (new_scope($subclass)) {
        my $temp = $hints->{$subclass};
        $unimport = $hints->{$subclass} = $temp ? { %$temp } : {}; # clone/create
    } else {
        $unimport = $hints->{$subclass}; # augment
    }

    for my $name (keys %bindings) {
        my $sub = $bindings{$name};

        # normalize bindings
        unless (_isa($sub, 'CODE')) {
            $sub = do {
                load($sub) if (($sub =~ s/^\+//) || $autoload);
                no strict 'refs';
                *{$sub}{CODE}
            } || pcroak "can't find subroutine: '$sub'";
        }

        my $fqname = fqname($name, $caller);
        my ($old, $new) = install_sub($fqname, $sub);

        if (exists $installed->{$fqname}) {
            $class->debug('redefining', $fqname, $old, $new) if ($DEBUG);
            $installed->{$fqname}->[REDO] = $new;
        } else {
            $class->debug('creating', $fqname, $old, $new) if ($DEBUG);
            $installed->{$fqname} = [];
            $installed->{$fqname}->[UNDO] = $old;
            $installed->{$fqname}->[REDO] = $new;
        }

        $unimport->{$fqname} = $new;
    }
}

sub import {
    my $class = shift; # ignore invocant
    $class->import_for($class, @_);
}
   
# uninstall one or more lexical subs from the current scope
sub unimport_for {
    my $class = shift;
    my $namespace = shift;
    my $hints = my_hints;
    my $subclass = "$MYSUBS($namespace)";
    my $unimport;

    return unless (($^H & 0x20000) && ($unimport = $hints->{$subclass}));

    my $caller = ccstash();
    my @subs = @_ ? (map { scalar(fqname($_, $caller)) } @_) : keys(%$unimport);
    my $installed = $hints->{$MYSUBS};
    my $new_installed = clone($installed);
    my $deleted = 0;

    for my $fqname (@subs) {
        my $glob = $unimport->{$fqname};

        if ($glob) { # the glob this module/subclass installed
            # if the current glob ($installed->{$fqname}->[REDO]) is the glob this module installed ($unimport->{$fqname})
            if (xs_glob_eq($glob, $installed->{$fqname}->[REDO])) {
                my $old = $installed->{$fqname}->[REDO];
                my $new = $installed->{$fqname}->[UNDO];

                $class->debug('unimporting', $fqname, $old, $new) if ($DEBUG);
                glob_install($fqname, $installed->{$fqname}->[UNDO]); # restore the glob to its pre-lexical sub state

                # what import adds, unimport taketh away
                delete $new_installed->{$fqname};
                delete $unimport->{$fqname};

                ++$deleted;
            } else {
                carp "$namespace: attempt to unimport a shadowed lexical sub: $fqname";
            }
        } else {
            carp "$namespace: attempt to unimport an undefined lexical sub: $fqname";
        }
    }

    if ($deleted) {
        xs_cache($hints->{$MYSUBS} = $new_installed);
    }
}

sub unimport {
    my $class = shift;
    $class->unimport_for($class, @_);
}

1;

__END__