File Coverage

script/git-perl

Criterion	Covered	Total	%
statement	172	189	91.0
branch	81	108	75.0
condition	18	30	60.0
subroutine	9	9	100.0
pod			n/a
total	280	336	83.3

#!/usr/bin/env perl

our $VERSION = "0.1.18";

# 0.1.14 - 2022-07-21 15:25
#        - further changelogs will be listed in ChangeLog file
# 0.1.13 - 2022-07-21 14:12
#        - fixed finding module listed on cli between recent and real repositories
#        - fixed tests - checking is repository cloned and where it is clone
#        - skip testing for Windows OS / not supported / linux only
#        - add comments in scripts for few tests
#        - fixed stderr leak when reading from nonexisting config file
# 0.1.12 - 2022.07.05
#        - rebuild distribution to fix changes from 0.1.11, related to Kwalitee
# 0.1.11 - 2022.07.05
#        - fixed Kwalitee Issues for distribution
#        - find module name from Makefile.PL in a different way, additionally
# 0.1.10 - 2022.07.03
#        - use HTTP::Tiny instead of curl
# 0.1.9 - 2022.07.03
#       - added tests
# 0.1.8 - 2022.07.03
#       - updated bugtracker link in Makefile.PL
# 0.1.7 - 2022.07.03
#       - added CONTRIBUTING.md
#       - fixed bugtracker in Makefile.PL
# 0.1.6 - 2022.07.03
#       - updated bugtracking/issues link in Makefile.PL
#       - added ChangeLog
# 0.1.5 - 2022.07.02
#       - updated documentation in script/git-perl and README.md to use head1 (head2 looks awful)
# 0.1.4 - 2022.07.02
#       - moved README into README.md, so it can be visible on github and not rendered by metacpan
#       - testing head2 instead of head1 on metacpan/github
# 0.1.3 - 2022.07.02
#       - updated AUTHOR information in README and git-perl
#       - updated link to git-perl from App::Git::Perl
#       - removed required strict and warnings from Makefile.PL
#       - updated Makefile.PL to reflect minimum required Perl version of 5.6.0 (using perlver command)
# 0.1.2 - 2022.07.02
#       - bumped version to 0.1.2, since I forgot to update version in lib/App/Git/Perl.pm
# 0.1.1 - 2022.07.02
#       - remove "use strict", and "use warnings"
#       - updated documentation in README and script/git-perl to show 'git-perl' and not 'git' in metacpan
# 0.1.0 - 2022.07.02
#       - initial commit

my $configfile = "$ENV{HOME}/.config/git-perl.conf";
my $gitdirs;

# init
$gitdirs = config("dir");
$gitdirs = "." if ( not $gitdirs );
system("mkdir -p \"$gitdirs\"") if ( not -d $gitdirs );

sub logger {
  print "LOG: @_\n";
}

sub usage {
  print <<"EOF";

git-perl $VERSION

Created to make you easier to monitor latest changes in perl modules, and make you collaborate faster.
Just put it somewhere in your \$PATH, and call like "git perl".

Prepared by Nedzad Hrnjica.

Usage:

  git perl recent                                     = shows recent list of changes from https://metacpan.org/recent
  git perl log BAYASHI/Object-Container-0.16          = git clone repository and show latest changes
  git perl log BAYASHI/Object-Container-0.16 remove   = remove cloned repository
  git perl log Log::Any                               = git clone repository and show latest changes
  git perl log Log::Any remove                        = remove cloned repository
  git perl clone BAYASHI/Object-Container-0.16        = git clone repository
  git perl clone BAYASHI/Object-Container-0.16 remove = remove cloned repository
  git perl clone Log::Any                             = git clone repository
  git perl clone Log::Any remove                      = remove cloned repository
  git perl local                                      = list cloned repositories
  git perl local object-container-perl                = list cloned repository 'object-container-perl'
  git perl local object-container-perl log            = show latest changes in repository
  git perl local object-container-perl remove         = remove local repository stored in 'object-container-perl'
  git perl local Log::Any                             = git clone repository ( get remote repository locally )
  git perl local Log::Any remove                      = remove cloned repository

  git perl config                                     = show current config ( from ~/.config/git-perl.conf )
  git perl config dir                                 = show value of 'dir' from config
  git perl config dir ~/git/perl                      = set value of 'dir' to '~/git/perl'
  git perl config --unset dir                         = remove variable 'dir' from config file

EOF

}

sub httpget {
  use HTTP::Tiny;

  my $url = shift;
  return "" if not $url;

  my $response = HTTP::Tiny->new->get( $url );

  if ( length $response->{content} ) {
    return $response->{content}
  }

  return "";
}

sub config {
  my ($name,$value) = (shift,shift);

  if ( not $name ) {
    # git perl config
    # show all values from ~/.config/git-perl.conf
    my $output = qx{ cat "$configfile" 2>/dev/null };
    chomp($output);
    return $output;
  }

  if ( not $value ) {
    # git perl config 'something'
    # show value for 'something' from ~/.config/git-perl.conf
    my $value = qx{ cat "$configfile" 2>/dev/null | grep "^$name=" | cut -d"=" -f2- };
    chomp($value);
    return $value;
  }

  # unset ?
  my $unset = 0;
  if ( $name eq "--unset" ) {
    $unset = 1;
    $name = $value;
  }

  # If $name and $value

  if ( $name and $value ) {
    # set value
    qx{ mkdir -p "$ENV{HOME}/.config/" };
    qx{ cat "$configfile" 2>/dev/null | grep -v "^$name=" > "$configfile" };
    qx{ echo "$name=$value" >> "$configfile" } if ( not $unset );

    # If final file is empty, remove it from disk.
    if ( -z "$configfile" ) {
      unlink "$configfile";
    }

    return "";
  }

}

sub clone {
  my $module = shift;
  return if ( not $module );

  if ( $module =~ /::/ ) {
      # That's ok, we will keep this for query.
      # Example: App::Git::Perl
  } else {

      $module =~ s#.*/##;      # keep only last part without any '/'
      $module =~ s/-[0-9].*//; # remove any part after '-number' from distribution
      $module =~ s/-/::/g;     # convert '-' into '::'

      # NHRNJICA/App-Git-Perl-0.1.12
      # App-Git-Perl-0.1.12
      # App-Git-Perl
      # App::Git::Perl
  }

  # https://fastapi.metacpan.org/release/_search?sort=date:desc&q=main_module:%22App::Git::Perl%22%20AND%20status:latest&_source=main_module,resources.repository.url

  my $url = join("", 'https://fastapi.metacpan.org/release/_search?sort=date:desc&q=main_module:%22',$module,'%22%20AND%20status:latest&_source=main_module,resources.repository.url');

  logger("Getting repository details from '$url'...");

  my $content = httpget( $url );

  my $repository = "";
  if ( $content =~ /"resources".* "repository".* "url" : "([^"]*)"/s ) {
    $repository = $1;
  }

  logger("REPOSITORY: [$repository]");

  if ( not $repository ) {
    logger("ERROR: Respository for module '$module' does not exist!");
    return;
  }

  logger("Cloning remote repository '$repository'...");
  qx{ mkdir -p "${gitdirs}" };
  my $clonetext = qx{ cd ${gitdirs}; git clone "$repository" 2>&1 };
  my ($subdir) = $clonetext =~ /Cloning into '(.*)'/;
  chomp($clonetext);
  logger("CLONED: [$clonetext]");
  $subdir = "" if ( $subdir and not -d "$gitdirs/$subdir" );
  if ( $subdir ) {
    logger("Cloned into: [$subdir]");
  } else {
    ($subdir) = $clonetext =~ /destination path '(.*)' already exists/;
    logger("Cloned repository already exists in: [$subdir]") if ( $subdir );
  }

  return $subdir;
}

sub remove {
  my $subdir = shift;
  return if ( not $subdir );
  if ( not -d "$gitdirs/$subdir") {
    logger("ERROR: Subdir '$subdir' does not exist!");
    return;
  }

  # $subdir should be OK, when getting it from GIT. But ...
  # make sure that $subdir is not dangerous
  $subdir =~ s#/$##;  # remove last '/' if this is direct reference to subdir
  $subdir =~ s#.*/##; # remove any path element from $subdir
  $subdir = "" if ( $subdir eq "." );  # prevent removing current dir
  $subdir = "" if ( $subdir eq ".." ); # prevent removing parent dir
  my $removed = 0;
  if ( $subdir and -d "$gitdirs/$subdir" ) {
    system( "rm -fr \"$gitdirs/$subdir\"" ); # DANGEROUS !?
    $removed = 1;
  }
  if ( $removed and ! -d "$gitdirs/$subdir" ) {
    print "Removed repository stored in subdir '$subdir'.\n";
  } else {
    print "ERROR: Unable to remove repository subdir '$subdir'!\n";
  }
}

sub gitlog {
  my $module = shift;
  return if ( not $module );
  my $subcommand = shift;

  my $subdir = "";

  # If we want to see log from already cloned subdirectory (as output from 'git perl local')
  if ( -d "$gitdirs/$module" ) {
    $subdir = $module;
  }

  # If that is not local subdir, get it from repository
  if ( not $subdir ) {
    # Clone repostiory locally, or get '$subdir' where it is cloned already
    $subdir = clone($module);
    return if ( not $subdir );
  }

  # If user ask local repository to be removed, do so.
  my $removed = 0;
  if ( $subcommand and $subcommand eq "remove" ) {
    logger("About to remove subdir for module '$module'...");
    remove( $subdir );
    return;
  }

  # Get lastlog and show all changes since last tag
  # If no tags used, show all changes since epoch
  my $lasttag = qx{ cd "$gitdirs/$subdir"; git tag -l | tail -n 2 | head -n 1 };
  chomp($lasttag);
  logger("Last tag: [$lasttag]");
  if ( $lasttag ) {
    system("cd \"$gitdirs/$subdir\"; git log -p ${lasttag}..HEAD");
  } else {
    system("cd \"$gitdirs/$subdir\"; git log -p");
  }

  # Repository will stay locally, so inform user.
  print "Cloned into: $subdir\n";
}

sub main {
  my $command = shift;

  if ( not $command ) {
    usage();
    exit;
  }

  if ( $command eq "recent" ) {

    # get a list of recent repositories
    my $content = httpget("https://fastapi.metacpan.org/release/_search?_source=name,author,date&sort=date:desc&size=100");

    my @repositories;
    my @records = split(/^ *{/m, $content);
    foreach my $record (@records) {
      if ( $record =~ /"author" : "([^"]*)".* "date" : "([^"]*)".* "name" : "([^"]*)"/s ) {
        my $author = $1;
        my $date = $2;
        my $name = $3;
        $date =~ s/T/ /g;
        push( @repositories, "$date $author/$name" );
      }
    }
    @repositories = reverse @repositories;
    print join("\n", @repositories, "");

    exit;

  }

  if ( $command eq "clone" ) {
    my $module = shift;
    exit if ( not $module );

    # If user asked to remove subdirectory directly, do it immediately

    my ($subcommand) = shift;
    if ( $subcommand and $subcommand eq "remove" and -d "$module" ) {
      remove( $module );
      exit;
    }

    # Clone repository locally, or get '$subdir' where it is cloned already

    my $subdir = clone($module);
    return if ( not $subdir );

    print "Cloned into: $subdir\n";

    if ( $subcommand and $subcommand eq "remove" ) {
      remove( $subdir );
      exit;
    }

    exit;
  }

  if ( $command eq "log" ) {
    my $module = shift;
    exit if ( not $module );

    # Call gitlog for $module, and add additional parameter if asked by user (e.g. 'remove')
    gitlog($module,shift);

    exit;
  }

  if ( $command eq "local" ) {
    my ($subdir, $subcommand) = (shift,shift);
    $subdir =~ s#/$## if ( $subdir ); # remove trailing '/' if provided as $subdir
    if ( $subdir and not -d "$gitdirs/$subdir" ) {
      my $newsubdir = clone( $subdir ); # it suppose the '$subdir' is actually '$modulename'
      $subdir = $newsubdir if ( $newsubdir ); # if cloned, use it
    }
    if ( $subdir and $subcommand ) {
      if ( $subcommand eq "remove" ) {
        remove( $subdir );
        exit;
      }
      if ( $subcommand eq "log" ) {
        gitlog( $subdir );
        exit;
      }
    }
    my @local = qx{ cd "${gitdirs}"; ls -1 */dist.ini */Makefile.PL 2>/dev/null | cut -d"/" -f1 | sort | uniq };
    chomp( @local );
    foreach my $local (@local) {
      # If user provided subdir, return data only for that module
      if ( $subdir ) {
        next if ( $local !~ /$subdir/ );
      }
      my $modulefile = "";
      my $module = "";
      my $VERSION = "";

      # Makefile.PL
      $modulefile = qx{ cd "${gitdirs}"; grep VERSION_FROM "$local/Makefile.PL" 2>/dev/null | grep "=>" | cut -d"=" -f2 | cut -d\\' -f2 | cut -d\\" -f2 | sed -e "s#^#$local/#" };
      chomp( $modulefile );
      if ( not $modulefile ) {
        $modulefile = qx{ cd "${gitdirs}"; grep "all_from" "$local/Makefile.PL" 2>/dev/null | cut -d\\' -f2 | cut -d\\" -f2 | sed -e "s#^#$local/#" };
        chomp( $modulefile );
      }
      if ( not $modulefile ) {
        $modulefile = qx{ cd "${gitdirs}"; find "$local/lib" -iname "*.pm" 2>/dev/null | xargs grep -H "package " | sed -e "s/.pm:.*/.pm/" | head -n 1 };
        chomp( $modulefile );
      }
      if ( $modulefile ) {
        $module = qx{ cd "${gitdirs}"; cat "$modulefile" | grep "^\\s*package " | sed -e "s/package //" | cut -d";" -f1 | head -n 1 };
        chomp( $module );
        if ( not $module ) {
          $module = $modulefile;
        }
        $VERSION = qx{ cd "${gitdirs}"; cat "$modulefile" | grep VERSION | grep "[0-9]" | cut -d\\' -f2 | cut -d\\" -f2 | head -n 1 };
        chomp( $VERSION );
      } else {
        # This is just guessing. It returns our...VERSION from first found file.
        $module = qx{ cd "${gitdirs}"; cd "$local/" ; grep -rsn VERSION * | grep our | cut -d":" -f1 };
        chomp( $module );
        $VERSION = qx{ cd "${gitdirs}"; cd "$local/" ; grep -rsn VERSION * | grep our | cut -d\\' -f2 | cut -d\\" -f2 | head -n 1 };
        chomp( $VERSION );
      }

      # $module/$VERSION is just provisioning data, not really used anywhere
      print "$local $module $VERSION\n";
    }
    exit;
  }

  if ( $command eq "config" ) {
    my ($name, $value) = (shift,shift);

    my $output = config($name,$value);
    print "$output\n" if ($output);
    exit;
  }

  print "ERROR: I do now know what you want? See usage:\n";
  usage();

}

main(@ARGV);

__END__ # Documentation