SBO::Lib::Repo: separate out repo utils from SBO::Lib

Also adds documentation for the utils.

1 files changed, 382 insertions, 0 deletions

diff --git a/SBO-Lib/lib/SBO/Lib/Repo.pm b/SBO-Lib/lib/SBO/Lib/Repo.pm
new file mode 100644
index 0000000..b4205a6
--- /dev/null
+++ b/SBO-Lib/lib/SBO/Lib/Repo.pm
@@ -0,0 +1,382 @@
+package SBO::Lib::Repo;
+
+use 5.016;
+use strict;
+use warnings;
+
+our $VERSION = '2.0';
+
+use SBO::Lib::Util qw/ %config usage_error get_slack_version script_error open_fh open_read in /;
+
+use Cwd;
+use File::Copy;
+use File::Find;
+use File::Path qw/ make_path remove_tree /;
+use Sort::Versions;
+
+use Exporter 'import';
+
+our @EXPORT_OK = qw{
+  check_git_remote
+  check_repo
+  chk_slackbuilds_txt
+  fetch_tree
+  generate_slackbuilds_txt
+  git_sbo_tree
+  migrate_repo
+  pull_sbo_tree
+  rsync_sbo_tree
+  slackbuilds_or_fetch
+  update_tree
+
+  $distfiles
+  $repo_path
+  $slackbuilds_txt
+};
+
+our %EXPORT_TAGS = (
+  all => \@EXPORT_OK,
+);
+
+=head1 NAME
+
+SBO::Lib::Repo - Routines for downloading and updating the SBo repo.
+
+=head1 SYNOPSIS
+
+  use SBO::Lib::Repo qw/ fetch_tree /;
+
+  fetch_tree();
+
+=head1 VARIABLES
+
+=head2 $distfiles
+
+By default $distfiles is set to C</usr/sbo/distfiles>, and it is where all the
+downloaded sources are kept.
+
+The location depends on the C<SBO_HOME> config setting.
+
+=head2 $repo_path
+
+By default $repo_path is set to C</usr/sbo/repo>, and it is where the
+SlackBuilds.org tree is kept.
+
+The location depends on the C<SBO_HOME> config setting.
+
+=cut
+
+# some stuff we'll need later
+our $distfiles = "$config{SBO_HOME}/distfiles";
+our $repo_path = "$config{SBO_HOME}/repo";
+our $slackbuilds_txt = "$repo_path/SLACKBUILDS.TXT";
+
+=head1 SUBROUTINES
+
+=cut
+
+=head2 check_git_remote
+
+  my $bool = check_git_remote($path, $url);
+
+C<check_git_remote()> will check if the repository at C<$path> is a git
+repository and if so, it will check if it defined an C<origin> remote that
+matches the C<$url>. If so, it will return a true value. Otherwise it will
+return a false value.
+
+=cut
+
+sub check_git_remote {
+  script_error('check_git_remote requires two arguments.') unless @_ == 2;
+  my ($path, $url) = @_;
+  return 0 unless -f "$path/.git/config";
+  my ($fh, $exit) = open_read("$path/.git/config");
+  return 0 if $exit;
+
+  while (my $line = readline($fh)) {
+    chomp $line;
+    if ($line eq '[remote "origin"]') {
+      REMOTE: while (my $remote = readline($fh)) {
+        last REMOTE if $remote =~ /^\[/;
+        return 1 if $remote =~ /^\s*url\s*=\s*\Q$url\E$/;
+        return 0 if $remote =~ /^\s*url\s*=/;
+      }
+    }
+  }
+  return 0;
+}
+
+=head2 check_repo
+
+  my $bool = check_repo();
+
+C<check_repo()> checks if the path in C<$repo_path> exists and is an empty
+directory, and returns a true value if so.
+
+If it exists but isn't empty, it will exit with a usage error.
+
+If it doesn't exist, it will attempt to create it and return a true value. If
+it fails to create it, it will exit with a usage error.
+
+=cut
+
+sub check_repo {
+  if (-d $repo_path) {
+    _race::cond '$repo_path could be deleted after -d check';
+    opendir(my $repo_handle, $repo_path);
+    FIRST: while (my $dir = readdir $repo_handle) {
+      next FIRST if in($dir => qw/ . .. /);
+      usage_error("$repo_path exists and is not empty. Exiting.\n");
+    }
+  } else {
+    eval { make_path($repo_path) }
+      or usage_error("Unable to create $repo_path.\n");
+  }
+  return 1;
+}
+
+=head2 chk_slackbuilds_txt
+
+  my $bool = chk_slackbuilds_txt();
+
+C<chk_slackbuilds_txt()> checks if the file C<SLACKBUILDS.TXT> exists in the
+correct location, and returns a true value if it does, and a false value
+otherwise.
+
+Before the check is made, it attempts to call C<migrate_repo()> so it doesn't
+give a false negative if the repository hasn't been migrated to its sbotools
+2.0 location yet.
+
+=cut
+
+# does the SLACKBUILDS.TXT file exist in the sbo tree?
+sub chk_slackbuilds_txt {
+  if (-f "$config{SBO_HOME}/SLACKBUILDS.TXT") { migrate_repo(); }
+  return -f $slackbuilds_txt ? 1 : undef;
+}
+
+=head2 fetch_tree
+
+  fetch_tree();
+
+C<fetch_tree()> will make sure the C<$repo_path> exists and is empty, and then
+fetch the SlackBuilds.org repository tree there.
+
+If the C<$repo_path> is not empty, it will exit with a usage error.
+
+=cut
+
+sub fetch_tree {
+  check_repo();
+  say 'Pulling SlackBuilds tree...';
+  pull_sbo_tree(), return 1;
+}
+
+=head2 generate_slackbuilds_txt
+
+  my $bool = generate_slackbuilds_txt();
+
+C<generate_slackbuilds_txt()> will generate a minimal C<SLACKBUILDS.TXT> for a
+repository that doesn't come with one. If it fails, it will return a false
+value. Otherwise it will return a true value.
+
+=cut
+
+sub generate_slackbuilds_txt {
+  my ($fh, $exit) = open_fh($slackbuilds_txt, '>');
+  return 0 if $exit;
+
+  opendir(my $dh, $repo_path) or return 0;
+  my @categories =
+    grep { -d "$repo_path/$_" }
+    grep { $_ !~ /^\./ }
+    readdir($dh);
+  close $dh;
+
+  for my $cat (@categories) {
+    opendir(my $cat_dh, "$repo_path/$cat") or return 0;
+    while (my $package = readdir($cat_dh)) {
+      next if in($package => qw/ . .. /);
+      next unless -f "$repo_path/$cat/$package/$package.info";
+      print { $fh } "SLACKBUILD NAME: $package\n";
+      print { $fh } "SLACKBUILD LOCATION: ./$cat/$package\n";
+    }
+    close $cat_dh;
+  }
+  close $fh;
+  return 1;
+}
+
+=head2 git_sbo_tree
+
+  my $bool = git_sbo_tree($url);
+
+C<git_sbo_tree()> will C<git clone> the repository specified by C<$url> to the
+C<$repo_path> if the C<$url> repository isn't already there. If it is, it will
+run C<git fetch && git reset --hard origin>.
+
+If any command fails, it will return a false value. Otherwise it will return a
+true value.
+
+=cut
+
+sub git_sbo_tree {
+  script_error('git_sbo_tree requires an argument.') unless @_ == 1;
+  my $url = shift;
+  my $cwd = getcwd();
+  my $res;
+  if (-d "$repo_path/.git" and check_git_remote($repo_path, $url)) {
+    _race::cond '$repo_path can be deleted after -d check';
+    chdir $repo_path or return 0;
+    $res = eval {
+      die unless system(qw! git fetch !) == 0; # if system() doesn't return 0, there was an error
+      _race::cond 'git repo could be changed or deleted here';
+      die unless system(qw! git reset --hard origin !) == 0;
+      unlink "$repo_path/SLACKBUILDS.TXT";
+      1;
+    };
+  } else {
+    chdir $config{SBO_HOME} or return 0;
+    remove_tree($repo_path) if -d $repo_path;
+    $res = system(qw/ git clone /, $url, $repo_path) == 0;
+  }
+  _race::cond '$cwd could be deleted here';
+  return 1 if chdir $cwd and $res;
+  return 0;
+}
+
+=head2 migrate_repo
+
+  migrate_repo();
+
+C<migrate_repo()> moves an old sbotools 1.x repository to the location it needs
+to be in for sbotools 2.x. This means every directory and file except for the
+C<distfiles> directory in (by default) C</usr/sbo/> gets moved to
+C</usr/sbo/repo>.
+
+=cut
+
+# Move everything in /usr/sbo except distfiles and repo dirs into repo dir
+sub migrate_repo {
+  make_path($repo_path) unless -d $repo_path;
+  _race::cond '$repo_path can be deleted between being made and being used';
+  opendir(my $dh, $config{SBO_HOME});
+  foreach my $entry (readdir($dh)) {
+    next if in($entry => qw/ . .. repo distfiles /);
+    move("$config{SBO_HOME}/$entry", "$repo_path/$entry");
+  }
+  close $dh;
+}
+
+=head2 pull_sbo_tree
+
+  pull_sbo_tree();
+
+C<pull_sbo_tree()> will pull the SlackBuilds.org repository tree from
+C<rsync://slackbuilds.org/slackbuilds/$ver/> or whatever the C<REPO>
+configuration variable has been set to.
+
+C<$ver> is the version of Slackware you're running, provided it is supported,
+or whatever you've set in the C<SLACKWARE_VERSION> configuration variable.
+
+=cut
+
+sub pull_sbo_tree {
+  my $url = $config{REPO};
+  if ($url eq 'FALSE') {
+    my $slk_version = get_slack_version();
+    $url = "rsync://slackbuilds.org/slackbuilds/$slk_version/";
+  } else {
+    unlink($slackbuilds_txt);
+  }
+  my $res = 0;
+  if ($url =~ m!^rsync://!) {
+    $res = rsync_sbo_tree($url);
+  } else {
+    $res = git_sbo_tree($url);
+  }
+
+  my $wanted = sub { chown 0, 0, $File::Find::name; };
+  find($wanted, $repo_path) if -d $repo_path;
+  if ($res and not chk_slackbuilds_txt()) {
+    generate_slackbuilds_txt();
+  }
+}
+
+=head2 rsync_sbo_tree
+
+  my $bool = rsync_sbo_tree($url);
+
+C<rsync_sbo_tree()> syncs the SlackBuilds.org repository to C<$repo_path> from
+the C<$url> provided.
+
+=cut
+
+# rsync the sbo tree from slackbuilds.org to $repo_path
+sub rsync_sbo_tree {
+  script_error('rsync_sbo_tree requires an argument.') unless @_ == 1;
+  my $url = shift;
+  $url .= '/' unless $url =~ m!/$!; # make sure $url ends with /
+  my @info;
+  # only slackware versions above 14.1 have an rsync that supports --info=progress2
+  if (versioncmp(get_slack_version(), '14.1') == 1) { @info = ('--info=progress2'); }
+  my @args = ('rsync', @info, '-a', '--exclude=*.tar.gz', '--exclude=*.tar.gz.asc', '--delete', $url);
+  return system(@args, $repo_path) == 0;
+}
+
+=head2 slackbuilds_or_fetch
+
+  slackbuilds_or_fetch();
+
+C<slackbuilds_or_fetch()> will check if there is a C<SLACKBUILDS.TXT> in the
+C<$repo_path>, and if not, offer to run C<sbosnap fetch> for you.
+
+=cut
+
+# if the SLACKBUILDS.TXT is not in $repo_path, we assume the tree has
+# not been populated there; prompt the user to automagickally pull the tree.
+sub slackbuilds_or_fetch {
+  unless (chk_slackbuilds_txt()) {
+    say 'It looks like you haven\'t run "sbosnap fetch" yet.';
+    print 'Would you like me to do this now? [y] ';
+    if (<STDIN> =~ /^[Yy\n]/) {
+      fetch_tree();
+    } else {
+      say 'Please run "sbosnap fetch"';
+      exit 0;
+    }
+  }
+  return 1;
+}
+
+=head2 update_tree
+
+  update_tree();
+
+C<update_tree()> will check if there is a C<SLACKBUILDS.TXT> in the
+C<$repo_path>, and if not, will run C<fetch_tree()>. Otherwise it will update
+the SlackBuilds.org tree.
+
+=cut
+
+sub update_tree {
+  fetch_tree(), return() unless chk_slackbuilds_txt();
+  say 'Updating SlackBuilds tree...';
+  pull_sbo_tree(), return 1;
+}
+
+=head1 AUTHORS
+
+SBO::Lib was originally written by Jacob Pipkin <j@dawnrazor.net> with
+contributions from Luke Williams <xocel@iquidus.org> and Andreas
+Guldstrand <andreas.guldstrand@gmail.com>.
+
+=head1 LICENSE
+
+The sbotools are licensed under the WTFPL <http://sam.zoy.org/wtfpl/COPYING>.
+
+Copyright (C) 2012-2016, Jacob Pipkin, Luke Williams, Andreas Guldstrand.
+
+=cut
+
+1;