view release on metacpan or  search on metacpan

lib/Strict/Perl.pm  view on Meta::CPAN

        # avoid: Use of reserved word "our" is deprecated
        if (($_[0] =~ /^Use of reserved word "our" is deprecated at /) and exists $INC{'Fake/Our.pm'}) {
            # ignore message
        }

        # ignore wrong warning: Name "main::BAREWORD" used only once
        elsif ($_[0] =~ /Name "main::[A-Za-z_][A-Za-z_0-9]*" used only once:/) {
            if ($] < 5.012) {
                # ignore message
            }
            else {
                $SIG{__DIE__}->(@_);
            }
        }
        else {
            $SIG{__DIE__}->(@_);
        }
    };

    # HACK #55 Show Source Code on Errors in Chapter 6: Debugging of PERL HACKS
    $SIG{__DIE__}  = sub {
        print STDERR __PACKAGE__, ': ';
        print STDERR "$^E\n" if defined($^E);
        print STDERR "$_[0]\n";

        my $i = 0;
        my @confess = ();
        while (my($package,$filename,$line,$subroutine) = caller($i)) {
            push @confess, [$i,$package,$filename,$line,$subroutine];
            $i++;
        }
        for my $confess (reverse @confess) {
            my($i,$package,$filename,$line,$subroutine) = @{$confess};
            next if $package eq __PACKAGE__;
            next if $package eq 'Carp';

            print STDERR "[$i] $subroutine in $filename\n";
            if (open(SCRIPT,$filename)) {
                my @script = (undef,<SCRIPT>);
                close(SCRIPT);
                printf STDERR "%04d: $script[$line-2]", $line-2 if (($line-2) >= 1);
                printf STDERR "%04d: $script[$line-1]", $line-1 if (($line-1) >= 1);
                printf STDERR "%04d* $script[$line+0]", $line+0 if defined($script[$line+0]);
                printf STDERR "%04d: $script[$line+1]", $line+1 if defined($script[$line+1]);
                printf STDERR "%04d: $script[$line+2]", $line+2 if defined($script[$line+2]);
                printf STDERR "\n";
            }
        }
        exit(1);
    };
}

# perl 5.000 or later
sub BEGIN {

    # $SIG{__WARN__}, $SIG{__DIE__}
    _SIG();
}

# perl 5.010 or later
sub UNITCHECK {
}

# perl 5.006 or later
sub CHECK {

    # use warnings;
    _warnings();
}

# perl 5.005 or later
sub INIT {

    # use English; $WARNING = 1;
    $^W = 1;

    # disable prohibited modules
    for my $module (qw(
        Thread.pm
        threads.pm
        encoding.pm
        Switch.pm
    )) {
        if (exists $INC{$module}) {
            die "Deprecate module '$module' used.\n";
        }
    }
}

use vars qw($VERSION_called);
sub VERSION {
    my($self,$version) = @_;
    if ($version != $Strict::Perl::VERSION) {
        my($package,$filename,$line) = caller;
        die "$self $version required--this is version $Strict::Perl::VERSION, stopped at $filename line $line.\n";
    }
    $VERSION_called = 1;
}

sub import {
    my($self) = @_;

    # verify that we're called correctly so that strictures will work.
    if (__FILE__ !~ m{ \b Strict[/\\]Perl\.pm \z}x) {
        my($package,$filename,$line) = caller;
        die "Incorrect use of module '${\__PACKAGE__}' at $filename line $line.\n";
    }

    # must VERSION require
    unless ($VERSION_called) {
        my($package,$filename,$line) = caller;
        die "$self $Strict::Perl::VERSION version required like 'use $self $Strict::Perl::VERSION;', stopped at $filename line $line.\n";
    }

    # use strict;
    _strict();

    # use Fatal qw(...); --- compatible routine
    _Fatal();

    # use autodie qw(...);