# -*- coding: utf-8 -*-
# Copyright (C) 2011, 2012 Rocky Bernstein <rocky@cpan.org>
use strict; use warnings;
package Devel::Trepan::Util;
use vars qw(@EXPORT @ISA @YN);
@EXPORT = qw( hash_merge safe_repr uniq_abbrev extract_expression
parse_eval_suffix parse_eval_sigil
YES NO YES_OR_NO @YN bool2YN);
@ISA = qw(Exporter);
use constant YES => qw(y yes oui si yep ja);
@YN = YES;
use constant NO => qw(n no non nope nein);
push(@YN, NO);
sub YN($)
{
my $response = shift;
!!grep(/^${response}$/i, @YN);
}
# Return 'Yes' for True and 'No' for False, and ?? for anything else
sub bool2YN($)
{
my $bool = shift;
$bool ? 'Yes' : 'No';
}
# Hash merge like Ruby has.
sub hash_merge($$) {
my ($config, $default_opts) = @_;
while (my ($field, $default_value) = each %$default_opts) {
$config->{$field} = $default_value unless defined $config->{$field};
};
$config;
}
sub safe_repr($$;$)
{
my ($str, $max, $elipsis) = @_;
$elipsis = '... ' unless defined $elipsis;
my $strlen = length($str);
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;
}
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 : ';';
}
# Demo code
unless (caller) {
my $default_config = {a => 1, b => 'c'};
require Data::Dumper;
import Data::Dumper;
my $config = {};
hash_merge $config, $default_config;
print Dumper($config), "\n";
for my $file (__FILE__, 'bogus') {
my $result = invalid_filename($file);
if (defined($result)) {
print "$result\n";
} else {
print "$file exists\n";
}
}
$config = {
term_adjust => 1,
bogus => 'yep'
};
print Dumper($config), "\n";
hash_merge $config, $default_config;
print Dumper($config), "\n";
my $string = 'The time has come to talk of many things.';
print safe_repr($string, 50), "\n";
print safe_repr($string, 17), "\n";
print safe_repr($string, 17, ''), "\n";
my @list = qw(disassemble disable distance up);
uniq_abbrev(\@list, 'disas');
print join(' ', @list), "\n";
for my $name (qw(dis disas u upper foo)) {
printf("uniq_abbrev of %s is %s\n", $name,
uniq_abbrev(\@list, $name));
}
# ------------------------------------
# extract_expression
for my $stmt (
'if (condition("if"))',
'if (condition("if")) {',
'if(condition("if")){',
'until (until_termination)',
'until (until_termination){',
'return return_value',
'return return_value;',
'nothing to be done',
'my ($a,$b) = (5,6);',
) {
print extract_expression($stmt), "\n";
}
for my $cmd (qw(eval eval$ eval% eval@ evaluate% none)) {
print "parse_eval_suffix($cmd) => '". parse_eval_suffix($cmd) . "'\n";
}
for my $resp (qw(yes no Y NO nein nien huh?)) {
printf "YN($resp) => '%s'\n", YN($resp);
}
for my $resp (1, 0, '', 'Foo', undef) {
my $resp_str = defined $resp ? $resp : 'undef';
printf "bool2YN($resp_str) => '%s'\n", bool2YN($resp);
}
}
1;