view release on metacpan or  search on metacpan

lib/Devel/Trepan/Util.pm  view on Meta::CPAN

    if ($max > 0 && $strlen > $max && -1 == index($str, "\n")) {
        sprintf("%s%s%s", substr($str, 0, $max/2),
                $elipsis,  substr($str, $strlen+1-($max)/2));
    } else {
        $str;
    }
}

# name is String and list is an Array of String.
# If name is a unique leading prefix of one of the entries of list,
# then return that. Otherwise return name.
sub uniq_abbrev($$)
{
    my ($list, $name) = @_;
    my @candidates = ();
    for my $try_name (@$list) {
        push @candidates, $try_name if 0 == index($try_name, $name);
    }
    scalar @candidates == 1 ? $candidates[0] : $name;
}

# extract the "expression" part of a line of source code.
# Specifically
#   if (expression) -> expression
#   elsif (expression) -> expression
#   else (expression) -> expression
#   until (expression) -> expression
#   while (expression) -> expression
#   return (expression) -> expression
#   my (...) = (expression) -> (...) = (expression)
#   my ... = expression -> expression
#   ditto for "our" and "local", e.g.
#   local (...) = (expression) -> (...) = (expression
#   local ... = expression -> expression
#   $... = expression -> expression
sub extract_expression($)
{
    my $text = shift;
    if ($text =~ /^\s*(?:if|elsif|unless)\s*\(/) {
        $text =~ s/^\s*(?:if|elsif|unless)\s*\(//;
        $text =~ s/\s*\)\s*\{?\s*$//;
    } elsif ($text =~ /^\s*(?:until|while)\s*\(/) {
        $text =~ s/^\s*(?:until|while)\s*\(//;
        $text =~ s/\s*\)\{?\s*$//;
    } elsif ($text =~ /^\s*return\s+/) {
        # EXPRESSION in: return EXPRESSION
        $text =~ s/^\s*return\s+//;
        $text =~ s/;\s*$//;
    } elsif ($text =~ /^\s*(?:my|our|local)\s*(.+(\((?:.+)\s*\)\s*=.*);.*$)/) {
        # my (...) = ...;
        # Note: This has to appear before the below assignment
        $text =~ s/^\s*(?:my|our|local)\s*(\((?:.+)\)\s*=.*)[^;]*;.*$/$1/;
    } elsif ($text =~ /^\s*(?:my|our|local)\s+(?:.+)\s*=\s*(.+);.*$/) {
        # my ... = ...;
        $text = $1;
    # } elsif ($text =~ /^\s*case\s+/) {
    #     # EXPRESSION in: case EXPESSION
    #     $text =~ s/^\s*case\s*//;
    # } elsif ($text =~ /^\s*sub\s*.*\(.+\)/) {
    #     $text =~ s/^\s*sub\s*.*\((.*)\)/\(\1\)/;
    } elsif ($text =~ /^\s*\$[A-Za-z_][A-Za-z0-9_\[\]]*\s*=[^=>]/) {
        # RHS of an assignment statement.
        $text =~ s/^\s*[A-Za-z_][A-Za-z0-9_\[\]]*\s*=//;
    }
    return $text;
}

sub invalid_filename($)
{
    my $filename = shift;
    return "Command file '$filename' doesn't exist"   unless -f $filename;
    return "Command file '$filename' is not readable" unless -r $filename;
    return undef;
}

# Return 'undef' arg $cmd_str is ok. If not return the message a Perl -c
# gives, dropping off the "-e had complation errors" message.
sub invalid_perl_syntax($;$)
{
    my ($cmd_str, $have_e_opt) = @_;
    my $cmd = sprintf("$EXECUTABLE_NAME -c %s",
		      $have_e_opt ? $cmd_str : "-e '$cmd_str'");
    my $output = `$cmd 2>&1`;
    my $rc = $? >>8;
    return undef if 0 == $rc;
    # Drop off: -e had compilation errors.
    my @errmsg = split(/\n/, $output);
    pop @errmsg;
    return join("\n", @errmsg);
}

sub parse_eval_suffix($)
{
    my $cmd = shift;
    my $suffix = substr($cmd, -1);
    return ( index('%@$;>', $suffix) != -1) ? $suffix : '';
}

sub parse_eval_sigil($)
{
    my $cmd = shift;
    return ($cmd =~ /^\s*([%\$\@>;])/) ? $1 : ';';
}

# This routine makes sure $pager is set up so that '|' can use it.
sub pager()
{
    # If PAGER is defined in the environment, use it.
    if (defined $ENV{PAGER}) {
	$ENV{PAGER};
    } elsif (eval { require Config } && defined $Config::Config{pager} ) {
	# if Config.pm defines it.
	$Config::Config{pager};
    } else {
      # fall back to 'more'.
	'more'
    }
}


# Demo code