File Coverage

blib/lib/Shipwright/Script/List.pm

Criterion	Covered	Total	%
statement	25	147	17.0
branch	0	66	0.0
condition	0	23	0.0
subroutine	9	11	81.8
pod	0	2	0.0
total	34	249	13.6

package Shipwright::Script::List;

use strict;
use warnings;
use Shipwright::Util;

use base qw/App::CLI::Command Shipwright::Base Shipwright::Script/;
__PACKAGE__->mk_accessors(qw/with_latest_version only_update/);

use Shipwright;
use Cwd qw/getcwd/;
use File::Temp qw/tempdir/;
use File::Spec::Functions qw/catdir/;

sub options {
    (
        'with-latest-version' => 'with_latest_version',
        'only-update'         => 'only_update',
    );
}

sub run {
    my $self = shift;
    my $name = shift;

    my $shipwright = Shipwright->new( repository => $self->repository, );

    my $versions = $shipwright->backend->version;
    my $source   = $shipwright->backend->source;
    my $refs     = $shipwright->backend->refs || {};
    my $branches;

    if ( $shipwright->backend->has_branch_support ) {
        $branches = $shipwright->backend->branches;
    }

    my $latest_version = {};

    # only_update option implies with_latest_version
    $self->with_latest_version(1) if $self->only_update;

    if ( $self->with_latest_version ) {
        my $map = $shipwright->backend->map;

        if ($name) {
            if ( $name =~ /^cpan-/ && !$source->{$name} ) {
                my %reversed = reverse %$map;
                my $module   = $reversed{$name};
                $latest_version->{$name} =
                  $self->_latest_version( name => $module );
            }
            else {
                $latest_version->{$name} =
                  $self->_latest_version( url => $source->{$name} );
            }
        }
        else {

            for my $module ( keys %$map ) {
                next if exists $latest_version->{ $map->{$module} };
                $latest_version->{ $map->{$module} } =
                  $self->_latest_version( name => $module );
            }
            for my $name ( keys %$source ) {
                next if exists $latest_version->{$name};
                for my $branch ( keys %{ $source->{$name} } ) {
                    if ( $source->{$name}{$branch} =~
                        m{^(sv[nk]|git|shipwright):} )
                    {
                        $latest_version->{$name}{$branch} =
                          $self->_latest_version(
                            url => $source->{$name}{$branch} );
                    }
                }
            }
        }
    }

    if ($name) {
        my $new_versions = {};
        $new_versions->{$name} = $versions->{$name}
          if exists $versions->{$name};
        $versions = $new_versions;
    }
    for my $name ( sort keys %$versions ) {
        my $flip = 1;

        if ( $self->only_update ) {
            $flip = 0;
            if ( $latest_version->{$name} ) {
                require version;
                my $latest = version->new( $latest_version->{$name} );
                if ( ref $versions->{$name} ) {

                  # we show this dist if at least one of the branches has update
                    for my $branch ( keys %{ $versions->{$name} } ) {
                        if ( $latest gt $versions->{$name}{$branch} ) {
                            $flip = 1;
                            last;
                        }
                    }
                }
                elsif ( $latest gt $versions->{$name} ) {
                    $flip = 1;
                }
            }
        }

        if ($flip) {
            $self->log->fatal( $name, ':' );
            my $version_info;
            if ( ref $versions->{$name} ) {

                if ( $name =~ /^cpan-/ ) {
                    $version_info = $versions->{$name}{'vendor'};
                }
                else {
                    $version_info = "\n";
                    for my $branch ( keys %{ $versions->{$name} } ) {
                        $version_info .= ' ' x 8 .
                          $branch . ': ' . $versions->{$name}{$branch}
                          || '' . "\n";
                    }
                    chomp $version_info;
                }
            }
            else {
                $version_info = $versions->{$name} || '';
            }
            $self->log->fatal( ' ' x 4 . 'version: ' . $version_info );

            my $from_info;
            if ( ref $source->{$name} ) {
                $from_info = "\n";
                for my $branch ( keys %{ $source->{$name} } ) {
                    $from_info .= ' ' x 8 . $branch .
                      ': ' . $source->{$name}{$branch} || '' . "\n";
                }
                chomp $from_info;
            }
            else {
                $from_info = $source->{$name} || 'CPAN';
            }
            $self->log->fatal( ' ' x 4 . 'from: ' . $from_info );

            $self->log->fatal( ' ' x 4 . 'references: ',
              defined $refs->{$name} ? $refs->{$name} : 'unknown' );

            if ( $self->with_latest_version ) {
                my $latest_version_info;
                if ( ref $source->{$name} ) {
                    $latest_version_info = "\n";
                    for my $branch ( keys %{ $source->{$name} } ) {
                        $latest_version_info .=
                            ' ' x 8
                          . $branch . ': '
                          . ( $latest_version->{$name}{$branch} || 'unknown' )
                          . "\n";
                    }
                    chomp $latest_version_info;
                }
                else {
                    $latest_version_info = $latest_version->{$name} || 'unknown';
                }
                $self->log->fatal( ' ' x 4,
                    'latest_version: ' . $latest_version_info );
            }

            if ($branches && $name !~ /^cpan-/) {
                $self->log->fatal( ' ' x 4 . 'branches: ',
                    join ', ', @{ $branches->{$name} } );
            }
        }
    }

    if ( $name && keys %$versions == 0 ) {
        $self->log->fatal( "$name doesn't exist" );
    }
}

sub _latest_version {
    my $self = shift;
    my %args = @_;
    if ( $args{url} ) {

        my ( $cmd, $out );

        # XXX TODO we need a better latest_version for shipwright source
        # using the source shipwright repo's whole version seems lame
        if ( $args{url} =~ s/^shipwright:// ) {
            $args{url} =~ s!/[^/]+$!!;
        }

        # has url, meaning svn, svk or git
        if ( $args{url} =~ /^svn[:+]/ ) {
            $args{url} =~ s{^svn:(?!//)}{};
            $cmd = [ $ENV{'SHIPWRIGHT_SVN'}, 'info', $args{url} ];
            $cmd = [ $ENV{'SHIPWRIGHT_SVK'}, 'info', $args{url} ];
            ($out) = run_cmd( $cmd, 1 );    # ignore failure
            if ( $out =~ /^Revision:\s*(\d+)/m ) {
                return $1;
            }
        }
        elsif ( $args{url} =~ m{^(svk:|//)} ) {
            $args{url} =~ s/^svk://;
            $cmd = [ $ENV{'SHIPWRIGHT_SVK'}, 'info', $args{url} ];
            ($out) = run_cmd( $cmd, 1 );    # ignore failure
            if ( $out =~ /^Revision:\s*(\d+)/m ) {
                return $1;
            }
        }
        elsif ( $args{url} =~ /^git:/ ) {
            $args{url} =~ s{^git:(?!//)}{};

         # TODO XXX is there a better way that we can get latest version of git?
         # current way is not too heavy: it needs clone and log

            my $cwd = getcwd();
            my $dir = tempdir(
                'shipwright_list_git_XXXXXX',
                CLEANUP => 1,
                TMPDIR  => 1
            );
            my $path = catdir( $dir, 'git' );
            run_cmd(
                [ $ENV{SHIPWRIGHT_GIT}, 'clone', $args{url}, $path, ] );
            chdir $path;
            ($out) = run_cmd( [ $ENV{SHIPWRIGHT_GIT}, 'log' ] );
            chdir $cwd;

            if ( $out =~ /^commit\s+(\w+)/m ) {
                return $1;
            }
        }

    }
    elsif ( $args{name} ) {

        # cpan
        require CPAN;
        require CPAN::DistnameInfo;

        select_fh('cpan');

        my $module = CPAN::Shell->expand( 'Module', $args{name} );

        select_fh('stdout');

        my $info    = CPAN::DistnameInfo->new( $module->cpan_file );
        my $version = $info->version;
        $version =~ s/^v//;    # we don't want the leading 'v'
        return $version;
    }
    return;
}

1;

__END__