File Coverage

blib/lib/RPerl.pm

Criterion	Covered	Total	%
statement	103	103	100.0
branch	14	16	87.5
condition	10	18	55.5
subroutine	12	12	100.0
pod	0	1	0.0
total	139	150	92.6

use rperltypesconv;  # DEV NOTE, CORRELATION #rp008: import from Exporter for code outside of a package or class

# [[[ HEADER SPECIAL ]]]
package RPerl;
use strict;
use warnings;

# DEV NOTE, CORRELATION #rp016: CPAN's underscore-is-beta (NOT RPerl's underscore-is-comma) numbering scheme utilized here, to preserve trailing zeros
our $VERSION = '2.800000';

#our $VERSION = 20170616;    # NON-RELEASE VERSION NUMBER, OFFICIAL LONGDATE
#our $VERSION = 2017.167;    # NON-RELEASE VERSION NUMBER, OFFICIAL STARDATE

# [[[ CRITICS ]]]
## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls)  # USER DEFAULT 1: allow numeric values & print operator
## no critic qw(ProhibitConstantPragma ProhibitMagicNumbers)  # USER DEFAULT 3: allow constants
## no critic qw(ProhibitExplicitStdin)  # USER DEFAULT 4: allow <STDIN> prompt
## no critic qw(ProhibitStringyEval)  # SYSTEM DEFAULT 1: allow eval()
## no critic qw(RequireInterpolationOfMetachars)  # USER DEFAULT 2: allow single-quoted control characters & sigils

# [[[ INCLUDES ]]]

# NEED FIX: pre-load all RPerl deps instead of only these?
# force pre-loading so they make it into $inc_skip
use parent qw();
use IPC::Cmd;
#use re 'strict';  # doesn't work in all versions of Perl
use re 'taint';  # hopefully doesn't actually do anything!

# actually used in this file
use Data::Dumper;

use Filter::Simple;

$Data::Dumper::Sortkeys = 1;    # Dumper() output must be sorted for lib/RPerl/Tests/Type_Types/* etc.

FILTER { $_ = filter($_) };

use rperlnamespaces;

# DEV NOTE: causes circular (or other weird) dependencies, error "Subroutine import redefined...",
# so we can't use RPerl::diag, RPerl types, or subroutines in this files;
# UPDATE: and yet now it works (and in fact seems required) after further development, gotta love unpredictable high-magic code!  :-/
use RPerl::AfterSubclass;

use Module::ScanDeps;

our $INC_SCANNED = {};    # global variable to avoid repeated calls to scan_deps()

sub filter {
    ( my $input ) = @_;

    my $output = q{};
    my $namespace_root;
    my $package = q{};
    my $package_line = q{};
    my $post_package_lines = q{};
    my $use_parent_line = q{};

        my $dependencies;
    #    my $dependencies_rperl                   = {};
    #    my $dependencies_rperl_package_names     = [];
    #    my $dependencies_nonsystem               = {};
    #    my $dependencies_nonsystem_package_names = [];
    my $inc_skip = {};

    my $rand_serial = rand();

    # pre-generate $inc_skip to use in this file and in Module::ScanDeps::scan_deps()
    foreach my $included_filename_short ( sort keys %INC ) {
#        print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', top of $inc_skip loop, have $included_filename_short = ' . $included_filename_short . "\n";
        $namespace_root = filename_short_to_namespace_root_guess($included_filename_short);
#        print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', in $inc_skip loop, have $namespace_root = ' . $namespace_root . "\n";
        if (( $namespace_root ne q{} )
            and (  ( exists $rperlnamespaces_generated::CORE->{$namespace_root} )
                or ( exists $rperlnamespaces_generated::RPERL_DEPS->{$namespace_root} )
                or ( exists $rperlnamespaces_generated::RPERL->{$namespace_root} ) )
            )
        {
            # DEV NOTE, CORRELATION #rp019: need remove hard-coded allowance of RPerl::Test namespace, at least move to rperlnamespaces.pm or friends
            if ( $namespace_root eq 'RPerl::' ) {
#                $package = filename_short_to_package_guess($included_filename_short);
#                if ( $package !~ /^RPerl::Test/xms ) {
                if ( $included_filename_short !~ /^RPerl[\\\/]Test/xms ) {
#                    print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', in $inc_skip loop, noting-to-skip RPerl non-RPerl::Test $included_filename_short = ' . $included_filename_short . "\n";
                    $inc_skip->{$included_filename_short} = $INC{$included_filename_short};
                }
            }
            else {
#                print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', in $inc_skip loop, noting-to-skip non-RPerl $included_filename_short = ' . $included_filename_short . "\n";
                $inc_skip->{$included_filename_short} = $INC{$included_filename_short};
            }
        }
#        else { print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', in $inc_skip loop, NOT noting-to-skip $included_filename_short = ' . $included_filename_short . "\n"; }
    }
    $inc_skip = { %{$inc_skip}, %{$INC_SCANNED} };
    $package = q{};

#    print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', have $INC_SCANNED = ' . Dumper( $INC_SCANNED ) . "\n";
#    print {*STDERR} 'in RPerl::filter(), have $inc_skip = ' . Dumper( $inc_skip ) . "\n";
#    print {*STDERR} 'in RPerl::filter(), have [sort keys %{$inc_skip}] = ' . Dumper( [ sort keys %{$inc_skip} ] ) . "\n";

    # ORIGINAL PURPOSE: generate $dependencies_rperl & $dependencies_nonsystem
    # NEW PURPOSE: recursively filter all non-skipped dependencies and sub-dependencies
    foreach my $included_filename_short ( sort keys %INC ) {
        if ( not exists $inc_skip->{$included_filename_short} ) {
            $INC_SCANNED->{$included_filename_short} = $INC{$included_filename_short};

#            print {*STDERR} 'in RPerl::filter(), $rand_serial = ' . $rand_serial . ', SCANNING non-system $included_filename_short = ' . $included_filename_short . "\n";

            # DEV NOTE: Easter Egg!!  scan_deps() plus filter() equals recursive source filtering!!!
            $dependencies = scan_deps( files => [ $INC{$included_filename_short} ], skip => { reverse %{$inc_skip} }, recurse => 1, execute => 0 );
#            scan_deps( files => [ $INC{$included_filename_short} ], skip => { reverse %{$inc_skip} }, recurse => 1, execute => 0 );

#            print {*STDERR} 'in RPerl::filter(), have $INC{$included_filename_short} = ' . $INC{$included_filename_short} . ' and $dependencies = ' . Dumper($dependencies) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $INC{$included_filename_short} = ' . $INC{$included_filename_short} . ' and [sort keys %{$dependencies}] = ' . Dumper( [ sort keys %{$dependencies} ] ) . "\n";

        }
#        else { print {*STDERR} 'in RPerl::filter(), SKIPPING system $included_filename_short = ' . $included_filename_short . "\n"; }
    }

#    print {*STDERR} 'in RPerl::filter(), have $INC_SCANNED = ' . Dumper( $INC_SCANNED ) . "\n";
    #    print {*STDERR} 'in RPerl::filter(), have %INC = ' . Dumper( \%INC ) . "\n";
    #    print {*STDERR} 'in RPerl::filter(), have [sort keys %{$dependencies_rperl}] = ' . Dumper(     [ sort keys %{$dependencies_rperl} ] ) . "\n";
    #    print {*STDERR} 'in RPerl::filter(), have [sort keys %{$dependencies_nonsystem}] = ' . Dumper( [ sort keys %{$dependencies_nonsystem} ] ) . "\n";

    #    print {*STDERR} 'in RPerl::filter(), have $dependencies_rperl = ' . Dumper($dependencies_rperl) . "\n";
    #    print {*STDERR} 'in RPerl::filter(), have $dependencies_nonsystem = ' . Dumper($dependencies_nonsystem) . "\n";

#    print {*STDERR} "\n" . 'in RPerl::filter(), have pre-modification $input = ' . "\n" . '<<<<<<<<<<<<<<<<================ BEGIN INPUT FILE ================>>>>>>>>>>>>>>' . "\n" . $input . "\n" . '<<<<<<<<<<<<<<<<================ END INPUT FILE ================>>>>>>>>>>>>>>' . "\n\n";

    # look for all user-defined classes, create subclasses
    foreach my $input_line ( split /\n/, $input ) {
#        print {*STDERR} 'in RPerl::filter(), have $input_line = ' . $input_line . "\n";

        if ( $input_line =~ /^\s*package\s+(.*)\s*;/xms ) {
            # not all packages are classes
            $package_line = $input_line;
            $package = $1;
            $post_package_lines = q{};
            $output .= '# [[[ HEADER, PART 1 ]]]' . "\n";
            $output .= $input_line . "\n";
            $output .= 'use rperltypesconv;' . "\n";  # DEV NOTE, CORRELATION #rp008: import from Exporter for code inside of a package or class
            $output .= 'use RPerl::Config;' . "\n";  # DEV NOTE, CORRELATION #rp034: enable @ARG in all packages (class & non-class)

#            print {*STDERR} 'in RPerl::filter(), found $package_line = ' . $package_line . "\n";
#            print {*STDERR} 'in RPerl::filter(), found $package = ' . $package . "\n";
        }
        elsif ( ( $input_line =~ /^\s*use\s+parent/xms ) and ( $package ne q{} ) ) {
            # all classes are packages
            $use_parent_line = $input_line;
            $namespace_root = package_to_namespace_root($package);

#            print {*STDERR} q{in RPerl::filter(), have $package = '} . $package . "'\n";
#            print {*STDERR} q{in RPerl::filter(), have $namespace_root = '} . $namespace_root . "'\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::CORE = ' . Dumper($rperlnamespaces_generated::CORE) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::RPERL_DEPS = ' . Dumper($rperlnamespaces_generated::RPERL_DEPS) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::RPERL = ' . Dumper($rperlnamespaces_generated::RPERL) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::CORE->{' . $namespace_root . '} = ' . Dumper($rperlnamespaces_generated::CORE->{$namespace_root}) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::RPERL_DEPS->{' . $namespace_root . '} = ' . Dumper($rperlnamespaces_generated::RPERL_DEPS->{$namespace_root}) . "\n";
#            print {*STDERR} 'in RPerl::filter(), have $rperlnamespaces_generated::RPERL->{' . $namespace_root . '} = ' . Dumper($rperlnamespaces_generated::RPERL->{$namespace_root}) . "\n";

            # DEV NOTE, CORRELATION #rp019: need remove hard-coded allowance of RPerl::Test namespace, at least move to rperlnamespaces.pm or friends
            if (
                ($package =~ /RPerl::Test/xms) or
                ($package eq 'RPerl::CompileUnit::Module::Class::Template') or (
                    ( not exists $rperlnamespaces_generated::CORE->{$namespace_root} ) and
                    ( not exists $rperlnamespaces_generated::RPERL_DEPS->{$namespace_root} ) and
                    ( not exists $rperlnamespaces_generated::RPERL->{$namespace_root} ) ) )
            {
#                print {*STDERR} 'in RPerl::filter(), enabling subclasses for $package = ' . $package . "\n";

                my $input_line_prepend = q{};
                $input_line_prepend .= '# <<<=== BEGIN $input_line_prepend ===>>>' . "\n";
#                $input_line_prepend .= 'use RPerl::Config;' . "\n";  # DEV NOTE, CORRELATION #rp034: enable @ARG in all packages (class & non-class)
                $input_line_prepend .= 'use RPerl::AfterSubclass;' . "\n";
                $input_line_prepend .= '1;  # end class, original' . "\n";
                my $subclasses = {
                    '_raw'              => [ 'RPerl::DataType::Modifier::Reference', 'ref' ],
                    '_arrayref'         => [ 'RPerl::DataStructure::Array',          'arrayref' ],
                    '_hashref'          => [ 'RPerl::DataStructure::Hash',           'hashref' ],
                    '::method'          => [ 'RPerl::CodeBlock::Subroutine::Method', 'method' ],
                    '_arrayref::method' => [ 'RPerl::CodeBlock::Subroutine::Method', 'method' ],
                    '_hashref::method'  => [ 'RPerl::CodeBlock::Subroutine::Method', 'method' ],
                };
                $input_line_prepend .= "\n" . '# [[[ SUBCLASSES, AUTO-GENERATED ]]]' . "\n";
                foreach my $subclass_key ( sort keys %{$subclasses} ) {
                    $input_line_prepend .= 'package ' . $package . $subclass_key . ';' . "\n";

                    #                    $input_line_prepend .= 'use strict;' . "\n";
                    #                    $input_line_prepend .= 'use warnings;' . "\n";
                    #                    $input_line_prepend .= 'use RPerl::AfterSubclass;' . "\n";
                    $input_line_prepend .= 'use ' . $subclasses->{$subclass_key}->[0] . ';' . "\n";
                    $input_line_prepend .= 'use parent -norequire, qw(' . $subclasses->{$subclass_key}->[1] . ');' . "\n";
                    $input_line_prepend .= '1;  # end class, auto-generated subclass' . "\n";
                }
                $input_line_prepend .= '# <<<=== END $input_line_prepend ===>>>' . "\n";
                $input_line = $input_line_prepend . "\n";
                $input_line .= '# [[[ HEADER, PART 2 ]]]' . "\n";
                $input_line .= $package_line . "\n";
                $input_line .= '# <<<=== BEGIN $post_package_lines ===>>>' . "\n";
                $input_line .= $post_package_lines;  # append even if we don't enable subclasses
                $input_line .= '# <<<=== END $post_package_lines ===>>>' . "\n";
                $input_line .= $use_parent_line . "\n";

                # DEV NOTE: perl calls filter() but perlcritic does not, '## no critic...' & 'use strict' can be passed to perl but not perlcritic,
                # so we must still put critics & strict in every RPerl file;
                # 'use warnings' is checked by perl but not perlcritic, so it can be passed to perl and not put in every RPerl file;
                #                $input_line .= 'use strict;' . "\n";
                #                $input_line .= 'use warnings;' . "\n";
                $input_line .= 'use RPerl::Config;' . "\n";
                $input_line .= 'use RPerl::AfterSubclass;';

#               print {*STDERR} 'in RPerl::filter(), have modified $input_line = ' . "\n" . $input_line . "\n";
            }
#            else { print {*STDERR} 'in RPerl::filter(), NOT enabling subclasses or RPerl::AfterSubclass for $package = ' . $package . "\n"; }
            $output .= $input_line . "\n";
            $package = q{};
            $package_line = q{};
            $post_package_lines = q{};
        }
        elsif ( $package ne q{} ) {
            $post_package_lines .= $input_line . "\n";
        }
        else {
            $output .= $input_line . "\n";
        }
    }

    # package but not a class
    $output .= $post_package_lines;

    # replace fake SSE infix operators with their actually-overloaded single-character selves
    foreach my $sse_define_pair (['sse_add', '+'], ['sse_sub', '-'], ['sse_mul', '*'], ['sse_div', '/']) {
        $output =~ s/$sse_define_pair->[0]/$sse_define_pair->[1]/gxms;
    }

#    print {*STDERR} "\n" . 'in RPerl::filter(), have post-modification $output = ' . "\n" . '<<<<<<<<<<<<<<<<================ BEGIN OUTPUT FILE ================>>>>>>>>>>>>>>' . "\n" . $output . '<<<<<<<<<<<<<<<<================ END OUTPUT FILE ================>>>>>>>>>>>>>>' . "\n\n";

    return $output;
}

1;    # end of class

__END__
=head1 NAME

RPerl Back-End Module

Restricted Perl, The Optimizing Perl 5 Compiler

=head1 SYNOPSIS

        use RPerl;

=head1 DESCRIPTION

B<RPerl> is a compiler.  For more info:

L<https://github.com/wbraswell/rperl/blob/master/README.md>

=head1 SEE ALSO

L<rperl>

=head1 AUTHOR

B<William N. Braswell, Jr.>

L<mailto:[e-mail]>

=cut