libur-perl 0.440-1 / usr / share / perl5 / Command / Dispatch / Shell.pm

package Command::V2;  # additional methods to dispatch from a command-line
use strict;
use warnings;

use IO::File;
use List::MoreUtils;

# instead of tacking these methods onto general Command::V2 objects
# they could be put on the Command::Shell class, which is a wrapper/adaptor Command for translating from
# command-line shell to purely functional commands.

# old entry point
# new cmds will call Command::Shell->run("MyClass",@ARGV)
# which goes straight into _cmdline_run for now...
sub execute_with_shell_params_and_exit {
    my $class = shift;
    if (@_) {
        die "No params expected for execute_with_shell_params_and_exit()!";
    }
    my @argv = @ARGV;
    @ARGV = ();
    my $exit_code = $class->_cmdline_run(@argv);
    exit $exit_code;
}

sub _cmdline_run {
    # This automatically parses command-line options and "does the right thing":
    # TODO: abstract out all dispatchers for commands into a given API
    my $class = shift;
    my @argv = @_;

    $Command::entry_point_class ||= $class;
    $Command::entry_point_bin ||= File::Basename::basename($0);

    if ($ENV{COMP_CWORD}) {
        require Getopt::Complete;
        my @spec = $class->resolve_option_completion_spec();
        my $options = Getopt::Complete::Options->new(@spec);
        $options->handle_shell_completion;
        die "error: failed to exit after handling shell completion!";
    }

    my $exit_code;
    eval {
        $exit_code = $class->_execute_with_shell_params_and_return_exit_code(@argv);
        UR::Context->commit or die "Failed to commit!: " . UR::Context->error_message();
    };
    if ($@) {
        $class->error_message($@);
        UR::Context->rollback or die "Failed to rollback changes after failed commit!!!\n";
        $exit_code = 255 unless ($exit_code);
    }
    return $exit_code;
}

sub _execute_with_shell_params_and_return_exit_code {
    my $class = shift;
    my @argv = @_;

    my $original_cmdline = join("\0",$0,@argv);

    # make --foo=bar equivalent to --foo bar
    @argv = map { ($_ =~ /^(--\w+?)\=(.*)/) ? ($1,$2) : ($_) } @argv;
    my ($delegate_class, $params, $errors) = $class->resolve_class_and_params_for_argv(@argv);

    my $exit_code;
    if ($errors and @$errors) {
        $delegate_class->dump_status_messages(1);
        $delegate_class->dump_warning_messages(1);
        $delegate_class->dump_error_messages(1);
        for my $error (@$errors) {
            $delegate_class->error_message(join(' ', $error->property_names) . ": " . $error->desc);
        }
        $exit_code = 1;
    }
    else {
        my $rv = $class->_execute_delegate_class_with_params($delegate_class,$params,$original_cmdline);
        $exit_code = $delegate_class->exit_code_for_return_value($rv);
    }

    return $exit_code;
}


sub _execute_delegate_class_with_params {
    # this is called by both the shell dispatcher and http dispatcher for now
    my ($class, $delegate_class, $params, $original_cmdline) = @_;

    unless ($delegate_class) {
        $class->dump_status_messages(1);
        $class->dump_warning_messages(1);
        $class->dump_error_messages(1);
        $class->dump_usage_messages(1);
        $class->dump_debug_messages(0);
        $class->usage_message($class->help_usage_complete_text);
        return;
    }

    $delegate_class->dump_status_messages(1);
    $delegate_class->dump_warning_messages(1);
    $delegate_class->dump_error_messages(1);
    $delegate_class->dump_usage_messages(1);
    $delegate_class->dump_debug_messages(0);

    # FIXME There should be a better check for params that are there because they came from the
    # command line, and params that exist for infrastructural purposes.  'original_command_line'
    # won't ever be given on the command line and shouldn't count toward the next test.
    # maybe check the is_input properties...
    if ( !defined($params) ) {
        my $command_name = $delegate_class->command_name;
        $delegate_class->status_message($delegate_class->help_usage_complete_text);
        $delegate_class->error_message("Please specify valid params for '$command_name'.");
        return;
    }

    if ( $params->{help} ) {
        $delegate_class->usage_message($delegate_class->help_usage_complete_text);
        return 1;
    }

    $params->{'original_command_line'} = $original_cmdline if (defined $original_cmdline);
    my $command_object = $delegate_class->create(%$params);

    unless ($command_object) {
        # The delegate class should have emitted an error message.
        # This is just in case the developer is sloppy, and the user will think the task did not fail.
        print STDERR "Exiting.\n";
        return;
    }

    $command_object->dump_status_messages(1);
    $command_object->dump_warning_messages(1);
    $command_object->dump_error_messages(1);
    $command_object->dump_debug_messages($command_object->debug);
    if ($command_object->debug) {
        UR::ModuleBase->dump_debug_messages($command_object->debug);
    }

    my $rv = $command_object->execute($params);

    if ($command_object->__errors__) {
        $command_object->delete;
    }

    return $rv;
}

sub resolve_class_and_params_for_argv {
    # This is used by execute_with_shell_params_and_exit, but might be used within an application.
    my $self = shift;
    my @argv = @_;

    my ($params_hash,@spec) = $self->_shell_args_getopt_specification;
    unless (grep { /^help\W/ } @spec) {
        push @spec, "help!";
    }

    my @error_tags;

    # Thes nasty GetOptions modules insist on working on
    # the real @ARGV, while we like a little more flexibility.
    # Not a problem in Perl. :)  (which is probably why it was never fixed)
    local @ARGV;
    @ARGV = @argv;

    do {
        # GetOptions also likes to emit warnings instead of return a list of errors :(
        my @errors;
        my $rv;
        {
            local $SIG{__WARN__} = sub { push @errors, @_ };

            ## Change the pattern to be '--', '-' followed by a non-digit, or '+'.
            ## This s the effect of treating a negative number as a value of an option.
            ## This means that we won't be allowed to have an option named, say, -1.
            ## But since command modules' properties have to be allowable function names,
            ## and "1" is not a valid function name, it's not really a problem
            #Getopt::Long::Configure('prefix_pattern=--|-(?!\D)|\+');
            $rv = GetOptions($params_hash,@spec);
        }
        unless ($rv) {
            for my $error (@errors) {
                $self->error_message($error);
            }
            return($self, undef);
        }
    };

    # Q: Is there a standard getopt spec for capturing non-option paramters?
    # Perhaps that's not getting "options" :)
    # A: Yes.  Use '<>'.  But we need to process this anyway, so it won't help us.

    if (my @names = $self->_bare_shell_argument_names) {
        for (my $n=0; $n < @ARGV; $n++) {
            my $name = $names[$n];
            unless ($name) {
                $self->error_message("Unexpected bare arguments: @ARGV[$n..$#ARGV]!");
                return($self, undef);
            }
            my $value = $ARGV[$n];
            my $meta = $self->__meta__->property_meta_for_name($name);
            if ($meta->is_many and $n == $#names) {
                # slurp the rest
                $params_hash->{$name} = [@ARGV[$n..$#ARGV]];
                last;
            }
            else {
                $params_hash->{$name} = $value;
            }
        }
    }

    if (@ARGV and not $self->_bare_shell_argument_names) {
        ## argv but no names
        $self->error_message("Unexpected bare arguments: @ARGV!");
        return($self, undef);
    }

    for my $key (keys %$params_hash) {
        # handle any has-many comma-sep values
        my $value = $params_hash->{$key};
        if (ref($value)) {
            my @new_value;
            for my $v (@$value) {
                my @parts = split(/,\s*/,$v);
                push @new_value, @parts;
            }
            @$value = @new_value;

        } elsif ($value eq q('') or $value eq q("")) {
            # Handle the special values '' and "" to mean undef/NULL
            $params_hash->{$key} = '';
        }

        # turn dashes into underscores
        my $new_key = $key;

        next unless ($new_key =~ tr/-/_/);
        if (exists $params_hash->{$new_key} && exists $params_hash->{$key}) {
            # this corrects a problem where is_many properties badly interact
            # with bare args leaving two entries in the hash like:
            # a-bare-opt => [], a_bare_opt => ['with','vals']
            delete $params_hash->{$key};
            next;
        }
        $params_hash->{$new_key} = delete $params_hash->{$key};
    }

    # futher work is looking for errors, and may display them
    # if help is set, return now
    # we might have returned sooner, but having full info available
    # allows for dynamic help
    if ($params_hash->{help}) {
        return ($self, $params_hash);
    }

    ##
    my $params = $params_hash;
    my $class = $self->class;

    if (my @errors = $self->_errors_from_missing_parameters($params)) {
        return ($class, $params, \@errors);
    }

    unless (@_) {
        return ($class, $params);
    }

    # should this be moved up into the methods which are only called
    # directly from the shell, or is it okay everywhere in this module to
    # presume we're a direct cmdline call? -ssmith
    local $ENV{UR_COMMAND_DUMP_STATUS_MESSAGES} = (!exists($ENV{UR_COMMAND_DUMP_STATUS_MESSAGES})
                                                    or $ENV{UR_COMMAND_DUMP_STATUS_MESSAGES});

    my @params_to_resolve = $self->_params_to_resolve($params);
    for my $p (@params_to_resolve) {
        my $param_arg_str = join(',', @{$p->{value}});
        my $pmeta = $self->__meta__->property($p->{name});

        my @params;
        eval {
            @params = $self->resolve_param_value_from_cmdline_text($p);
        };

        if ($@) {
            push @error_tags, UR::Object::Tag->create(
                type => 'invalid',
                properties => [$p->{name}],
                desc => "Errors while resolving from $param_arg_str: $@",
            );
        }
        if (@params and $params[0]) {
            if ($pmeta->{'is_many'}) {
                $params->{$p->{name}} = \@params;
            }
            else {
                $params->{$p->{name}} = $params[0];
            }
        }
        else {
            push @error_tags, UR::Object::Tag->create(
                type => 'invalid',
                properties => [$p->{name}],
                desc => "Problem resolving from $param_arg_str.",
            );
        }
    }

    if (@error_tags) {
        return ($class, undef, \@error_tags);
    }
    else {
        return ($class, $params);
    }
}

sub resolve_option_completion_spec {
    my $class = shift;
    my @completion_spec = $class->_shell_args_getopt_complete_specification;
    no warnings;
    unless (grep { /^help\W/ } @completion_spec) {
        push @completion_spec, "help!" => undef;
    }
    return \@completion_spec
}

sub _errors_from_missing_parameters {
    my ($self, $params) = @_;

    my $class_meta = $self->__meta__;

    my @all_property_metas = $class_meta->properties();
    my @specified_property_metas = grep { exists $params->{$_->property_name} } @all_property_metas;

    my %specified_property_metas = map { $_->property_name => $_ } @specified_property_metas;
    my %set_indirectly;
    my @todo = @specified_property_metas;
    while (my $property_meta = shift @todo) {
        if (my $via = $property_meta->via) {
            if (not $property_meta->is_mutable) {
                my $list = $set_indirectly{$via} ||= [];
                push @$list, $property_meta;
            }
            unless ($specified_property_metas{$via}) {
                my $via_meta = $specified_property_metas{$via} = $class_meta->property($via);
                push @specified_property_metas, $via_meta;
                push @todo, $via_meta;
            }
        }
        elsif (my $id_by = $property_meta) {
            my $list = $set_indirectly{$id_by} ||= [];
            push @$list, $property_meta;
            unless ($specified_property_metas{$id_by}) {
                my $id_by_meta = $specified_property_metas{$id_by} = $class_meta->property($id_by);
                push @specified_property_metas, $id_by_meta;
                push @todo, $id_by_meta;
            }
        }
    }

    # TODO: this should use @all_property_metas, and filter down to is_param and is_input
    # This old code just ignores things inherited from a base class.
    # We will need to be careful fixing this because it could add checks to tools which
    # work currently and lead to unexpected failures.
    my @property_names;
    if (my $has = $class_meta->{has}) {
        @property_names = List::MoreUtils::uniq(keys %$has);
    }
    my @property_metas = map { $class_meta->property_meta_for_name($_); } @property_names;

    my @error_tags;
    for my $property_meta (@property_metas) {
        my $pn = $property_meta->property_name;

        next if $property_meta->is_optional;
        next if $property_meta->implied_by;
        next if defined $property_meta->default_value;
        next if defined $params->{$pn};
        next if $set_indirectly{$pn};

        if (my $via = $property_meta->via) {
            if ($params->{$via} or $set_indirectly{$via}) {
                next;
            }
        }

        my $arg = $pn;
        $arg =~ s/_/-/g;
        $arg = "--$arg";

        if ($property_meta->is_output and not $property_meta->is_input and not $property_meta->is_param) {
            if ($property_meta->_data_type_as_class_name->__meta__->data_source 
                and not $property_meta->_data_type_as_class_name->isa("UR::Value")
            ) {
                # outputs with a data source do not need a specification
                # on the cmdline to "store" them after execution
                next;
            }
            elsif ($property_meta->is_calculated) {
                # outputs that are calculated don't need to be specified on
                # the command line
                next;
            }
            else {
                push @error_tags, UR::Object::Tag->create(
                    type => 'invalid',
                    properties => [$pn],
                    desc => "Output requires specified destination: " . $arg . "."
                );
            }
        }
        else {
            $DB::single = 1;
            push @error_tags, UR::Object::Tag->create(
                type => 'invalid',
                properties => [$pn],
                desc => "Missing required parameter: " . $arg . "."
            );
        }
    }

    return @error_tags;
}

sub _params_to_resolve {
    my ($self, $params) = @_;
    my @params_to_resolve;
    if ($params) {
        my $cmeta = $self->__meta__;
        my @params_will_require_verification;
        my @params_may_require_verification;

        for my $param_name (keys %$params) {
            my $pmeta = $cmeta->property($param_name);
            unless ($pmeta) {
                # This message was a die after a next, so I guess it isn't supposed to be fatal?
                $self->warning_message("No metadata for property '$param_name'");
                next;
            }

            my $param_type = $pmeta->data_type;
            next unless($self->_can_resolve_type($param_type));

            my $param_arg = $params->{$param_name};
            if (my $arg_type = ref($param_arg)) {
                next if $arg_type eq $param_type; # param is already the right type
                if ($arg_type ne 'ARRAY') {
                    $self->error_message("no handler for property '$param_name' with argument type " . ref($param_arg));
                    next;
                }
            } else {
                $param_arg = [$param_arg];
            }
            next unless (@$param_arg);

            my $resolve_info = {
                name => $param_name,
                class => $param_type,
                value => $param_arg,
            };
            push(@params_to_resolve, $resolve_info);

            my $require_user_verify = $pmeta->{'require_user_verify'};
            if ( defined($require_user_verify) ) {
                push @params_will_require_verification, "'$param_name'" if ($require_user_verify);
            } else {
                push @params_may_require_verification, "'$param_name'";
            }
        }

        my @adverbs = ('will', 'may');
        my @params_adverb_require_verification = (
            \@params_will_require_verification,
            \@params_may_require_verification,
        );
        for (my $i = 0; $i < @adverbs; $i++) {
            my $adverb = $adverbs[$i];
            my @param_adverb_require_verification = @{$params_adverb_require_verification[$i]};
            next unless (@param_adverb_require_verification);

            if (@param_adverb_require_verification > 1) {
                $param_adverb_require_verification[-1] = 'and ' . $param_adverb_require_verification[-1];
            }
            my $param_str = join(', ', @param_adverb_require_verification);
            $self->status_message($param_str . " $adverb require verification...");
        }
    }
    return @params_to_resolve;
}

sub _can_resolve_type {
    my ($self, $type) = @_;

    return 0 unless($type);

    my $non_classes = 0;
    if (ref($type) ne 'ARRAY') {
        $non_classes = $type !~ m/::/;
    } else {
        $non_classes = scalar grep { ! m/::/ } @$type;
    }
    return $non_classes == 0;
}

sub _shell_args_property_meta {
    my $self = shift;
    my $class_meta = $self->__meta__;

    # Find which property metas match the rules.  We have to do it this way
    # because just calling 'get_all_property_metas()' will product multiple matches
    # if a property is overridden in a child class
    my ($rule, %extra) = UR::Object::Property->define_boolexpr(@_);
    my %seen;
    my (@positional,@required_input,@required_param,@optional_input,@optional_param, @output);

    my @property_meta = $class_meta->properties();
    PROP:
    foreach my $property_meta (@property_meta) {
        my $property_name = $property_meta->property_name;

        next if $seen{$property_name}++;
        next unless $rule->evaluate($property_meta);
        next unless $property_meta->can("is_param") and ($property_meta->is_param or $property_meta->is_input or $property_meta->is_output);
        if (%extra) {
            no warnings;
            for my $key (keys %extra) {
                if ($property_meta->$key ne $extra{$key}) {
                    next PROP;
                }
            }
        }

        next if $property_name eq 'id';
        next if $property_name eq 'result';
        next if $property_name eq 'is_executed';
        next if $property_name eq 'original_command_line';
        next if $property_name =~ /^_/;

        next if $property_meta->implied_by;
        next if $property_meta->is_calculated;
        # Kept commented out from UR's Command.pm, I believe is_output is a workflow property
        # and not something we need to exclude (counter to the old comment below).
        #next if $property_meta->{is_output}; # TODO: This was breaking the G::M::T::Annotate::TranscriptVariants annotator. This should probably still be here but temporarily roll back
        next if $property_meta->is_transient;
        next if $property_meta->is_constant;
        if (($property_meta->is_delegated) || (defined($property_meta->data_type) and $property_meta->data_type =~ /::/)) {
            next unless($self->can('resolve_param_value_from_cmdline_text'));
        }
        else {
            next unless($property_meta->is_mutable);
        }

        if ($property_meta->{shell_args_position}) {
            push @positional, $property_meta;
        }
        elsif ($property_meta->is_optional) {
            if ($property_meta->is_input or $property_meta->is_output) {
                push @optional_input, $property_meta;
            }
            elsif ($property_meta->is_param) {
                push @optional_param, $property_meta;
            }
        }
        else {
            if ($property_meta->is_input or $property_meta->is_output) {
                push @required_input, $property_meta;
            }
            elsif ($property_meta->is_param) {
                push @required_param, $property_meta;
            }
        }
    }

    my @result;
    @result = (
        (sort { $a->position_in_module_header cmp $b->position_in_module_header } @required_param),
        (sort { $a->position_in_module_header cmp $b->position_in_module_header } @optional_param),
        (sort { $a->position_in_module_header cmp $b->position_in_module_header } @required_input),
        (sort { $a->position_in_module_header cmp $b->position_in_module_header } @optional_input),
        (sort { $a->shell_args_position <=> $b->shell_args_position } @positional),
    );

    return @result;
}


sub _shell_arg_name_from_property_meta {
    my ($self, $property_meta,$singularize) = @_;
    my $property_name = ($singularize ? $property_meta->singular_name : $property_meta->property_name);
    my $param_name = $property_name;
    $param_name =~ s/_/-/g;
    return $param_name;
}

sub _shell_arg_getopt_qualifier_from_property_meta {
    my ($self, $property_meta) = @_;

    my $many = ($property_meta->is_many ? '@' : '');
    if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
        return '!' . $many;
    }
    #elsif ($property_meta->is_optional) {
    #    return ':s' . $many;
    #}
    else {
        return '=s' . $many;
    }
}

sub _shell_arg_usage_string_from_property_meta {
    my ($self, $property_meta) = @_;
    my $string = $self->_shell_arg_name_from_property_meta($property_meta);
    if ($property_meta->{shell_args_position}) {
        $string = uc($string);
    }

    if ($property_meta->{shell_args_position}) {
        if ($property_meta->is_optional) {
            $string = "[$string]";
        }
    }
    else {
        $string = "--$string";
        if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
            $string = "[$string]";
        }
        else {
            if ($property_meta->is_many) {
                $string .= "=?[,?]";
            }
            else {
                $string .= '=?';
            }
            if ($property_meta->is_optional) {
                $string = "[$string]";
            }
        }
    }
    return $string;
}

sub _shell_arg_getopt_specification_from_property_meta {
    my ($self,$property_meta) = @_;
    my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
    return (
        $arg_name .  $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
        #this prevents defaults from being used for is_many properties
        #($property_meta->is_many ? ($arg_name => []) : ())
    );
}


sub _shell_arg_getopt_complete_specification_from_property_meta {
    my ($self,$property_meta) = @_;
    my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
    my $completions = $property_meta->valid_values;
    if ($completions) {
        if (ref($completions) eq 'ARRAY') {
            $completions = [ @$completions ];
        }
    }
    else {
        my $type = $property_meta->data_type;
        my @complete_as_files = (
            'File','FilePath','Filesystem','FileSystem','FilesystemPath','FileSystemPath',
            'Text','String',
        );
        my @complete_as_directories = (
            'Directory','DirectoryPath','Dir','DirPath',
        );
        if (!defined($type)) {
            $completions = 'files';
        }
        else {
            for my $pattern (@complete_as_files) {
                if (!$type || $type eq $pattern) {
                    $completions = 'files';
                    last;
                }
            }
            for my $pattern (@complete_as_directories) {
                if ( $type && $type eq $pattern) {
                    $completions = 'directories';
                    last;
                }
            }
        }
    }
    return (
        $arg_name .  $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
        $completions,
#        ($property_meta->is_many ? ($arg_name => []) : ())
    );
}

sub _shell_args_getopt_specification {
    my $self = shift;
    my @getopt;
    my @params;
    for my $meta ($self->_shell_args_property_meta) {
        my ($spec, @params_addition) = $self->_shell_arg_getopt_specification_from_property_meta($meta);
        push @getopt,$spec;
        push @params, @params_addition;
    }
    @getopt = sort @getopt;
    return { @params}, @getopt;
}

sub _shell_args_getopt_complete_specification {
    my $self = shift;
    my @getopt;
    for my $meta ($self->_shell_args_property_meta) {
        my ($spec, $completions) = $self->_shell_arg_getopt_complete_specification_from_property_meta($meta);
        push @getopt, $spec, $completions;
    }
    return @getopt;
}


sub _bare_shell_argument_names {
    my $self = shift;
    my $meta = $self->__meta__;
    my @ordered_names =
        map { $_->property_name }
        sort { $a->{shell_args_position} <=> $b->{shell_args_position} }
        grep { $_->{shell_args_position} }
        $self->_shell_args_property_meta();
    return @ordered_names;
}

#
# Logic to turn command-line text into objects for parameter/input values
#

our %ALTERNATE_FROM_CLASS = ();

# This will prevent infinite loops during recursion.
our %SEEN_FROM_CLASS = ();
our $MESSAGE;

sub resolve_param_value_from_cmdline_text {
    my ($self, $param_info) = @_;
    my $param_name  = $param_info->{name};
    my $param_class = $param_info->{class};
    my @param_args  = @{$param_info->{value}};
    my $param_str   = join(',', @param_args);

    if (ref($param_class) eq 'ARRAY') {
        my @param_class = @$param_class;
        if (@param_class > 1) {
            die 'Multiple data types on command arguments are not supported.';
        } else {
            $param_class = $param_class[0];
        }
    }

    my $param_resolve_message = "Resolving parameter '$param_name' from command argument '$param_str'...";
    my $pmeta = $self->__meta__->property($param_name);
    my $require_user_verify = $pmeta->{'require_user_verify'};

    my @results;
    my $bx = eval { UR::BoolExpr->resolve_for_string($param_class, $param_str) };
    my $bx_error = $@;
    if ($bx) {
        @results = $param_class->get($bx);
        if (@results > 1 && !defined($require_user_verify)) {
            $require_user_verify = 1;
        }
    } else {
        for my $arg (@param_args) {
            %SEEN_FROM_CLASS = ();

            # call resolve_param_value_from_text without a via_method to "bootstrap" recursion
            my @arg_results = $self->resolve_param_value_from_text($arg, $param_class);

            if (@arg_results != 1 && !defined($require_user_verify)) {
                $require_user_verify = 1;
            }

            push @results, @arg_results;
        }
    }
    if (@results) {
        # the ALTERNATE_FROM_CLASS stuff leads to non $param_class objects in results
        @results = List::MoreUtils::uniq(@results);
        @results = grep { $_->isa($param_class) } @results;

        $self->status_message($param_resolve_message . " found " . @results);
    }
    else {
        if ($bx_error) {
            $self->status_message($bx_error);
        }
        $self->status_message($param_resolve_message . " none found.");
    }

    return unless (@results);

    my $limit_results_method = "_limit_results_for_$param_name";
    if ( $self->can($limit_results_method) ) {
        @results = $self->$limit_results_method(@results);
        return unless (@results);
    }
    @results = List::MoreUtils::uniq(@results);
    if ($require_user_verify) {
        if (!$pmeta->{'is_many'} && @results > 1) {
            $MESSAGE .= "\n" if ($MESSAGE);
            $MESSAGE .= "'$param_name' expects only one result.";

            if ($ENV{UR_NO_REQUIRE_USER_VERIFY}) {
                die "$MESSAGE\n";
            }
        }
        @results = $self->_get_user_verification_for_param_value($param_name, @results);
    }
    while (!$pmeta->{'is_many'} && @results > 1) {
        $MESSAGE .= "\n" if ($MESSAGE);
        $MESSAGE .= "'$param_name' expects only one result, not many!";
        @results = $self->_get_user_verification_for_param_value($param_name, @results);
    }

    if (wantarray) {
        return @results;
    }
    elsif (not defined wantarray) {
        return;
    }
    elsif (@results > 1) {
        Carp::confess("Multiple matches found!");
    }
    else {
        return $results[0];
    }
}

sub resolve_param_value_from_text {
    my ($self, $param_arg, $param_class, $via_method) = @_;

    unless ($param_class) {
        $param_class = $self->class;
    }

    $SEEN_FROM_CLASS{$param_class} = 1;
    my @results;
    # try getting BoolExpr, otherwise fallback on '_resolve_param_value_from_text_by_name_or_id' parser
    eval { @results = $self->_resolve_param_value_from_text_by_bool_expr($param_class, $param_arg); };
    Carp::croak($@) if ($@ and $@ !~ m/Not a valid BoolExpr/);
    if (!@results && !$@) {
        # no result and was valid BoolExpr then we don't want to break it apart because we
        # could query enormous amounts of info
        return;
    }
    # the first param_arg is all param_args to try BoolExpr so skip if it has commas
    if (!@results && $param_arg !~ /,/) {
        my @results_by_string;
        if ($param_class->can('_resolve_param_value_from_text_by_name_or_id')) {
            @results_by_string = $param_class->_resolve_param_value_from_text_by_name_or_id($param_arg);
        }
        else {
            @results_by_string = $self->_resolve_param_value_from_text_by_name_or_id($param_class, $param_arg);
        }
        push @results, @results_by_string;
    }
    # if we still don't have any values then try via alternate class
    if (!@results && $param_arg !~ /,/) {
        @results = $self->_resolve_param_value_via_related_class_method($param_class, $param_arg, $via_method);
    }

    if ($via_method) {
        @results = map { $_->$via_method } @results;
    }

    if (wantarray) {
        return @results;
    }
    elsif (not defined wantarray) {
        return;
    }
    elsif (@results > 1) {
        Carp::confess("Multiple matches found!");
    }
    else {
        return $results[0];
    }
}

sub _resolve_param_value_via_related_class_method {
    my ($self, $param_class, $param_arg, $via_method) = @_;
    my @results;
    my $via_class;
    if (exists($ALTERNATE_FROM_CLASS{$param_class})) {
        $via_class = $param_class;
    }
    else {
        for my $class (keys %ALTERNATE_FROM_CLASS) {
            if ($param_class->isa($class)) {
                if ($via_class) {
                    $self->error_message("Found additional via_class $class but already found $via_class!");
                }
                $via_class = $class;
            }
        }
    }
    if ($via_class) {
        my @from_classes = sort keys %{$ALTERNATE_FROM_CLASS{$via_class}};
        while (@from_classes && !@results) {
            my $from_class  = shift @from_classes;
            my @methods = @{$ALTERNATE_FROM_CLASS{$via_class}{$from_class}};
            my $method;
            if (@methods > 1 && !$via_method && !$ENV{UR_NO_REQUIRE_USER_VERIFY}) {
                $self->status_message("Trying to find $via_class via $from_class...\n");
                my $method_choices;
                for (my $i = 0; $i < @methods; $i++) {
                    $method_choices .= ($i + 1) . ": " . $methods[$i];
                    $method_choices .= " [default]" if ($i == 0);
                    $method_choices .= "\n";
                }
                $method_choices .= (scalar(@methods) + 1) . ": none\n";
                $method_choices .= "Which method would you like to use?";
                my $response = $self->_ask_user_question($method_choices, 0, '\d+', 1, '#');
                if ($response =~ /^\d+$/) {
                    $response--;
                    if ($response == @methods) {
                        $method = undef;
                    }
                    elsif ($response >= 0 && $response <= $#methods) {
                        $method = $methods[$response];
                    }
                    else {
                        $self->error_message("Response was out of bounds, exiting...");
                        exit;
                    }
                    $ALTERNATE_FROM_CLASS{$via_class}{$from_class} = [$method];
                }
                elsif (!$response) {
                    $self->status_message("Exiting...");
                }
            }
            else {
                $method = $methods[0];
            }
            unless($SEEN_FROM_CLASS{$from_class}) {
                #$self->debug_message("Trying to find $via_class via $from_class->$method...");
                @results = eval {$self->resolve_param_value_from_text($param_arg, $from_class, $method)};
            }
        } # END for my $from_class (@from_classes)
    } # END if ($via_class)
    return @results;
}

sub _resolve_param_value_from_text_by_bool_expr {
    my ($self, $param_class, $arg) = @_;

    my @results;
    my $bx = eval {
        UR::BoolExpr->resolve_for_string($param_class, $arg);
    };
    if ($bx) {
        @results = $param_class->get($bx);
    }
    else {
        die "Not a valid BoolExpr";
    }
    #$self->debug_message("B: $param_class '$arg' " . scalar(@results));

    return @results;
}

sub _try_get_by_id {
    my ($self, $param_class, $str) = @_;

    my $class_meta = $param_class->__meta__;
    my @id_property_names = $class_meta->id_property_names;
    if (@id_property_names == 0) {
        die "Failed to determine ID property names for class ($param_class).";
    } elsif (@id_property_names == 1) {
        my $id_data_type = $class_meta->property_meta_for_name($id_property_names[0])->_data_type_as_class_name || '';
        # Validate $str, if possible, to prevent warnings from database if $str does not fit column type.
        if ($id_data_type->isa('UR::Value::Number')) { # Oracle's Number data type includes floats but we just use integers for numeric IDs
            return ($str =~ /^[+-]?\d+$/);
        }
    }
    return 1;
}

sub _resolve_param_value_from_text_by_name_or_id {
    my ($self, $param_class, $str) = @_;
    my (@results);
    if ($self->_try_get_by_id($param_class, $str)) {
        @results = eval { $param_class->get($str) };
    }
    if (!@results && $param_class->can('name')) {
        @results = $param_class->get(name => $str);
        unless (@results) {
            @results = $param_class->get("name like" => "$str");
        }
    }

    return @results;
}

sub _get_user_verification_for_param_value {
    my ($self, $param_name, @list) = @_;

    my $n_list = scalar(@list);
    if ($n_list > 200 && !$ENV{UR_NO_REQUIRE_USER_VERIFY}) {
        my $response = $self->_ask_user_question("Would you [v]iew all $n_list item(s) for '$param_name', (p)roceed, or e(x)it?", 0, '[v]|p|x', 'v');
        if(!$response || $response eq 'x') {
            $self->status_message("Exiting...");
            exit;
        }
        return @list if($response eq 'p');
    }

    my @new_list;
    while (!@new_list) {
        @new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list);
    }

    my @ids = map { $_->id } @new_list;
    $self->status_message("The IDs for your selection are:\n" . join(',', @ids) . "\n\n");
    return @new_list;
}

sub _get_user_verification_for_param_value_drilldown {
    my ($self, $param_name, @results) = @_;
    my $n_results = scalar(@results);
    my $pad = length($n_results);

    # Allow an environment variable to be set to disable the require_user_verify attribute
    return @results if ($ENV{UR_NO_REQUIRE_USER_VERIFY});
    return if (@results == 0);

    my @dnames = map {$_->__display_name__} grep { $_->can('__display_name__') } @results;
    my $max_dname_length = @dnames ? length((sort { length($b) <=> length($a) } @dnames)[0]) : 0;
    my @statuses = map {$_->status || 'missing_status'} grep { $_->can('status') } @results;
    my $max_status_length = @statuses ? length((sort { length($b) <=> length($a) } @statuses)[0]) : 0;

    my @results_with_display_name_and_class = map { [ $_->__display_name__, $_->class, $_ ] } @results;
    @results = map { $_->[2] }
               sort { $a->[1] cmp $b->[1] }
               sort { $a->[0] cmp $b->[0] }
               @results_with_display_name_and_class;

    my @classes = List::MoreUtils::uniq(map {$_->class} @results);

    my $response;
    my @caller = caller(1);
    while (!$response) {
        $self->status_message("\n");
        # TODO: Replace this with lister?
        for (my $i = 1; $i <= $n_results; $i++) {
            my $param = $results[$i - 1];
            my $num = $self->_pad_string($i, $pad);
            my $msg = "$num:";
            $msg .= ' ' . $self->_pad_string($param->__display_name__, $max_dname_length, 'suffix');
            my $status = ' ';
            if ($param->can('status')) {
                $status = $param->status || 'missing_status';
            }
            $msg .= "\t" . $self->_pad_string($status, $max_status_length, 'suffix');
            $msg .= "\t" . $param->class if (@classes > 1);
            $self->status_message($msg);
        }
        if ($MESSAGE) {
            $MESSAGE = "\n" . '*'x80 . "\n" . $MESSAGE . "\n" . '*'x80 . "\n";
            $self->status_message($MESSAGE);
            $MESSAGE = '';
        }
        my $pretty_values = '(c)ontinue, (h)elp, e(x)it';
        my $valid_values = '\*|c|h|x|[-+]?[\d\-\., ]+';
        if ($caller[3] =~ /_trim_list_from_response/) {
            $pretty_values .= ', (b)ack';
            $valid_values .= '|b';
        }
        $response = $self->_ask_user_question("Please confirm the above items for '$param_name' or modify your selection.", 0, $valid_values, 'h', $pretty_values.', or specify item numbers to use');
        if (lc($response) eq 'h' || !$self->_validate_user_response_for_param_value_verification($response)) {
            $MESSAGE .= "\n" if ($MESSAGE);
            $MESSAGE .=
            "Help:\n".
            "* Specify which elements to keep by listing them, e.g. '1,3,12' would keep\n".
            "  items 1, 3, and 12.\n".
            "* Begin list with a minus to remove elements, e.g. '-1,3,9' would remove\n".
            "  items 1, 3, and 9.\n".
            "* Ranges can be used, e.g. '-11-17, 5' would remove items 11 through 17 and\n".
            "  remove item 5.";
            $response = '';
        }
    }
    if (lc($response) eq 'x') {
        $self->status_message("Exiting...");
        exit;
    }
    elsif (lc($response) eq 'b') {
        return;
    }
    elsif (lc($response) eq 'c' | $response eq '*') {
        return @results;
    }
    elsif ($response =~ /^[-+]?[\d\-\., ]+$/) {
        @results = $self->_trim_list_from_response($response, $param_name, @results);
        return @results;
    }
    else {
        die $self->error_message("Conditional exception, should not have been reached!");
    }
}

sub terminal_input_filehandle {
    my $self = shift;

    my $fh = IO::File->new('/dev/tty', 'r');
    unless ($fh) {
        Carp::carp("Couldn't open /dev/tty for terminal input: $!\n    Using STDIN...");
        $fh = *STDIN;
    }
    return $fh;
}

sub _ask_user_question {
    my $self = shift;
    my $question = shift;
    my $timeout = shift;
    my $valid_values = shift || "yes|no";
    my $default_value = shift || undef;
    my $pretty_valid_values = shift || $valid_values;
    $valid_values = lc($valid_values);
    my $input;
    $timeout = 60 unless(defined($timeout));

    local $SIG{ALRM} = sub { print STDERR "Exiting, failed to reply to question '$question' within '$timeout' seconds.\n"; exit; };
    print STDERR "\n$question\n";
    print STDERR "Reply with $pretty_valid_values: ";

    unless ($self->_can_interact_with_user) {
        print STDERR "\n";
        die $self->error_message("Attempting to ask user question but cannot interact with user!");
    }

    my $terminal = $self->terminal_input_filehandle();

    alarm($timeout) if ($timeout);
    chomp($input = $terminal->getline());
    alarm(0) if ($timeout);

    print STDERR "\n";

    if(lc($input) =~ /^$valid_values$/) {
        return lc($input);
    }
    elsif ($default_value) {
        return $default_value;
    }
    else {
        $self->error_message("'$input' is an invalid answer to question '$question'\n\n");
        return;
    }
}

sub _validate_user_response_for_param_value_verification {
    my ($self, $response_text) = @_;
    $response_text = substr($response_text, 1) if ($response_text =~ /^[+-]/);
    my @response = split(/[\s\,]/, $response_text);
    for my $response (@response) {
        if ($response =~ /^[xbc*]$/) {
            return 1;
        }
        if ($response !~ /^(\d+)([-\.]+(\d+))?$/) {
            $MESSAGE .= "\n" if ($MESSAGE);
            $MESSAGE .= "ERROR: Invalid list provided ($response)";
            return 0;
        }
        if ($3 && $1 && $3 < $1) {
            $MESSAGE .= "\n" if ($MESSAGE);
            $MESSAGE .= "ERROR: Inverted range provided ($1-$3)";
            return 0;
        }
    }
    return 1;
}

sub _trim_list_from_response {
    my ($self, $response_text, $param_name, @list) = @_;

    my $method;
    if ($response_text =~ /^[+-]/) {
        $method = substr($response_text, 0, 1);
        $response_text = substr($response_text, 1);
    }
    else {
        $method = '+';
    }

    my @response = split(/[\s\,]/, $response_text);
    my %indices;
    @indices{0..$#list} = 0..$#list if ($method eq '-');

    for my $response (@response) {
        $response =~ /^(\d+)([-\.]+(\d+))?$/;
        my $low = $1; $low--;
        my $high = $3 || $1; $high--;
        die if ($high < $low);
        if ($method eq '+') {
            @indices{$low..$high} = $low..$high;
        }
        else {
            delete @indices{$low..$high};
        }
    }
    #$self->debug_message("Indices: " . join(',', sort(keys %indices)));
    my @new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list[sort keys %indices]);
    unless (@new_list) {
        @new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list);
    }
    return @new_list;
}

sub _pad_string {
    my ($self, $str, $width, $pos) = @_;
    $str = '' if ! defined $str;
    my $padding = $width - length($str);
    $padding = 0 if ($padding < 0);
    if ($pos && $pos eq 'suffix') {
        return $str . ' 'x$padding;
    }
    else {
        return ' 'x$padding . $str;
    }
}

sub _can_interact_with_user {
    my $self = shift;
    if ( -t STDERR ) {
        return 1;
    }
    else {
        return 0;
    }
}


1;