6 files changed, 181 insertions(+), 46 deletions(-)

M Makefile
M lib/Lang/Go/Mod.pm
M t/01-sample.t
M t/02-fail.t
A t/02-retract.t
M t/samples/01/go.mod

@@ 4,7 4,7 @@ WORKDIR = /perl
 DOCKER_RUN = docker run --rm -it -v $(CWD):$(WORKDIR) -w $(WORKDIR)
 DZIL = dzil
 TEST_RUNNER = yath
-TIDY = perltidier
+TIDY = perltidier -dws -io
 CRITIC = perlcritic
 CRITIC_ARGS =
 TCRITIC_ARGS = --theme=tests

@@ 16,7 16,7 @@ use Path::Tiny qw(path);
 our $VERSION   = '0.005';
 our $AUTHORITY = 'cpan:bclawsie';
 
-our @EXPORT_OK = qw(read_go_mod parse_go_mod);
+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)';


@@ 31,18 31,18 @@ sub parse_go_mod {
     my $go_mod_content = shift || croak 'use: parse_go_mod(go_mod_content)';
 
     my $m = {};
-    $m->{exclude}   = {};
-    $m->{replace}   = {};
-    $m->{'require'} = {};
-    my ( $excludes, $replaces, $requires ) = ( 0, 0, 0 );
+    for my $k ( 'exclude', 'replace', 'require', 'retracts' ) {
+        $m->{$k} = {};
+    }
+    my ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 0, 0 );
 
-  LINE: for my $line ( split /\n/msx, $go_mod_content ) {
-        next LINE if ( $line =~ /^\s*$/msx );
+    LINE: for my $line ( split /\n/msx, $go_mod_content ) {
+        next LINE if ( $line =~ /^\s*$/x );
         if ($excludes) {
-            if ( $line =~ /^\s*[)]\s*$/msx ) {
+            if ( $line =~ /^\s*[)]\s*$/x ) {
                 $excludes = 0;
             }
-            elsif ( $line =~ /\s*(\S+)\s+(\S+)/msx ) {
+            elsif ( $line =~ /\s*(\S+)\s+(\S+)/x ) {
                 $m->{exclude}->{$1} = [] unless ( defined $m->{exclude}->{$1} );
                 push @{ $m->{exclude}->{$1} }, $2;
             }


@@ 52,10 52,10 @@ sub parse_go_mod {
             next LINE;
         }
         if ($replaces) {
-            if ( $line =~ /^\s*[)]\s*$/msx ) {
+            if ( $line =~ /^\s*[)]\s*$/x ) {
                 $replaces = 0;
             }
-            elsif ( $line =~ /^\s*(\S+)\s+=>\s+(\S+)\s*$/msx ) {
+            elsif ( $line =~ /^\s*(\S+)\s+=>\s+(\S+)\s*$/x ) {
                 croak "duplicate replace for $1"
                   if ( defined $m->{replace}->{$1} );
                 $m->{replace}->{$1} = $2;


@@ 66,10 66,10 @@ sub parse_go_mod {
             next LINE;
         }
         if ($requires) {
-            if ( $line =~ /^\s*[)]\s*$/msx ) {
+            if ( $line =~ /^\s*[)]\s*$/x ) {
                 $requires = 0;
             }
-            elsif ( $line =~ /^\s*(\S+)\s+(\S+).*$/msx ) {
+            elsif ( $line =~ /^\s*(\S+)\s+(\S+).*$/x ) {
                 croak "duplicate require for $1"
                   if ( defined $m->{'require'}->{$1} );
                 $m->{'require'}->{$1} = $2;


@@ 79,55 79,93 @@ sub parse_go_mod {
             }
             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;
+        }
 
-        if ( $line =~ /^module\s+(\S+)$/msx ) {
+        # single-line directives
+        if ( $line =~ /^module\s+(\S+)$/x ) {
             $m->{module} = $1;
         }
-        elsif ( $line =~ /^go\s+(\S+)$/msx ) {
+        elsif ( $line =~ /^go\s+(\S+)$/x ) {
             $m->{go} = $1;
         }
-        elsif ( $line =~ /^exclude\s+[(]\s*$/msx ) {
 
-            # beginning of exclude block
-            $excludes = 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 =~ /^replace\s+[(]\s*$/msx ) {
+        elsif ( $line =~ /^require\s+[(]\s*$/x ) {
 
-            # beginning of replace block
-            $replaces = 1;
+         # toggle beginning of require block (and negate the other block checks)
+            ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 1, 0 );
         }
-        elsif ( $line =~ /^require\s+[(]\s*$/msx ) {
+        elsif ( $line =~ /^retract\s+[(]\s*$/x ) {
 
-            # beginning of require block
-            $requires = 1;
+         # toggle beginning of retract block (and negate the other block checks)
+            ( $excludes, $replaces, $requires, $retracts ) = ( 0, 0, 0, 1 );
         }
-        elsif ( $line =~ /^exclude\s+(\S+)\s+(\S+)\s*$/msx ) {
+
+        # 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*$/msx ) {
+        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+).*$/msx ) {
+        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
+# comment
+# (can also be part of a multi-line retract rationale - want to strip out anyway)
 
         }
         else {
-            croak "unknown line content: $line";
+            croak "unparseable line content: $line";
         }
     }
 


@@ 137,6 175,54 @@ sub parse_go_mod {
     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*\[(.+?)\](.*)$/ox ) {    # version-range
+        my $range = $1;
+        my $rest  = $2;
+
+        # trim whitespace from range
+        $range =~ s/\s+//g;
+        my @versions = split( /,/, $range );
+        my $count    = 0;
+        for my $version (@versions) {
+            return unless ( $version =~ /\S+/ox );
+            $count++;
+        }
+        return if ( $count != 2 );
+
+        # if there is a comment, it must be properly formatted
+        if ( $rest =~ /\S/x ) {
+            return unless ( $rest =~ m|^\s+//|ox );
+        }
+        return '[' . $range . ']';
+    }
+    elsif ( $retract =~ /^\s*(\S+)(.*)$/ox ) {    # single version
+        my $version = $1;
+        my $rest    = $2;
+
+        # if there is a comment, it must be properly formatted
+        if ( $rest =~ /\S/x ) {
+            return unless ( $rest =~ m|^\s+//|ox );
+        }
+        return $version;
+    }
+
+    # unparseable retract string
+    return;
+}
+
 1;
 
 __END__

@@ 4,17 4,22 @@ use Test2::V0;
 use Lang::Go::Mod qw(read_go_mod);
 
 my $samples_path = File::Spec->catfile( File::Spec->curdir(), 't',  'samples' );
-my $go_mod_path  = File::Spec->catfile( $samples_path,        '01', 'go.mod' );
+my $go_mod_path  = File::Spec->catfile( $samples_path, '01', 'go.mod' );
 my $m;
 ok(
     lives {
         $m = read_go_mod($go_mod_path);
     }
-) or note($@);
+  ) or note($@);
 
-is( ref($m),      'HASH',                          'returned ref is hash' );
+is( ref($m), 'HASH', 'returned ref is hash' );
 is( $m->{module}, 'github.com/example/my-project', 'module label' );
-is( $m->{go},     '1.16',                          'go version label' );
+is( $m->{go}, '1.16', 'go version label' );
+
+is( $m->{retract}->{'[v1.0.0,v1.2.0]'}, 1, 'retract' );
+is( $m->{retract}->{'v1.3.0'}, 1, 'retract' );
+is( $m->{retract}->{'v1.4.0'}, 1, 'retract' );
+is( $m->{retract}->{'[v1.5.0,v1.6.0]'}, 1, 'retract' );
 
 is( $m->{exclude}->{'example.com/whatmodule'}, ['v1.4.0'], 'exclude' );
 is( $m->{exclude}->{'example.com/thismodule'}, ['v1.3.0'], 'exclude' );

@@ 13,7 13,7 @@ ok(
     dies {
         parse_go_mod($missing_module);
     }
-) or note($@);
+  ) or note($@);
 
 my $missing_go = <<"MISSING_GO";
 $module


@@ 22,7 22,7 @@ ok(
     dies {
         parse_go_mod($missing_go);
     }
-) or note($@);
+  ) or note($@);
 
 # this doesn't fail but demonstrates the "minimum viable go.mod"
 my $minimal = <<"MINIMAL";


@@ 33,7 33,7 @@ ok(
     lives {
         parse_go_mod($minimal);
     }
-) or note($@);
+  ) or note($@);
 
 my $typo_exclude = <<"TYPO_EXCLUDE";
 $minimal


@@ 43,7 43,7 @@ ok(
     dies {
         parse_go_mod($typo_exclude);
     }
-) or note($@);
+  ) or note($@);
 
 my $typo_replace = <<"TYPO_REPLACE";
 $minimal


@@ 53,7 53,7 @@ ok(
     dies {
         parse_go_mod($typo_replace);
     }
-) or note($@);
+  ) or note($@);
 
 my $typo_require = <<"TYPO_REQUIRE";
 $minimal


@@ 63,7 63,7 @@ ok(
     dies {
         parse_go_mod($typo_require);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_exclude = <<"MALFORMED_EXCLUDE";
 $minimal


@@ 73,7 73,7 @@ ok(
     dies {
         parse_go_mod($malformed_exclude);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_replace = <<"MALFORMED_REPLACE";
 $minimal


@@ 83,7 83,7 @@ ok(
     dies {
         parse_go_mod($malformed_replace);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_require = <<"MALFORMED_REQUIRE";
 $minimal


@@ 93,7 93,7 @@ ok(
     dies {
         parse_go_mod($malformed_require);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_multi_exclude = <<"MALFORMED_MULTI_EXCLUDE";
 $minimal


@@ 105,7 105,7 @@ ok(
     dies {
         parse_go_mod($malformed_multi_exclude);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_multi_replace = <<"MALFORMED_MULTI_REPLACE";
 $minimal


@@ 117,7 117,7 @@ ok(
     dies {
         parse_go_mod($malformed_multi_replace);
     }
-) or note($@);
+  ) or note($@);
 
 my $malformed_multi_require = <<"MALFORMED_MULTI_REQUIRE";
 $minimal


@@ 129,7 129,7 @@ ok(
     dies {
         parse_go_mod($malformed_multi_require);
     }
-) or note($@);
+  ) or note($@);
 
 done_testing;
 

@@ 0,0 1,36 @@
+package main;
+use Test2::V0;
+use Lang::Go::Mod qw(_parse_retract);
+
+# missing retract string
+ok(
+    dies {
+        _parse_retract();
+    }
+  ) or note($@);
+
+is( _parse_retract('v1.0.0'),   'v1.0.0', 'basic single version' );
+is( _parse_retract(' v1.0.0 '), 'v1.0.0', 'single version with whitespace' );
+is( _parse_retract(' v1.0.0 // why '),
+    'v1.0.0', 'single version with whitespace and rationale' );
+is( _parse_retract('v1.0.0 # why'), undef, 'bad comment' );
+is( _parse_retract('v1.0.0 / why'), undef, 'bad comment' );
+is( _parse_retract('unknown junk'), undef, 'not valid' );
+is( _parse_retract('// what'),      undef, 'only comment' );
+
+is( _parse_retract('[v1.0.0, v1.1.0]'), '[v1.0.0,v1.1.0]', 'range versions' );
+is( _parse_retract('[ v1.0.0, v1.1.0] '),
+    '[v1.0.0,v1.1.0]', 'range versions with whitespace' );
+is( _parse_retract(' [ v1.0.0, v1.1.0]  // why '),
+    '[v1.0.0,v1.1.0]', 'range versions with whitespace and rationale' );
+is( _parse_retract('[v1.0.0, v1.1.0'), undef, 'range versions missing ]' );
+is( _parse_retract('v1.0.0, v1.1.0]'), undef, 'range versions missing [' );
+is( _parse_retract(' [ v1.0.0, v1.1.0] # why '), undef, 'bad comment' );
+is( _parse_retract(' [ v1.0.0, v1.1.0] / why '), undef, 'bad comment' );
+is( _parse_retract('[v1.0.0, v1.1.0, v1.2.0]'),
+    undef, 'range version count not 2' );
+is( _parse_retract('[v1.0.0]'),  undef, 'range version count not 2' );
+is( _parse_retract('[v1.0.0,]'), undef, 'range version empty' );
+is( _parse_retract('[,v1.0.0]'), undef, 'range version empty' );
+
+done_testing;

@@ 2,6 2,14 @@ module github.com/example/my-project
 
 go 1.16
 
+retract [v1.0.0, v1.2.0] // rationale
+retract v1.3.0 // rationale
+
+retract (
+	v1.4.0 // rationale
+	[v1.5.0, v1.6.0] // rationale
+)
+
 // these are comments
 
 exclude (