File Coverage

blib/lib/persona.pm

Criterion	Covered	Total	%
statement	35	130	26.9
branch	10	82	12.2
condition	2	19	10.5
subroutine	8	14	57.1
pod	0	1	0.0
total	55	246	22.3

package persona;

$VERSION= '0.15';

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

# 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= readline $handle;

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

    # initializations
    my $done;
    my $skipped= 0;
    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#(?

                # 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__