File Coverage

blib/lib/Lang/Go/Mod.pm

Criterion	Covered	Total	%
statement	100	102	98.0
branch	77	88	87.5
condition	5	12	41.6
subroutine	9	9	100.0
pod	2	2	100.0
total	193	213	90.6

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Brad Clawsie, 2023 -- [e-mail]

package Lang::Go::Mod;
use warnings;
use strict;
use Carp qw(croak);
use English qw(-no_match_vars);
use Exporter qw(import);
use Path::Tiny qw(path);

# ABSTRACT: parse and model go.mod files

our $VERSION = '0.007';
our $AUTHORITY = 'cpan:bclawsie';

our @EXPORT_OK = qw(read_go_mod parse_go_mod _parse_retract);

sub read_go_mod {
    my $use_msg     = 'use: read_go_mod(go_mod_path)';
    my $go_mod_path = shift || croak $use_msg;

    my $go_mod_content = path($go_mod_path)->slurp_utf8 || croak "$ERRNO";

    return parse_go_mod($go_mod_content);
}

sub parse_go_mod {
    my $go_mod_content = shift || croak 'use: parse_go_mod(go_mod_content)';

    my $m = {};
    for my $k ( 'exclude', 'replace', 'require', 'retracts' ) {
        $m->{$k} = {};
    }
    my ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 0, 0 );

    LINE: for my $line ( split /\n/x, $go_mod_content ) {
        next LINE if ( $line =~ /^\s*$/x );
        if ($excludes) {
            if ( $line =~ /^\s*[)]\s*$/x ) {
                $excludes = 0;
            }
            elsif ( $line =~ /\s*(\S+)\s+(\S+)/x ) {
                $m->{exclude}->{$1} = [] unless ( defined $m->{exclude}->{$1} );
                push @{ $m->{exclude}->{$1} }, $2;
            }
            else {
                croak "malformed exclude line $line";
            }
            next LINE;
        }
        if ($replaces) {
            if ( $line =~ /^\s*[)]\s*$/x ) {
                $replaces = 0;
            }
            elsif ( $line =~ /^\s*(\S+)\s+=>\s+(\S+)\s*$/x ) {
                croak "duplicate replace for $1"
                  if ( defined $m->{replace}->{$1} );
                $m->{replace}->{$1} = $2;
            }
            else {
                croak "malformed replace line $line";
            }
            next LINE;
        }
        if ($requires) {
            if ( $line =~ /^\s*[)]\s*$/x ) {
                $requires = 0;
            }
            elsif ( $line =~ /^\s*(\S+)\s+(\S+).*$/x ) {
                croak "duplicate require for $1"
                  if ( defined $m->{'require'}->{$1} );
                $m->{'require'}->{$1} = $2;
            }
            else {
                croak "malformed require line $line";
            }
            next LINE;
        }
        if ($retracts) {
            if ( $line =~ /^\s*[)]\s*$/x ) {
                $retracts = 0;
            }
            elsif ( $line =~ /^\s*(\S+)(.*)$/x ) {
                my $retract = _parse_retract( $1 . $2 );
                croak "unparseable retract content: $line"
                  unless ( defined($retract) );
                croak "duplicate retract for $retract"
                  if ( defined $m->{retract}->{$retract} );
                $m->{retract}->{$retract} = 1;
            }
            else {
                croak "malformed retract line $line";
            }
            next LINE;
        }

        # single-line directives
        if ( $line =~ /^module\s+(\S+)$/x ) {
            $m->{module} = $1;
        }
        elsif ( $line =~ /^go\s+(\S+)$/x ) {
            $m->{go} = $1;
        }

        # multi-line directive
        elsif ( $line =~ /^exclude\s+[(]\s*$/x ) {

         # toggle beginning of exclude block (and negate the other block checks)
            ( $excludes, $replaces, $requires, $retracts ) = ( 1, 0, 0, 0 );
        }
        elsif ( $line =~ /^replace\s+[(]\s*$/x ) {

         # toggle beginning of replace block (and negate the other block checks)
            ( $excludes, $replaces, $requires, $retracts ) = ( 0, 1, 0, 0 );
        }
        elsif ( $line =~ /^require\s+[(]\s*$/x ) {

         # toggle beginning of require block (and negate the other block checks)
            ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 1, 0 );
        }
        elsif ( $line =~ /^retract\s+[(]\s*$/x ) {

         # toggle beginning of retract block (and negate the other block checks)
            ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 0, 1 );
        }

        # single-line forms of multi-line directives
        elsif ( $line =~ /^exclude\s+(\S+)\s+(\S+)\s*$/x ) {

            # single exclude
            $m->{$1} = [] unless ( defined $m->{exclude}->{$1} );
            push @{ $m->{exclude}->{$1} }, $2;
        }
        elsif ( $line =~ /^replace\s+(\S+)\s+=>\s+(\S+)\s*$/x ) {

            # single replace
            croak "duplicate replace for $1"
              if ( defined $m->{replace}->{$1} );
            $m->{replace}->{$1} = $2;
        }
        elsif ( $line =~ /^require\s+(\S+)+\s+(\S+).*$/x ) {

            # single require
            croak "duplicate require for $1"
              if ( defined $m->{'require'}->{$1} );
            $m->{'require'}->{$1} = $2;
        }
        elsif ( $line =~ /^retract\s+(.+)/x ) {

            # single retract
            my $retract = _parse_retract($1);
            croak "unparseable retract content: $line"
              unless ( defined($retract) );
            croak "duplicate retract for $retract"
              if ( defined $m->{retract}->{$retract} );
            $m->{retract}->{$retract} = 1;
        }
        elsif ( $line =~ m{^\s*//.*$}mx ) {

            # comment - strip
            # (can also be part of a multi-line retract rationale)

        }
        else {
            croak "unparseable line content: $line";
        }
    }

    croak 'missing module line' unless ( defined $m->{module} );
    croak 'missing go line'     unless ( defined $m->{go} );

    return $m;
}

# 'private' sub to extract individual retract lines and strip off the rationale comments
# see: https://go.dev/ref/mod#go-mod-file-retract
#
# rationale comments are stripped out
#
# this sub should only see one line; if a retract rational had multiple lines, like:
# retract v1.0.0 // why
#                // oh why
#
# then the second comment line is caught by the comment match in the loop of parse_go_mod
sub _parse_retract {
    my $retract = shift || croak 'missing retract string';

    if ( $retract =~ /^\s*\[(.+?)\](.*)$/x ) {    # version-range
        my $range = $1;
        my $rest  = $2;

        # trim whitespace from range
        $range =~ s/\s+//gx;
        my @versions = split( /,/x, $range );
        my $count    = 0;
        for my $version (@versions) {
            return undef unless ( $version =~ /\S+/x );
            $count++;
        }
        return undef if ( $count != 2 );

        # if there is a comment, it must be properly formatted
        if ( $rest =~ /\S/x ) {
            return undef unless ( $rest =~ m{^\s+//}ox );
        }
        return '[' . $range . ']';
    }
    elsif ( $retract =~ /^\s*(\S+)(.*)$/x ) {    # single version
        my $version = $1;
        my $rest    = $2;

        # if there is a comment, it must be properly formatted
        if ( $rest =~ /\S/x ) {
            return undef unless ( $rest =~ m{^\s+//}ox );
        }
        return $version;
    }

    # unparseable retract string
    return undef;
}

1;

__END__