#!/usr/bin/env perl

# To paraphrase Voltaire who wrote
#  "Mais dans ce pays-ci il est bon de tuer de tems en tems un Amiral pour encourager les autres."
# we have in its place
#  "But in this company it is good to fire a programmer from time to time to encourage the others."

## no critic (ProhibitPostfixControls,ProhibitUnlessBlocks)
## no critic (RequireExtendedFormatting,RequireDotMatchAnything,RequireLineBoundaryMatching)
## no critic (RequirePodSections,RequireCheckedSyscalls);

use 5.032001;
use warnings;
use Data::Dumper;
use English qw(-no_match_vars);

{; # The useful stuff in in this block!!
    use Params::Validate qw(:all);
    use Path::Tiny;
    use PPI;
    use PPR::X;
    use Scalar::Util qw(blessed);

    my $contents;
    my $verbose;
    my ($PTR,@PACKAGE)=(0,'main','main');
    my $subs;
            sub _subs {
                $PACKAGE[++$PTR]=undef;
                for my $node (shift->children) {
                    next # This should never happen!
                        unless (blessed $node);
                    next # WE don't care about these do we??
                        if ($node->isa('PPI::Statement::Null') || $node->isa('PPI::Token::Comment')
                        || $node->isa('PPI::Token::Whitespace') || $node->isa('PPI::Token::Structure'));

                    printf "%-40s: %s\n",(' > ' x $PTR).$node->class,(' > ' x $PTR).substr($node->content =~ s{ (?&PerlNWS) $PPR::X::GRAMMAR }{ }gxr,0,32)
                        if ($verbose);

                    if ($node->isa('PPI::Statement::Package')) {
                        #say $node->content;
                        $PACKAGE[$PTR]=$node->child(2)->content;
                        }
                    elsif ($node->isa('PPI::Statement::Sub')) {
                        #say $node->content;
                        my $name=$node->child(2)->content;
                        if ($name =~ m{^(.*?)::(\w+)$}) { # name has package
                            #;warn Data::Dumper->new([\$1,\$2],[qw(*1 *2)])->Deepcopy(1)->Indent(1)->Maxdepth(3)->Sortkeys(1)->Dump(),q{ };
                            # The following fails on perl-5.32.1_64
                            #$subs->{''.$1}{''.$}}=$node->content =~ s{ (?&PerlNWS) $PPR::X::GRAMMAR }{ }gxr;
                            # ... so
                            #;warn Data::Dumper->new([\$1,\$2],[qw(*1 *2)])->Deepcopy(1)->Indent(1)->Maxdepth(3)->Sortkeys(1)->Dump(),q{ };
                            my ($package,$sub)=($1,$2);
                            $subs->{$package}{$sub}=(
                                $contents ? $node->content =~ s{ (?&PerlNWS) $PPR::X::GRAMMAR }{ }gxr
                                    : (@{$node->location})[0]
                                );
                            }
                        else {
                            for (my $i=$PTR; $i >= 0; $i--) { # Look for the containing package
                                if (defined $PACKAGE[$i]) {
                                    $subs->{$PACKAGE[$i]}{$name}=(
                                        $contents ? $node->content =~ s{ (?&PerlNWS) $PPR::X::GRAMMAR }{ }gxr
                                            : (@{$node->location})[0]
                                        );
                                    last;
                                    };
                                };
                            };
                        };
                    # See if further processing is needed --- ie if this node leads to a sub declaration
                    _subs($node)
                        if ($node->can('find') && $node->find('PPI::Statement::Sub'));
                    }
                $PTR--;
                return;
                }; # sub _subs:

    sub subs {
        Params::Validate::validate_pos(@_,{ type=>SCALAR|SCALARREF },({}) x $#_);
        my $arg=shift;
        my (%opt_H)=Params::Validate::validate(@_,{ contents=>{ type=>BOOLEAN,default=>0 },verbose=>{ type=>BOOLEAN,default=>0 } });
        $contents=$opt_H{contents};
        $verbose=$opt_H{verbose};
        if (ref $arg eq 'SCALAR') { #  Reference to a string
            unless (${$arg} =~ m{ (?&PerlEntireDocument) $PPR::X::GRAMMAR }x) {
                die q{Invalid Perl code: }.$PPR::X::ERROR->source."\n"
                };
            }
        else { # A Scalar -- hence a file's name
            unless (path($arg)->slurp =~ m{ (?&PerlEntireDocument) $PPR::X::GRAMMAR }x) {
                die q{Invalid Perl code: }.$PPR::X::ERROR->source."\n"
                };
            };
        _subs(PPI::Document->new($arg));
        return $subs;
        }; # sub subs:
    };

my $chunk=do {
    local $INPUT_RECORD_SEPARATOR=undef;
    <DATA>
    };
my $sub_href=subs(\$chunk,contents=>1,verbose=>1);
warn Data::Dumper->new([\$sub_href],[qw(*sub_href)])->Deepcopy(1)->Indent(1)->Maxdepth(3)->Sortkeys(1)->Dump().q{ };
exit;
__DATA__
    sub zero { # main::zero
        say __PACKAGE__.q{::zero};
        };
    package Fee;
    sub one { # Fee::one
        say __PACKAGE__.q{::one};
        };
    package Fi;
    sub two { # Fi::two
        say __PACKAGE__.q{::two};
        };
    { package Fo;
        sub three { # Foo::Three
            say __PACKAGE__.q{::three};
            };
        }; # End of package Foo!
    {;
        say "This block introduces no new package"
        };
    sub Fum::four { # Fum::four
        say __PACKAGE__.q{:four};
        };
    sub four { # Fi::four
        say __PACKAGE__.q{:four};
        };
    package I_smell_the_blood_of_an_Englishman { # Package with a block
        sub five { # I_smell_the_blood_of_an_Englishman::five
            say qq{Fee-fi-fo-fum,\nI smell the blood of an Englishman,\nBe he alive, or be he dead\nI'll grind his bones to make my bread.};
            };
        };