view release on metacpan or  search on metacpan

lib/PAX/CodeUnitCompiler.pm  view on Meta::CPAN

        env => $env,
        fallback => $fallback,
    };
}

sub _return_literal_from_source {
    my ($source, $sub_name) = @_;
    my $body = _extract_sub_body($source, $sub_name) or return;
    if ($body =~ /\A\s*return\s+"([^"\\]*(?:\\.[^"\\]*)*)"\s*;\s*\z/s) {
        my $value = $1;
        $value =~ s/\\"/"/g;
        $value =~ s/\\\\/\\/g;
        $value =~ s/\\n/\n/g;
        return {
            type => 'string',
            value => $value,
        };
    }
    if ($body =~ /\A\s*return\s+(-?\d+)\s*;\s*\z/s) {
        return {
            type => 'integer',
            value => 0 + $1,
        };
    }
    return;
}

sub _package_tail_is {
    my ($package, $tail) = @_;
    return 0 unless defined $package;
    return 1 if !defined $tail || $tail eq '';
    return $package =~ /(?:^|::)\Q$tail\E\z/ ? 1 : 0;
}

sub _calls_class_tail {
    my ($body, $class_tail, $method) = @_;
    return 0 unless defined $body && defined $class_tail;
    my $escaped_tail = quotemeta $class_tail;
    my $qualified_tail = qr/(?:[A-Za-z_][A-Za-z0-9_]*::)*$escaped_tail/;

    if (defined $method && $method ne '') {
        my $method_escaped = quotemeta $method;
        return $body =~ /(?:^|[^A-Za-z0-9_])$qualified_tail\s*->\s*\Q$method_escaped\E\s*\(/m ? 1 : 0;
    }
    return $body =~ /(?:^|[^A-Za-z0-9_])$qualified_tail\b/m ? 1 : 0;
}

sub _requires_class_tail {
    my ($body, $class_tail) = @_;
    return 0 unless defined $body && defined $class_tail;
    return $body =~ /^\s*require\s+(?:[A-Za-z_][A-Za-z0-9_]*::)*\Q$class_tail\E\s*;/m ? 1 : 0;
}

sub _sibling_class {
    my ($package, $class) = @_;
    return $package if !defined $class || $class eq '';
    return $package if !defined $package || $package eq '';

    my ($root) = $package =~ m{^(.*)::([^:]+)$};
    $root //= '';
    my @class_parts = split m{::}, $class;
    return join('::', grep { defined && $_ ne '' } $root, @class_parts);
}

sub _related_class_from_source {
    my ($source, $package, $body, $class, %args) = @_;
    return _sibling_class($package, $class) if !defined $class || $class eq '';

    my @methods = @{ $args{methods} || [] };
    for my $scope (grep { defined && $_ ne '' } $body, $source) {
        my $qualified = _qualified_class_in_scope($scope, $class, \@methods);
        return $qualified if defined $qualified && $qualified ne '';
    }

    for my $scope (grep { defined && $_ ne '' } $source, $body) {
        my $imported = _imported_class_in_scope($scope, $class);
        return $imported if defined $imported && $imported ne '';
    }

    return _sibling_class($package, $class);
}

sub _qualified_class_in_scope {
    my ($scope, $class, $methods) = @_;
    return if !defined $scope || !defined $class || $class eq '';
    my $qualified_tail = qr/(?:[A-Za-z_][A-Za-z0-9_]*::)+\Q$class\E/;
    if ($methods && @$methods) {
        for my $method (@$methods) {
            next if !defined $method || $method eq '';
            if ($scope =~ /($qualified_tail)\s*->\s*\Q$method\E\s*\(/m) {
                return $1;
            }
        }
    }
    return $1 if $scope =~ /($qualified_tail)\b/m;
    return;
}

sub _imported_class_in_scope {
    my ($scope, $class) = @_;
    return if !defined $scope || !defined $class || $class eq '';
    return $1 if $scope =~ /^\s*use\s+((?:[A-Za-z_][A-Za-z0-9_]*::)+\Q$class\E)\b/m;
    return $1 if $scope =~ /^\s*require\s+((?:[A-Za-z_][A-Za-z0-9_]*::)+\Q$class\E)\s*;/m;
    return;
}

sub _extract_sub_body {
    my ($source, $sub_name) = @_;
    return if $source !~ /sub\s+\Q$sub_name\E\b[^\{]*\{/g;
    my $start = pos($source);
    my $depth = 1;
    my $i = $start;
    while ($i < length($source)) {
        my $char = substr($source, $i, 1);
        $depth++ if $char eq '{';
        $depth-- if $char eq '}';
        return substr($source, $start, $i - $start) if $depth == 0;
        $i++;
    }
    return;
}