view release on metacpan or  search on metacpan

bin/bb-cli  view on Meta::CPAN

#!/usr/bin/perl

# Created on: 2017-04-24 08:14:56
# Create by:  Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use strict;
use warnings;
use Getopt::Alt;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use FindBin qw/$Bin/;
use YAML::Syck qw/LoadFile DumpFile/;
use Path::Tiny;

our $VERSION = 0.009;
my ($name)   = $PROGRAM_NAME =~ m{^.*/(.*?)$}mxs;

exit main();

sub main {
    my @common = (
        'colors|c=s%',
        'force|f!',
        'host|h=s',
        'long|l',
        'max|M=i',
        'password|P=s',
        'project|p=s',
        'regexp|R',
        'remote|m=s',
        'repository|r=s',
        'sleep|s=i',
        'test|T!',
        'username|U=s',
        'verbose|v+',
    );
    my ($options, $cmd, $opt) = get_options(
        {
            name        => 'bb-cli',
            conf_prefix => '.',
            helper      => 1,
            default     => {
                remote => 'origin',
                colors => {
                    aborted  => 'grey18 on_grey0',
                    disabled => 'grey22',
                    notbuilt => 'grey12',
                },
            },
            sub_command   => sub_commands(),
            help_packages => sub_commands_help(),
            auto_complete => sub {
                my ($option, $auto, $errors) = @_;
                my $sub_command = $option->cmd;
                if ( $sub_command eq '--' ) {
                    warn '--';
                }
                elsif ( ! $sub_command || $sub_command eq $name  || $sub_command eq $0 ) {
                    my $part = shift @ARGV;
                    print join "\n", (
                        grep { $part ? /$part/ : 1 }
                        sort keys %{ sub_commands() }
                    ), '';
                }
                else {
                    warn Dumper $sub_command, \@ARGV, $0;
                }
            },
        },
        \@common,
    );

    $opt->_show_help if $cmd eq 'help';

    $options = set_defaults($options);

    # do stuff here
    my $module = 'App::BitBucketCli::Command::' . join '', map {ucfirst $_} split /-/, $cmd;
    my $file = "$module.pm";
    $file =~ s/::/\//g;
    require $file;
    my $bbs = $module->new(
        host => $options->{host},
        user => $options->{username},
        pass => $options->{password},
        max  => $options->{max},
        opt  => $options,
    );

    $cmd =~ s/-/_/g;
    return $bbs->$cmd(@ARGV) || 0;
}

sub set_defaults {
    my ($opt) = @_;
    my $config = eval { LoadFile($ENV{HOME} . '/.bb-cli.yml') } || {};

    my $top = `git rev-parse --show-toplevel 2> /dev/null`;
    chomp $top;

    if ($top) {
        # find other information about repository
        my @remotes = `git remote -v`;
        # Eg
        # origin  ssh://git@stash.example.com:45222/lux/lux.git (fetch)
        # origin  ssh://git@stash.example.com:45222/lux/lux.git (push)
        #
        # ssh://git@stash.example.com:45222/lux/lux.git
        # https://joe.blogs@stash.example.com/scm/lux/lux.git

        for my $remote (@remotes) {
            my ($name, $url, $type) = $remote =~ /^(\S+)\s+(.*?)\s+[(](\w+)[)]$/;
            next if $name ne $opt->remote;

            if ( $url =~ /^http/ ) {
                my ($protocol, $user, $host, $project, $repo) = $url =~ m{^(https?)://(?:([^@]+)[@])?([^:/]+)(?:[:]\d+)?/scm/(\w+)/(\w+)};
                if ( $config->{$host} ) {
                    for my $key (keys %{ $config->{$host} }) {
                        $opt->{$key} ||= $config->{$host}{$key};
                    }
                }

                $opt->{host}       ||= $host;
                $opt->{username}   ||= $user;
                $opt->{project}    ||= $project;
                $opt->{repository} ||= $repo;
            }
            elsif ( $url =~ /^ssh/ ) {
                # ssh://git@stash.optusnet.com.au:45222/lux/lux.git
                my ($protocol, $host, $port, $project, $repo) = $url =~ m{^(ssh)://(?:[^@]+@)?([^:/]+)(?:[:](\d+))?/([^/]+)/(.*?)[.]git$};
                #warn "$url\n$protocol $host $port $project $repo\n";
                if ( $config->{$host} ) {
                    for my $key (keys %{ $config->{$host} }) {
                        $opt->{$key} ||= $config->{$host}{$key};
                    }
                }

                $opt->{host}       ||= $host;
                $opt->{project}    ||= $project;
                $opt->{repository} ||= $repo;
            }
        }
    }

    $opt->{host}     ||= $config->{host};
    $opt->{username} ||= $config->{user};
    $opt->{password} ||= $config->{pass};

    return $opt;
}

sub sub_commands_help {
    my ($self) = @_;
    my %help;

    for my $cmd (keys %{sub_commands()}) {
        my $module = 'App::BitBucketCli::Command::' . join '', map {ucfirst $_} split /-/, $cmd;
        $help{$cmd} = $module;
    }

    return \%help;
}

sub sub_commands {
    my ($self)   = @_;
    my $sub_file = path $ENV{HOME}, '.bb-cli', 'sub-commands.yml';

    mkdir $sub_file->parent if ! -d $sub_file->parent;

    return LoadFile("$sub_file") if -f $sub_file && (stat $sub_file)[9] > time - 60 * 60 * 24 * 31;

    return generate_sub_command();
}

sub generate_sub_command {
    my ($self)   = @_;
    my $sub_file = path $ENV{HOME}, '.bb-cli', 'sub-commands.yml';

    require Module::Pluggable;
    Module::Pluggable->import( require => 1, search_path => ['App::BitBucketCli::Command'] );
    my @commands = __PACKAGE__->plugins;

    my $sub_commands = {};
    for my $command (reverse sort @commands) {
        my ($name) = $command =~ /::([^:]+)$/;
        $name = join "-", map {lc $_} split /(?=[A-Z])/, $name;
        my ($conf) = $command->options;
        $sub_commands->{$name} = $conf;
    }

    DumpFile($sub_file, $sub_commands);

    return $sub_commands;
}

__DATA__

=head1 NAME

bb-cli - Command line tool for communicating with BitBucket Server

=head1 VERSION

0his documentation refers to bb-cli version 0.009

=head1 SYNOPSIS

   bb-cli [option]
   bb-cli projects [options]
   bb-cli repositories [options]
   bb-cli repository [options]
   bb-cli branch [options]
   bb-cli pull_requests [options]

 OPTIONS:
  -c --colors[=]str Change colours used specified as key=value
                    eg --colors disabled=grey22
                    current colour names aborted, disabled and notbuilt
  -f --force        Force action
  -l --long         Show long form data if possible
  -M --max[=]int    The maximum number of records to fetch from BitBucket/Stash
  -p --project[=]str
                    For commands that need a project name this is the name to use
  -R --recipient[=]str
                    ??
  -R --regexp[=]str ??
  -m --remote[=]str ??
  -r --repository[=]str
                    For commands that work on repositories this contains the repository
  -s --sleep[=]seconds
                    ??
  -t --test         ??

 CONFIGURATION:
  -h --host[=]str   Specify the Stash/Bitbucket Servier host name
  -P --password[=]str
                    The password to connect to the server as
  -u --username[=]str
                    The username to connect to the server as

  -v --verbose       Show more detailed option
     --version       Prints the version information
     --help          Prints this help information
     --man           Prints the full documentation for bb-cli

=head1 DESCRIPTION

=head1 SUBROUTINES/METHODS

=head1 DIAGNOSTICS

=head1 CONFIGURATION AND ENVIRONMENT

=head1 DEPENDENCIES

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to Ivan Wills (ivan.wills@gmail.com).

Patches are welcome.

=head1 AUTHOR

Ivan Wills - (ivan.wills@gmail.com)

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2017 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
All rights reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.

=cut