persona - control which code will be loaded for an execution context

  $ PERSONA=cron perl foo.pl

  foo.pl
  =================
  use persona only_for => '*';  # all modules, maybe regex
  use Foo;

  Foo.pm
  =================
  package Foo;
  # code to be compiled always

  #PERSONA cron || app || book
  # code to be compiled only for the "cron", "app" and "book" personas

  #PERSONA
  # code to be compiled always

  #PERSONA !cron
  # code to be compiled for all personas except "cron"

  #PERSONA !( app || book )
  # code to be compiled for all personas except "app" and "book"

  my $limit = PERSONA eq 'app' ? 100 : 10; # code using the constant

 use persona only_for => 'Foo';

  Foo.pm
  FooBar.pm
  Foo/Bar.pm

  Bar.pm

 use persona only_for => qr/^(?:Foo|Bar)\.pm$/;

 $ PERSONA=cron perl -Mpersona=only_for,Foo script.pl

 #PERSONA backoffice
 sub override_access { # only for the back office persona
     # code...
 }
 #PERSONA
 sub has_access {      # for all personas
     # code...
 }

 #PERSONA !cron
 sub not_for_cron {
     # code...
 }
 #PERSONA

 #PERSONA cron || backoffice
 sub for_cron_and_backoffice {
     # code...
 }
 PERSONA

 #PERSONA !( app || book )
 sub not_for_app_or_book {
     # code...
 }
would make the subroutine C<not_for_app_or_book> available for all personas
B<except> C<app> and C<book>.

 use persona only_for => '*';

 use persona only_for => 'Foo', only_for => 'Bar';

  use strict;
  use persona;  # compilation error without this
  print "Running code for persona " . PERSONA . "\n"
    if PERSONA;

  __PACKAGE__->columns( All => ( PERSONA eq 'backoffice' ? @all : @subset ) );

 $ perl -Mpersona=cron bar.pl

 $ perl -Mpersona=only_for,*,persona,cron bar.pl

 use persona 'cron';

 perldoc -f require

 my $source_ref = persona->path2source($path);  # current persona

 my ( $source_ref, $skipped ) = persona->path2source( $path, $persona );

 (none)

  (skipped %d lines for persona '%s')

package persona;

# be as strict and verbose as possible
use strict;
use warnings;

# set version info
our $VERSION  = '0.10';

# modules that we need
use List::Util qw( first );

# persona and semaphore to indicate @INC watcher is installed for this process
my $process_persona;

# regular expression to check
my $all;
my @only_for;

# are we debugging?
BEGIN {
    my $debug = $ENV{DEBUG} || 0;
    $debug = 0 if $debug !~ m#^[0-9]+$#; ## only numeric constants
    eval "sub DEBUG () { $debug }";
}    #BEGIN

# log pipe if we're debugging
BEGIN {
    *TELL = DEBUG
       ? sub {
             my $format = shift() . "\n";
             printf STDERR $format, @_;
         }
       : sub { };
}    #BEGIN

# satisfy -require-
1;

#-------------------------------------------------------------------------------
#
# Class methods
#
#-------------------------------------------------------------------------------
# path2source
#
# Convert a given handle to source code for a given persona
#
#  IN: 1 class (ignored)
#      2 path
#      3 persona to parse for (default: current)
# OUT: 1 scalar reference to source code or undef
#      2 number of lines skipped (optional)

sub path2source {
    my ( undef, $path, $persona ) = @_;
    $persona = $process_persona if !defined $persona;

    # could not open file, let the outside handle this
    open( my $handle, '<', $path ) or return;
    TELL 'Parsing %s', $path if DEBUG;

    # no persona, so we don't need to do any parsing at all
    if ( !$persona ) {

        # enable slurp mode
        local $/;
        my $source = <$handle>;

        # we're done
        return wantarray ? ( \$source, 0 ) : \$source;
    }

    # initializations
    my $skipped = 0;
    my $done;
    my $active  = 1;
    my $line_nr = 0;
    my $source  = '';

    # until we reach end of file
  LINE:
    while (1) {
        my $line = readline $handle;
        last LINE if !defined $line;

        # seen __END__ or __DATA__, no further looking needed here
        if ($done) {
            $source .= $line;
            next LINE;
        }

        # reached the end of logical code, continue without further looking
        elsif ( $line =~ m#^__(?:DATA|END)__$# ) {  ## syn hilite
            $done = 1;
            $source .= $line;
            next LINE;
        }

        # we've seen a line and want to remember that
        $line_nr++;

        # code for new persona?
        if ( $line =~ m/^#PERSONA\s*(.*)/ ) {
            my $rest = $1;

            # all personas
            if ( !$rest ) {

                # switching from inactive persona to all
                if ( !$active ) {
                    $active = 1;

                    # make sure errors / stack traces have right line info
                    $source .= sprintf "#line %d %s (all personas)\n",
                      $line_nr + 1, $path;

                    # don't bother adding the line with #PERSONA
                    next LINE;
                }
            }

            # we have an expression
            else {

                # huh?
                die "Found illegal characters in PERSONA specification:\n$rest"
                  if $rest =~ m#[^\w\s\(\)\|!]#;

                # change simple list into expression
                1 while $rest =~ s#(?<!\!)(\w+)\s+(\w+)#$1 || $2#;

                # create evallable expression
                my %value = ( $persona => 1 );
                $rest =~ s#(\w+)# $value{$1} || 0 #ge;

                # evaluate expression
                my $ok = eval $rest;
                die "Error in evaluation persona specification:\n'$rest'\n$@"
                  if $@;

                # stop copying code for now
                if ( !$ok ) {
                    $active  = undef;
                }

                # switching from inactive persona to all
                elsif ( !$active ) {
                    $active = 1;

                    # make sure errors / stack traces have right line info
                    $source .=
                      sprintf "#line %d %s (allowed by persona '%s')\n",
                      $line_nr + 1, $path, $persona;

                    # don't bother adding the line with #PERSONA
                    next LINE;
                }
            }
        }

        # we're not doing this line
        $skipped++, next LINE if !$active;

        # new package, make sure it knows about PERSONA if it doesn't yet
        if ( $line =~ m#^\s*package\s+([\w:]+)\s*;# ) {
            no strict 'refs';
            my $sub = $1 . '::PERSONA';
            *{$sub} = \&main::PERSONA if !exists &$sub;
        }

        # we'll do this line
        $source .= $line;
    }
    # show source if *really* debugging
    TELL $source if DEBUG > 2;

    return wantarray ? ( \$source, $skipped ) : \$source;
}    #path2source

#-------------------------------------------------------------------------------
#
# Standard Perl features
#
#-------------------------------------------------------------------------------
# import
#
#  IN: 1 class (ignored)
#      2 .. N attributes

sub import {
    my ( undef, @attr ) = @_;

    # assume we want to set persona if only one parameter
    unshift @attr, 'persona' if @attr == 1;

    # fetch name's name
    my $name = $ENV{ENV_PERSONA} || 'PERSONA';

    # fetch parameters we know
    my @only_for_new;
    my @huh;
    while ( my ( $key, $value ) = splice @attr, 0, 2 ) {

        # setting module specification 
        if ( $key eq 'only_for' ) {
            push @only_for_new, $value;
        }

        # setting persona
        elsif ( $key eq 'persona' ) {

            # huh?
            die "Already have '$process_persona' as persona, "
              . "cannot specify '$value' now"
              if defined $process_persona and $value ne $process_persona;

            $ENV{$name} = $value;
        }

        # don't know what to do with this
        else {
            push @huh, $key;
        }
    }

    # find persona we need to work for
    if ( !defined $process_persona ) {
        $process_persona = $ENV{$name};

        # too bad, we don't have a persona
        $process_persona = '' if !defined $process_persona;

        # force some sanity
        die "Persona may only contain alphanumeric characters,"
          . " e.g. '$process_persona'"
          if $process_persona =~ s#\W##sg;

        # create constant in main (for easy access later)
        die $@ if !eval "sub main::PERSONA () { '$process_persona' }; 1";

        # we have a persona, great!
        if ($process_persona) {

            # install handler if we have a persona
            unshift @INC, \&_inc_handler;

            # we're being called in a script
            if ( !( () = caller(3) )               # only 3 levels below us
                 and ( (caller(0))[1] ne '-e' )    # not a one liner
                 and ( (caller(2))[3] eq '(eval)'  # but an eval at lowest level
               ) ) {

                # make sure we will process this file
                unshift @only_for, qr#^$0$#;  ## syn hilite

                # do the script, but through the @INC handler
                TELL 'Recursively calling script for "%s"', $process_persona
                  if DEBUG;
                do $0;

                # we're done, nothing left to do at this level
                exit;
            }

            TELL 'Interpreting source code as "%s"', $process_persona if DEBUG;
        }
    }

    # extra parameters
    die "Don't know what to do with @{[ sort @huh ]}" if @huh;

    # we have some kind of specification which modules to check
    if (@only_for_new) {

        # normalize all new settings
      ONLY_FOR:
        foreach my $only_for (@only_for_new) {

            # need to check what we have
            if ( my $ref = ref $only_for ) {
                die "Can only handle references of type '$ref'"
                  if $ref ne 'Regexp';
    
                # it's ok
                push @only_for, $only_for;
            }

            # do all and everything
            elsif ( $only_for eq '*' ) {
                $all = 1;
                @only_for = @only_for_new = ();
                TELL "Look for personas in all files" if DEBUG;
                last ONLY_FOR;
            }
    
            # just a string, make it a regexp
            else {
                push @only_for, qr#^$only_for#;
            }
        }

        TELL "Added regular expression for matching file names:\n  %s",
          join( "\n  ", @only_for[ -@only_for_new .. $#only_for ] ),
          if DEBUG and @only_for_new;
    }

    # export constant to the caller if not done so already
    no strict 'refs';
    my $sub = caller() . '::PERSONA';
    *{$sub} = \&main::PERSONA if !exists &$sub;

    return;
} #import

#-------------------------------------------------------------------------------
#
# Internal subroutines
#
#-------------------------------------------------------------------------------
# _inc_handler
#
#  IN: 1 code reference to this sub
#      2 file to look for
# OUT: 1 handle to read source from

sub _inc_handler {
    my ( $self, $file ) = @_;

    # shouldn't handle this file, let require handle it (again)
    if ( !$all and !first { $file =~ m#$_# } @only_for ) {
        TELL 'Not handling %s', $file if DEBUG > 1;
        return undef;
    }

    # can't find ourselves?
    my $first = first { $INC[$_] eq $self } 0 .. $#INC;
    die "Could not find INC handler in @INC" if !defined $first;

    # could not find file, let require handle it (again)
    my $path = first { -e } map { "$INC[$_]/$file" } $first + 1 .. $#INC;
    if ( !$path ) {
        TELL 'Could not find %s', $file if DEBUG > 1;
        return undef;
    }

    # parse the source
    my ( $source, $skipped ) = __PACKAGE__->path2source($path);

    # could not open file, or nothing skipped, let -require- handle it
    return undef if !$source or !$skipped;

    # set %INC correctly
    $path =~ s#^\./##; # normalize just as perl does
    $INC{$file} =
      "$path (skipped $skipped lines for persona '$process_persona')";

    # make sure that __FILE__ will be correct as well
    $$source = "#line 1 $path\n$$source";

    # convert source to handle, so require can handle it
    open( my $require, '<', $source )
      or die "Could not open in-memory source for reading: $!";

    return $require;
}    #_inc_handler

#-------------------------------------------------------------------------------

__END__