Merge pull request aurutils#1224 from aurutils/perl-playground

`Depends.pm`: add `Depends::tsort`

Author: AladW

lib/aurweb/aur-depends

@@ -13,31 +13,28 @@ my $argv0 = 'depends';
 sub solve {
     my ($targets, $types, $callback, $opt_verify, $opt_provides, $opt_installed) = @_;
 
-    # Retrieve AUR results (JSON -> dict -> extract depends -> repeat until none)
+    # Retrieve AUR information
     my ($results, $pkgdeps, $pkgmap) = recurse($targets, $types, $callback);
 
     # Verify dependency requirements
     my ($dag, $dag_foreign) = graph($results, $pkgdeps, $pkgmap, $opt_verify, $opt_provides);
-    my @removals = ();
+
+    # Targets to be removed from the graph
+    my @to_prune;
 
     # Remove virtual dependencies from dependency graph (#1063)
-    if ($opt_provides) {
-        my @virtual = keys %{$pkgmap};
+    push @to_prune, keys %{$pkgmap} if $opt_provides;
 
-        # XXX: assumes <pkgmap> only contains keys with provides != pkgname
-        @removals = prune($dag, \@virtual);
-    }
     # Remove transitive dependencies for installed targets (#592)
-    # XXX: prune from $dag_foreign as well?
-    if (scalar @{$opt_installed}) {
-        @removals = prune($dag, $opt_installed);
-    }
-    # Remove packages no longer in graph from results
-    if (scalar @removals) {
-        map { delete $results->{$_} } @removals;
+    push @to_prune, @{$opt_installed} if $opt_installed && @{$opt_installed};
+
+    if (@to_prune) {
+        my @removed = prune($dag, \@to_prune);  # mutates $dag
+        delete @{$results}{@removed};           # drop from results
     }
-    # Return $dag for subsequent application of C<prune>
-    return $results, $dag, $dag_foreign;
+
+    # Possible further pruning by the caller
+    return ($results, $dag, $dag_foreign);
 }
 
 # tsv output for usage with aur-sync (aurutils <=10)

makepkg/aurutils.changelog

@@ -1,15 +1,18 @@
 ## 21
 
 * `aur-build`
-  + move local repository sync to `build--sync`
+  + move local repository sync to `build--sync` (#1183)
     - implement file-based locking (`makepkg` implementation)
     - implement `pactrans` upgrade
-  + add `--pool`
+  + add `--pool` (#1213)
 
 * `aur-fetch`
   + support mixed url and pkgbase names (#1104)
   + add trurl(1) as dependency
 
+* `perl`
+  + add `Depends::tsort` (#1224)
+
 ## 20.5
 
 * `aur-build`

perl/AUR/Depends.pm

@@ -7,7 +7,11 @@ use List::Util qw(first);
 use Carp;
 use Exporter qw(import);
 use AUR::Vercmp qw(vercmp);
-our @EXPORT_OK = qw(recurse prune graph);
+
+use constant EX_SUCCESS => 0;
+use constant EX_FAILURE => 1;
+use constant EX_OUT_OF_RANGE => 34;
+our @EXPORT_OK = qw(recurse prune graph tsort);
 our $VERSION = 'unstable';
 
 # Maximum number of calling the callback
@@ -135,12 +139,12 @@ sub recurse {
     # Check if results are available
     if (scalar keys %results == 0) {
         say STDERR __PACKAGE__ . ": no packages found";
-        exit(1);
+        exit EX_FAILURE;
     }
     # Check if request limits have been exceeded
     if ($a == $aur_callback_max) {
         say STDERR __PACKAGE__ . ": total requests: $a (out of range)";
-        exit(34);
+        exit EX_OUT_OF_RANGE;
     }
     return \%results, \%pkgdeps, \%pkgmap;
 }
@@ -227,7 +231,7 @@ sub graph {
         }
     }
     if (not $dag_valid) {
-        exit(1);
+        exit EX_FAILURE;
     }
     return \%dag, \%dag_foreign;
 }
@@ -292,4 +296,65 @@ sub prune {
     return @removals;
 }
 
+=head2 tsort()
+
+Topological sorting adapted from PerlPowerTools.
+
+=Performs depth-first traversal by default.
+
+=over
+
+=item C<$bfs> Perform breadth-first traversal.
+
+=back
+
+=cut
+
+sub tsort {
+    my ($bfs, $input) = @_;
+    $bfs //= 0;
+
+    my %pairs;  # all pairs ($l, $r)
+    my %npred;  # number of predecessors
+    my %succ;   # list of successors
+    my @output;
+
+    if (scalar(@{$input}) % 2 == 1) {
+        say STDERR __PACKAGE__ . ": odd number of tokens";
+        exit EX_FAILURE;
+    }
+
+    while (@{$input}) {
+        my $l = shift @${input};
+        my $r = shift @${input};
+
+        next if defined $pairs{$l}{$r};
+        $pairs{$l}{$r}++;
+        $npred{$l} += 0;
+
+        next if $l eq $r;
+        ++$npred{$r};
+        push @{$succ{$l}}, $r;
+    }
+
+    # create a list of nodes without predecessors
+    my @list = grep {!$npred{$_}} keys %npred;
+
+    while (@list) {
+        $_ = pop @list;
+        push @output, $_;
+
+        foreach my $child (@{$succ{$_}}) {
+            if ($bfs) {     # breadth-first
+                unshift @list, $child unless --$npred{$child};
+            } else {        # depth-first (default)
+                push @list, $child unless --$npred{$child};
+            }
+
+        }
+    }
+    warn "$Program: cycle detected\n" if grep {$npred{$_}} keys %npred;
+
+    return @output;
+}
 # vim: set et sw=4 sts=4 ft=perl: