File Coverage

blib/lib/Package/MoreUtil.pm

Criterion	Covered	Total	%
statement	75	77	97.4
branch	25	32	78.1
condition	11	19	57.8
subroutine	11	11	100.0
pod	4	4	100.0
total	126	143	88.1

package Package::MoreUtil;

our $DATE = '2019-12-25'; # DATE
our $VERSION = '0.592'; # VERSION

use 5.010001;
use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       package_exists
                       list_package_contents
                       list_package_subs
                       list_subpackages
               );

sub package_exists {
    no strict 'refs';

    my $pkg = shift;

    # opt
    #return unless $pkg =~ /\A\w+(::\w+)*\z/;

    if ($pkg =~ s/::(\w+)\z//) {
        return !!${$pkg . "::"}{$1 . "::"};
    } else {
        return !!$::{$pkg . "::"};
    }
}

# XXX incomplete/improper
sub list_package_contents {
    no strict 'refs';

    my $pkg = shift;

    return () unless !length($pkg) || package_exists($pkg);
    my $symtbl = \%{$pkg . "::"};

    my %res;
    while (my ($k, $v) = each %$symtbl) {
        next if $k =~ /::$/; # subpackage
        my $n;
        if ("$v" !~ /^\*/) {
            # constant
            $res{$k} = $v;
            next;
        }
        if (defined *$v{CODE}) {
            $res{$k} = *$v{CODE}; # subroutine
            $n++;
        }
        if (defined *$v{HASH}) {
            $res{"\%$k"} = \%{*$v}; # hash
            $n++;
        }
        if (defined *$v{ARRAY}) {
            $res{"\@$k"} = \@{*$v}; # array
            $n++;
        }
        if (defined(*$v{SCALAR}) # XXX always defined?
                && defined(${*$v})) { # currently we filter undef values
            $res{"\$$k"} = \${*$v}; # scalar
            $n++;
        }

        if (!$n) {
            $res{"\*$k"} = $v; # glob
        }
    }

    %res;
}

# XXX incomplete/improper too?
sub list_package_subs {
    no strict 'refs';

    my $pkg = shift;

    return () unless !length($pkg) || package_exists($pkg);
    my $symtbl = \%{$pkg . "::"};

    my @res;
    while (my ($k, $v) = each %$symtbl) {
        if (
            ref $v eq 'CODE' || # perl >= 5.22
                defined *$v{CODE}) {
            push @res, $k;
        }
    }

    @res;
}

sub list_subpackages {
    no strict 'refs';

    my ($pkg, $recursive, $cur_res, $ref_mem) = @_;

    return () unless !length($pkg) || package_exists($pkg);

    # this is used to avoid deep recursion. for example (the only one?) %:: and
    # %main:: point to the same thing.
    $ref_mem //= {};

    my $symtbl = \%{$pkg . "::"};
    return () if $ref_mem->{"$symtbl"}++;

    my $res = $cur_res // [];
    for (sort keys %$symtbl) {
        next unless s/::$//;
        my $name = (length($pkg) ? "$pkg\::" : "" ) . $_;
        push @$res, $name;
        list_subpackages($name, 1, $res, $ref_mem) if $recursive;
    }

    @$res;
}

1;
# ABSTRACT: Package-related utilities

__END__