view release on metacpan or  search on metacpan

lib/Pinto/Remote/SelfContained/App.pm  view on Meta::CPAN

        verify => {
            summary => 'report archives that are missing',
            usage_desc => '%c %o',
            opt_spec => [],
        },
    );
    for my $cmd (keys %ret) {
        $ret{$cmd}{usage_desc} =~ s/^%c\K/ $cmd/;
        $ret{$cmd}{usage_desc} .= " - $ret{$cmd}{summary}";
    }
    return \%ret;
}

sub command_alias {
    +{
        cp => 'copy',
        del => 'delete',
        history => 'log',
        ls => 'list',
        mv => 'rename',
        remove => 'delete',
        rm => 'delete',
        stats => 'statistics',
        up => 'update',
    };
}

sub global_opt_spec {
    return (
        [ 'root|r=s'           => 'Path to your repository root directory (required)' ],
        [ 'color|colour!'      => '(Currently ignored)' ],
        [ 'password|p=s'       => 'Password for server authentication' ],
        [ 'quiet|q'            => 'Only report fatal errors' ],
        [ 'username|u=s'       => 'Username for server authentication' ],
        [ 'verbose|v+'         => 'More diagnostic output (repeatable)' ],
        [],
        [ 'help|?'             => 'Print usage message and exit', { shortcircuit => 1 }],
    );
}

sub help_summary {
    my ($class) = @_;

    my %command_info = %{ $class->command_info };
    my $len = max(map length, keys %command_info);
    my $fmt = "  %${len}s: %s";
    return join '',
        "Available commands:\n\n",
        map defined() ? sprintf("    %*s: %s\n", $len, $_, $command_info{$_}{summary}) : '', (
            (sort { $command_info{$a}{pos} <=> $command_info{$b}{pos} }
             grep defined $command_info{$_}{pos}, keys %command_info),
            undef,
            (grep !defined $command_info{$_}{pos}, sort keys %command_info),
        );
}

sub parse_from_argv {
    my ($class, $argv) = @_;

    my $orig_cmd = do {
        local @ARGV = @$argv;
        () = describe_options('', $class->global_opt_spec, { getopt_conf => ['gnu_getopt', 'pass_through'] });
        print($class->help_summary), exit
            if !@ARGV; # "pintor", "pintor --help", "pintor -r URL", "pintor --username fred", etc
        $ARGV[0];
    };

    my $cmd = $class->command_alias->{$orig_cmd} // $orig_cmd;
    my $command_info = $class->command_info;
    my $info = $command_info->{$cmd} // do {
        print $class->help_summary;
        exit 2;
    };

    my $usage_desc = $info->{usage_desc};
    my @opt_spec = (@{ $info->{opt_spec} }, [], $class->global_opt_spec);

    local @ARGV = @$argv;
    my ($opt, $usage) = describe_options($usage_desc, @opt_spec, { getopt_conf => ['gnu_getopt'] });

    die "BUG; cmd=$cmd but not next in argv"
        if !@ARGV || shift(@ARGV) ne $orig_cmd;

    if ($opt->help || $cmd eq 'help' && !@ARGV) {
        say $usage->text;
        exit 0;
    }
    elsif ($cmd eq 'commands') {
        print $class->help_summary;
        exit 0;
    }
    elsif ($cmd eq 'help') {
        my $exit_status = $class->run_help_command($usage, @ARGV);
        exit $exit_status;
    }
    elsif (my @missing = grep !defined $opt->{$_}, qw(root)) {
        my $missing = join ', ', map "--$_", @missing;
        $usage->die({ pre_text => "Required options not found: $missing\n\n" });
    }

    my %parsed = $class->parse_arguments($info, $opt, $usage, @ARGV);
    my %args = (%$opt, %parsed);
    my %attrs = (action_name => $cmd);
    for my $attr (@ATTRS_FROM_OPTIONS) {
        next if !exists $args{$attr};
        $attrs{$attr} = delete $args{$attr};
    }

    return %attrs, args => \%args;
}

sub run_help_command {
    my ($class, $parent_usage, @argv) = @_;

    my $command_info = $class->command_info;
    (my $usage_text = $parent_usage->text) =~ s/\n\K/\n    Global options:\n/;
    say $usage_text;

    my $exit_status = 0;
    my $command_alias = $class->command_alias;
    for my $arg (@argv) {
        my $cmd = $command_alias->{$arg} // $arg;
        my $info = $command_info->{$cmd} // do {
            warn "No command '$cmd' found\n\n";
            $exit_status = 2;
            next;
        };
        my (undef, $usage) = do {
            local @ARGV;
            describe_options($info->{usage_desc}, [], @{ $info->{opt_spec} }, {
                getopt_conf => ['gnu_getopt', 'pass_through'],
            });
        };
        say $usage->text;
    }
    return $exit_status;
}

sub parse_arguments {
    my ($class, $info, $opt, $usage, @remaining_argv) = @_;
    if (!$info->{args}) {
        $usage->die({ pre_text => "Too many arguments\n\n" })
            if @remaining_argv;
        return;
    }
    elsif (ref $info->{args}) {
        return $info->{args}->($opt, $usage, @remaining_argv);
    }
    elsif ($info->{args} =~ /^([a-z]+)\? ([a-z]+)\z/) {
        my ($optional, $required) = ($1, $2);
        $usage->die({ pre_text => "You must specify at least one argument\n\n" })
            if !@remaining_argv;
        $usage->die({ pre_text => "You must specify at most two arguments\n\n" })
            if @remaining_argv > 2;
        my %ret = ($required => pop @remaining_argv);
        $ret{$optional} = $remaining_argv[0] if @remaining_argv;
        $usage->die({ pre_text => "\u$_ specified as both option and argument\n\n" })
            for grep $opt->{$_}, sort keys %ret;
        return %ret;
    }
    else {
        my @items = split / /, $info->{args};
        my $slurpy = $items[-1] =~ /[*+]\z/ ? pop @items : undef;
        $usage->die({ pre_text => "Not enough arguments\n\n" })
            if @remaining_argv < grep !/\?\z/, @items;
        $usage->die({ pre_text => "Too many arguments\n\n" })
            if !defined $slurpy && @remaining_argv > @items;
        my %ret;
        for my $arg_name (@items) {
            $arg_name =~ s/(?<!\?)\z/?/ if exists $opt->{$arg_name};
            last if $arg_name =~ s/\?\z// && !@remaining_argv;
            $usage->die({ pre_text => "No $arg_name argument supplied\n\n" })
                if !@remaining_argv;
            $usage->die({ pre_text => "\u$arg_name supplied as both option and argument\n\n" })
                if exists $opt->{$arg_name};
            $ret{$arg_name} = shift @remaining_argv;
        }
        if (defined $slurpy) {
            $slurpy =~ s/\*\z//;
            $usage->die({ pre_text => "Need at least one $slurpy argument\n\n" })
                if $slurpy =~ s/\+\z// && !@remaining_argv;
            $usage->die({ pre_text => "$slurpy supplied as both option and argument\n\n" })
                if exists $opt->{$slurpy};
            $ret{$slurpy} = [@remaining_argv] if @remaining_argv;
        }
        return %ret;
    }
}