File Coverage

lib/Devel/Trepan/Options.pm

Criterion	Covered	Total	%
statement	40	110	36.3
branch	1	52	1.9
condition	1	14	7.1
subroutine	14	23	60.8
pod	0	8	0.0
total	56	207	27.0

# Copyright (C) 2011-2014, 2019 Rocky Bernstein <[e-mail]>
use strict;
use warnings;
package Devel::Trepan::Options;
use Getopt::Long qw(GetOptionsFromArray);
use Pod::Usage;
use Pod::Find qw(pod_where);
use File::Spec;
use File::HomeDir;

use vars qw(@EXPORT $DEFAULT_OPTIONS $PROGRAM_NAME $VERSION);
@EXPORT = qw( process_options whence_file $DEFAULT_OPTIONS $PROGRAM_NAME);
our @ISA;
$VERSION='1.0.1'; # To fool CPAN indexer. Is <= real version

BEGIN {
    $PROGRAM_NAME = 'trepan.pl';
    my @OLD_INC = @INC;
    use rlib '../..';
    use rlib '.';
    use Devel::Trepan::Version;
    @INC = @OLD_INC;
}

use constant PROGRAM_NAME => $PROGRAM_NAME;

@ISA    = qw(Exporter);

# Return whether we want Terminal highlighting by default
sub default_term() {
    ($ENV{'TERM'} && ($ENV{'TERM'} ne 'dumb' ||
                     (exists($ENV{'EMACS'}) && $ENV{'EMACS'} eq 't')))
        ?  'lightbg' : undef
}

my $HOME = File::HomeDir->my_home;
my $initfile = File::Spec->catfile($HOME, '.treplrc');
$DEFAULT_OPTIONS = {
    basename     => 0,
    batchfile    => undef,
    cmddir       => [],      # Additional directories of debugger commands
    cmdfiles     => [],      # Files containing debugger commands to 'source'
    exec_strs    => [],      # Perl strings to evaluate
    fall_off_end => 0,       # Don't go into debugger on termination?
    highlight    => default_term(),
                           # Default values used only when 'server' or 'client'                            # (out-of-process debugging)
    host         => 'localhost',
    includes     => [],      # includes to add to @INC.
    initfile     => $initfile,
    initial_dir  => undef,   # If --cd option was given, we save it here.
    modules      => [],      # modules ot add to perl -M
    nx           => 0,       # Don't run user startup file (e.g. .treplrc)
    port         => 1954,
    post_mortem  => 0,       # Go into debugger on die?
    readline     => 1,       # Try to use GNU Readline?
    testing      => undef,
    traceprint   => 0,       # set -x tracing?
    verbose      => 0,       # show what we are doing?

};

sub show_version()
{
    printf "$PROGRAM_NAME, version %s\n", $Devel::Trepan::Version::VERSION;
    exit 10;
}

sub check_tcp_opts($$) {
    my ($server_client, $opts) = @_;
    my ($protocol, $host, $port) = @$opts;
    $opts->[1] = $host || $DEFAULT_OPTIONS->{host};
    $opts->[2] = $port || $DEFAULT_OPTIONS->{port};
    unless ($opts->[2] =~ /^\d+$/) {
	print STDERR "port should be a number: got $opts->[2]\n";
	$opts->[2] = $DEFAULT_OPTIONS->{port};
    }
    $opts;
}

sub bad_tty_opts($$) {
    my ($server_client, $opts) = @_;
    if (scalar @$opts != 3) {
	return "For now, you need to specify an input and output pseudo tty";
    }
    my ($protocol, $inp_pty, $out_pty) = @$opts;
    return "input pseudo-tty '$inp_pty' is not character device"
	unless -c $inp_pty;
    return "output pseudo-tty name '$out_pty' is not a character device"
	unless -c $out_pty;
    return "input pseudo-tty '$inp_pty' is not readable"
	unless -r $inp_pty;
    return "output pseudo-tty '$out_pty' is not writeable"
	unless -w $out_pty;
    return undef;
}

sub check_protocol($)
{
    my ($opts) = @_;
    my $server_type = $opts->[0];
    if ($server_type !~ /^tcp|^tty/) {
	print STDERR
	    "Protocol should be either 'tcp' or 'tty': got '$server_type'\n";
	$opts->[0] = 'tcp';
    }
}

sub parse_client_server_opts($$$)
{
    my ($server_client, $opts, $server_opts) = @_;
    if (scalar @$server_opts == 1) {
	if (!$server_opts->[0]) {
	    $server_opts->[0] = 'tcp';
	}
	check_protocol($server_opts);
    } elsif (scalar @$server_opts <= 3) {
	check_protocol($server_opts);
	if ($server_opts->[0] eq 'tcp'){
	    $server_opts = check_tcp_opts($server_client, $server_opts);
	    $opts->{host} = $server_opts->[1];
	    $opts->{port} = $server_opts->[2];
	} else {
	    my $mess = bad_tty_opts($server_client, $server_opts);
	    die $mess if $mess;
	}
    }
}

sub process_options($)
{
    $Getopt::Long::autoabbrev = 1;
    my ($argv) = @_;
    my ($show_version, $help, $man);
    my $opts = $DEFAULT_OPTIONS;

    my $result = &GetOptionsFromArray($argv,
         'basename'       => \$opts->{basename},
         'batch:s'        => \$opts->{batchfile},
         'bw'             => \$opts->{bw},
         'cd:s'           => \$opts->{initial_dir},
         'client=s@{0,3}' => \$opts->{client},
         'cmddir=s@'      => \$opts->{cmddir},
         'command=s@'     => \$opts->{cmdfiles},
         'e|exec=s@'      => \$opts->{exec_strs},
         'fall-off-end'   => \$opts->{fall_off_end},
         'help'           => \$help,
         'highlight'      => \$opts->{highlight},
         'I|includes=s@'  => \$opts->{includes},
         'man'            => \$man,
         'M|modules=s@'   => \$opts->{modules},
         'no-highlight'   => sub { $opts->{highlight} = 0},
         'no-readline'    => sub { $opts->{readline} = 0},
         'nx'             => \$opts->{nx},
         'post-mortem'    => \$opts->{post_mortem},
         'readline'       => \$opts->{readline},
         'server=s@{0,3}' => \$opts->{server},
         'testing:s'      => \$opts->{testing},
         'verbose'        => \$opts->{verbose},
         'version'        => \$show_version,
         'x|trace'        => \$opts->{traceprint},
        );

    pod2usage(-input => pod_where({-inc => 1}, __PACKAGE__),
              -exitstatus => 1) if $help;
    pod2usage(-exitstatus => 10, -verbose => 2,
              -input => pod_where({-inc => 1}, __PACKAGE__)) if $man;
    show_version() if $show_version;
    chdir $opts->{initial_dir} || die "Can't chdir to $opts->{initial_dir}" if
        defined($opts->{initial_dir});
    my $batch_filename = $opts->{testing};
    $batch_filename = $opts->{batchfile} unless defined $batch_filename;
    if ($batch_filename) {
        if (scalar(@{$opts->{cmdfiles}}) != 0) {
            printf(STDERR "--batch option disables command files: %s\n",
                   join(', ', @{$opts->{cmdfiles}}));
            $opts->{cmdfiles} = [];
        }
        $opts->{nx} = 1;
    }
    if ($opts->{server} and $opts->{client}) {
        printf STDERR
            "Pick only on from of the --server or --client options\n";
    } else {
	# use Enbugger 'trepan'; Enbugger->stop;
	# $opts->{server} = ['tcp'];
	if ($opts->{server}) {
	    parse_client_server_opts('server', $opts, $opts->{server});
	} elsif ($opts->{client}) {
	    parse_client_server_opts('client', $opts, $opts->{client})
	}
    }

    $opts;
}

# Do a shell-like path lookup for prog_script and return the results.
# If we can't find anything return the string given.
sub whence_file($)
{
    my $prog_script = shift;

    # If we have an relative or absolute file name, don't do anything.
    return $prog_script if
        File::Spec->file_name_is_absolute($prog_script);
    my $first_char = substr($prog_script, 0, 1);
    return $prog_script if index('./', $first_char) != -1;

    for my $dirname (File::Spec->path()) {
        my $prog_script_try = File::Spec->catfile($dirname, $prog_script);
        return $prog_script_try if -r $prog_script_try;
    }
    # Failure
    return $prog_script;
}

unless (caller) {
    my $argv = \@ARGV;
    my $opts = process_options($argv);
    printf "whence file for perl: %s\n", whence_file('perl');
    require Data::Dumper;
    import Data::Dumper;
    print Dumper($opts), "\n";
    my $pid = fork();
    # if ($pid == 0) {
    #     my @argv = qw(--version);
    #     my $opts = process_options(\@argv);
    #     exit 0;
    # } else {
    #     waitpid($pid, 0);
    #     print "exit code: ", $?>>8, "\n";
    # }
    # $pid = fork();
    # if ($pid == 0) {
    #     my @argv = qw(--cd /tmp --cmddir /tmp);
    #     my $opts = process_options(\@argv);
    #     print Dumper($opts), "\n";
    #     exit 0;
    # } else {
    #     waitpid($pid, 0);
    #     print "exit code: ", $?>>8, "\n";
    # }
    # exit;
    # $pid = fork();
    # if ($pid == 0) {
    #     my @argv = qw(--cd /bogus);
    #     my $opts = process_options(\@argv);
    #     exit 0
    # } else {
    #     waitpid($pid, 0);
    #     print "exit code: ", $?>>8, "\n";
    # }
    # $pid = fork();
    # if ($pid == 0) {
    #     my @argv = ('--batch', __FILE__);
    #     my $opts = process_options(\@argv);
    #     print Dumper($opts), "\n";
    #     exit 0
    # } else {
    #     waitpid($pid, 0);
    #     print "exit code: ", $?>>8, "\n";
    # }

    # $pid = fork();
    if ($pid == 0) {
        my @argv = ('--server', '--', __FILE__);
        my $opts = process_options(\@argv);
        print Dumper($opts), "\n";
        exit 0
    } else {
        waitpid($pid, 0);
        print "exit code: ", $?>>8, "\n";
    }

}

1;

__END__

=head1 TrepanPl

trepan.pl - Perl "Trepanning" Debugger

=head1 SYNOPSIS

   trepan.pl [options] [[--] perl-program [perl-program-options ...]]

   Options:
      --help               brief help message
      --man                full documentation
      --basename           Show basename only on source file listings.
                           (Needed in regression tests)
      --bw                 Use Bullwinkle Processor (for front-ends) rather
                           that the command-line processor
      -c| --command FILE   Run or 'source' debugger command file FILE
      --cmddir DIR         Read DIR for additional debugger commands
      --batch FILE         Like --command, but quit after reading FILE.
                           This option has precidence over --command and
                           will also set --nx
      --cd DIR             Change current directory to DIR
      -e| --exec STRING    eval STRING. Multiple -e's can be given.
                           Works like Perl's -e switch
      --nx                 Don't run user startup file (e.g. .treplrc)

      --client {'tcp' host port} | {'tty', input-slave output-slave}
                           Set for out-of-process debugging.
                           The client runs outside of this process.
                           'tcp' uses TCP/IP
                           'tty' uses pseudo tty.

      --server {'tcp' host port} | {'tty'}
                           Set for out-of-process debugging. The server
                           rus the Perl program to be debugged runs.

      --fall-off-end       Don't stay in debugger when program terminates

      --include | -I DIR   Add DIR to @INC in invoking program

      --module  | -M MOD   Add module MOD in invoking program

      --post-mortem        Enter debugger on die
      --readline  | --no-readline
                           Try or don't try to use Term::Readline
      -x|--trace           Simulate line tracing (think POSIX shell set -x)
      --highlight | --no-highlight
                           Use or don't use ANSI terminal sequences for syntax
                           highlight
      --verbose            Show what trepan.pl is invoking under the
                           covers

=head1 DESCRIPTION

B<trepan.pl> is a gdb-like debugger. Much of the interface and code has
been adapted from the trepanning debuggers of Ruby.

=cut