File Coverage

blib/lib/Devel/InPackage.pm

Criterion	Covered	Total	%
statement	54	55	98.1
branch	5	6	83.3
condition	3	15	20.0
subroutine	11	11	100.0
pod	0	2	0.0
total	73	89	82.0

package Devel::InPackage;
BEGIN {
  $Devel::InPackage::VERSION = '0.01';
}
# ABSTRACT: scan a file for package declarations or determine which package a line belongs to
use strict;
use warnings;
use 5.010;

use Carp qw(confess);
use File::Slurp qw(read_file);
use Sub::Exporter -setup => {
    exports => ['in_package', 'scan'],
};

our $VERSION;

my $MODULE = qr/(?[A-Za-z0-9:]+)/;

sub in_package {
    my %args = @_;
    # XXX: hope you don't want to know what package foo is in here:
    # package main;
    # { package Bar;  }
    my $point = delete $args{line} || confess 'need line';

    my $result = 'main';
    my $cb = sub {
        my ($line, $package, %info) = @_;
        my $line_number = $info{line_number};
        if( $line_number >= $point ){
            $result = $package;
            return 0;
        }
        return 1;
    };

    scan( %args, callback => $cb);

    return $result;
}

sub scan {
    my %args = @_;

    my $program = $args{code} //
      ($args{file} && read_file($args{file})) //
        confess 'Need "file" or "code"';

    my $callback = $args{callback} // confess 'Need "callback"';

    # this is very crude, and makes incorrect assumptions about Perl
    # syntax
    my @state = ('main');
    my $line_no = 0;
    while( $program =~ /^(?.+)$/mg ){
        my $line = $+{line};
        my $saved_line = $line;

        # skip comments
        $line =~ s/#(.+)$//;

        while( $line =~ /(?(?:
                                 { |
                                 } |
                                 \bpackage \s+ $MODULE \s* ; |
                                 \b(?:class|role) \s+ $MODULE (.+)? { ))
                        /xg ){
            given($+{token}){
                when('{'){
                    push @state, $state[-1];
                }
                when('}'){
                    confess "Unmatched closing } at $line_no" unless @state > 0;
                    pop @state;
                }
                when(/(package|class|role) ($MODULE)/){
                    push @state, $+{package};
                }
            }
        }

        my $continue_scanning = $callback->( $line, $state[-1], line_number => ++$line_no );
        return if !$continue_scanning; # end early
    }

    return;
}

1;

__END__