RFC: pragma pragmatic

We all (that's a rough rounded estimate) know about the most important pragma modules - strict and warnings - and maybe also how to turn them on or off, or how to turn on/off a subset of the facilities provided by them. In comparison, few of us know how a pragma really works. I don't either - to know *really* well, I'd have to wade the perl source code, which I won't, for now.

This I know from the docs, if I haven't misread them: the variable $^H is used for hints to the compiler, e.g. how to behave in respect to refs, subs and vars. The hash %^H is used for hints from the compiler to the interpreter, i.e. perl's runtime. The current state of %^H at compile time is stored in the optree (another obscure thing most perl programmers don't care about, but that's what's getting run), so its state can be retrieved at runtime via (caller($level))[10].

We could use that to make the scope of imported functions from some arbitrary package purely lexical, even if that package isn't pragma aware. Here's a shot at this:

Package pragmatic:

package pragmatic;
use 5.10.0;
our $VERSION = 0.01;

our %pragmas; # pragmas currently in effect
our %masked;  # masked symbols while pragma on
our %symbols; # 
our $AUTOLOAD;

sub import {
    shift;            # discard package
    return unless @_; # nothing to do
    my ($mod,@args) = split " ", shift;
    my @caller = caller(1);
    # see if $mod is defined in $caller
    my $callpkg = $caller[0];
    unless (exists $symbols{$callpkg} && exists $symbols{$callpkg}->{$
+mod}) {
        package pragmatic::import {
# bug!      my $loadstr = @args ? "use $mod" : "use $mod qw(@args)";
            my $loadstr = @args ? "use $mod qw(@args)" : "use $mod";
            die $@ unless eval "$loadstr;1";
            my $stash = "$callpkg\::";
            for my $symbol (keys %pragmatic::import::) {
                if (my $code = *{$pragmatic::import::{$symbol}}{CODE})
+{
                    if (${$stash}{$symbol}) {
                        if (ref ${$stash}{$symbol} eq 'CODE') { # vers
+ion > 5.20.2
                            $masked{$callpkg}->{$symbol}
                                = ${$stash}{$symbol};
                        } elsif (*{${$stash}{$symbol}}{CODE}) { # v5.2
+0.2 and lower
                            $masked{$callpkg}->{$symbol}
                                = *{${$stash}{$symbol}}{CODE};
                        }
                    }
                    $symbols{$callpkg}->{$mod}->{$symbol} = $code;
                    *{"$caller\::$symbol"} = \&{"pragmatic::$symbol"};
                }
                delete $pragmatic::import::{$symbol};
            }
        }
    }
    push @{$pragmas{$callpkg}}, $mod
        unless grep {/^$mod$/} @{$pragmas{$callpkg}};
    $^H{"$callpkg/pragma/in_effect"} = 1;
    $^H{"$callpkg/$mod/in_effect"} = 1;
}

sub unimport {
    shift;
    my $mod = shift;
    my $callpkg = (caller)[0];
    if($mod) {
        $^H{"$callpkg/$mod/in_effect"} = 0;
    } else {
        $^H{"$callpkg/pragma/in_effect"} = 0;
    }
}

sub AUTOLOAD {
    $AUTOLOAD =~ s/.*:://;
    my ($callpkg,$file,$line,$hinthash) = (caller(0))[0..2,10];
    if ($hinthash->{"$callpkg/pragma/in_effect"}) {
        # look up symbol in reverse pragma chain for this package
        for my $mod ( reverse @{$pragmas{$callpkg}} ) {
            if (exists $symbols{$callpkg}->{$mod}) {
                if (exists $symbols{$callpkg}->{$mod}->{$AUTOLOAD}) {
                    if ($hinthash->{"$callpkg/$mod/in_effect"}) {
                        goto &{$symbols{$callpkg}->{$mod}->{$AUTOLOAD}
+};
                    } else {
                        die "Undefined subroutine &$callpkg::$AUTOLOAD
+ called at $file line $line\n"
                            unless $masked{$callpkg}->{$AUTOLOAD};
                        goto &{$masked{$callpkg}->{$AUTOLOAD}};
                    }
                }
            }
        }
        die "Undefined subroutine &$callpkg::$AUTOLOAD called at $file
+ line $line\n";
    } else {
        goto &{$masked{$callpkg}->{$AUTOLOAD}};
    }
}
1;
[download]

Usage example:

package Foo;
use 5.10.0;
require Exporter;
@Foo::ISA = qw(Exporter);
our @EXPORT = qw(foo);

sub foo { say "Foo::foo at line ".(caller)[2] }
1;
[download]

#!/usr/bin/perl
use 5.10.0;
sub foo { say "main::foo at line ".(caller)[2] }
use pragmatic Foo;
foo; # line 5
no pragmatic Foo;
foo; # line 7
use pragmatic Foo;
foo; # line 9
no pragmatic;
foo; # line 11
use pragmatic Foo;
foo; # line 13
__END__
Foo::foo at line 5
main::foo at line 7
Foo::foo at line 9
main::foo at line 11
Foo::foo at line 13
[download]

A module imported via pragmatic isn't imported into the caller's namespace, but into the package pragmatic::import. Each symbol from that package is inspected, and after inspection, deleted. If the CODE slot is defined, its content is stored in the hash %symbols for this caller and this package. If a symbol of that name is found in the caller, its CODE slot content is saved to the hash %masked. The caller is given a reference to the undefined subroutine of that name in package pragmatic. At runtime, this triggers AUTOLOAD, where the appropriate subroutine is called, depending on whether the pragma is in effect or not.

This works for exported subroutines only. If a package exports other glob types, they are passed into the caller's namespace, and they aren't managed by pragmatic. I wish there was a way to govern those too.

To be done yet:

a forget(PACKAGE) method which finishes the pragmatic management and stores the stashed subroutines permanently in the caller's namespace
... (fill the blank)

What do you think? Bad idea? useful? Big delirium? Comments welcome.

edit: fixed some bugs

perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'

Back to Meditations