File Coverage

blib/lib/Term/DBPrompt.pm

Criterion	Covered	Total	%
statement	147	210	70.0
branch	45	88	51.1
condition	8	33	24.2
subroutine	14	19	73.6
pod	9	11	81.8
total	223	361	61.7

package Term::DBPrompt;

use strict;
use warnings;
use 5.010;

our $VERSION = '0.05';

our @EXPORT = qw( get_cmd_line page_open   page_close     set_prompt
                  set_banner   set_command get_candidates set_opt
                  init_pipe    fh);

use base qw(Exporter);
use File::Spec;

use Text::Balanced qw(extract_delimited);

use Fcntl qw(:seek);

my @pipe;

my $opt_file;
my $opt_argv;
my $opt_interact;
my $opt_prompt;
my $opt_quiet;

my $tty_in;
my $tty_out;

my $inp_prv = '';
my $inp_fin;
my $inp_dat;
my $inp_ctr;
my $inp_tok;
my $inp_typ;
my $inp_fhd;
my $inp_eof = 0;

my @commands;

sub set_opt {
    while (my ($k, $v) = each %{$_[0]}) {
        given ($k) {
            when ('file')    { $opt_file     = $v; }
            when ('argv')    { $opt_argv     = $v; }
            when ('inter')   { $opt_interact = $v; }
            when ('prompt')  { $opt_prompt   = $v; }
            when ('quiet')   { $opt_quiet    = $v; }
            when ('tty_in')  { $tty_in       = $v; }
            when ('tty_out') { $tty_out      = $v; }
            default {
                die "Error: in subroutine set_opt(), found invalid key {$k => '$v'} (not 'file', 'argv', 'inter', 'prompt', 'quiet', 'tty_in' or 'tty_out')";
            }
        }
    }
}

sub init_pipe {
    @pipe = ();
    if (defined $opt_file) {
        push @pipe, ['f', $opt_file]; # first read from a file (if any)
    }
    if (defined $opt_argv and $opt_argv =~ m{\S}xms) {
        push @pipe, ['a', $opt_argv]; # then execute from the commandline
    }
    if (!@pipe or $opt_interact) { # if pipe is empty, or interactive has been forced...
        push @pipe, ['i']; # ...then read from STDIN
    }

    $inp_prv = '';
    $inp_fin = undef;
    $inp_dat = undef;
    $inp_ctr = undef;
    $inp_tok = undef;
    $inp_typ = undef;
    $inp_fhd = undef;
    $inp_eof = 0;

    @commands = ();
}

# set up some parameters:

my $prompt = '?> ';

my $banner =
  qq{\n}.
  qq{**********\n}.
  qq{** Test **\n}.
  qq{**********\n}.
  qq{\n};

my @cmd_available = qw( exit help );

# some setters and getters:

sub set_banner {
    $banner = shift;
}

sub set_prompt {
    $prompt = shift;
}

sub set_command {
    @cmd_available = ();
    for (@_) {
        push @cmd_available, lc;
    }
}

sub get_cmd_line {
    until ($inp_eof or @commands) {
        getdata();
    }
    unless (@commands) { return; }

    my $cmd = shift @commands;
    my ($open, $close, $line) = @$cmd;

    if ($opt_prompt) {
        unless ($inp_typ eq 'i' and $tty_in) {
            say $prompt, $line;
        }
    }

    my @words;
    while (1) {
        my ($extracted, $new_line, $prefix) = extract_delimited $line, q{'"}, q{[^'"]*};

        unless (defined $extracted) {
            $line =~ s{\A \s+}''xms; # remove leading spaces
            push @words, split(m{\s+}xms, $line) if $line =~ m{\S}xms;
            last;
        }

        $line = $new_line;
        $extracted =~ s{\A ['"]}''xms;
        $extracted =~ s{['"] \z}''xms;
        $prefix    =~ s{\A \s+}''xms; # remove leading spaces
        push @words, split(m{\s+}xms, $prefix) if $prefix =~ m{\S}xms;;
        push @words, $extracted;
    }

    # say "DEBUG words = ('@words') has ", scalar @words, " elements!";

    unless (@words) {
        return 'Empty', $open, $close, '';
    }

    $words[0] = lc $words[0];

    my @candidates = get_candidates($words[0]);

    if (@candidates > 1) {
        return 'Dup', $open, $close, $words[0], @candidates;
    }

    if (@candidates == 1) {
        $words[0] = $candidates[0];
        return 'Found', $open, $close, @words;
    }

    return 'Not', $open, $close, @words;
}

sub getdata {
    while (1) {
        unless (defined $inp_tok) {
            unless ($inp_prv eq '') {
                $inp_dat = $inp_prv;
                $inp_prv = '';
                $inp_fin = 1;
                last;
            }
            unless (@pipe) {
                $inp_eof = 1;
                return;
            }
            $inp_tok = shift @pipe;
            $inp_typ = $inp_tok->[0];
            $inp_ctr = 0;

            if ($inp_typ eq 'f') {
                open $inp_fhd, '<', $inp_tok->[1]
                  or die "Can't open < '".$inp_tok->[1]."' because $!";
            }
        }

        $inp_ctr++;

        if ($inp_ctr == 1 and $inp_typ eq 'i' and $tty_in) {
            say $banner;
        }

        given ($inp_typ) {
            when ('f') {
                $inp_dat = <$inp_fhd>;
                unless (defined $inp_dat) {
                    close $inp_fhd;
                    $inp_tok = undef;
                    next;
                }
                chomp $inp_dat;
                $inp_dat =~ s{\A \s+}''xms;
                $inp_dat =~ s{\s+ \z}''xms;

                unless ($inp_prv eq '') {
                    $inp_dat = $inp_prv.' '.$inp_dat;
                    $inp_prv = '';
                }
                $inp_fin = 0;
                last;
            }
            when ('a') {
                $inp_dat = $inp_tok->[1];
                $inp_tok = undef;
                $inp_fin = 0;
                last;
            }
            when ('i') {
                if ($tty_in and !$tty_out) {
                    die "STDOUT is redirected but STDIN is not";
                }
                if ($tty_in) {
                    print $prompt;
                }
                $inp_dat = ;
                unless (defined $inp_dat) {
                    $inp_tok = undef;
                    next;
                }
                chomp $inp_dat;

                if (!$tty_in and $opt_prompt) {
                    say $prompt, $inp_dat;
                }

                unless ($inp_prv eq '') {
                    $inp_dat = $inp_prv.' '.$inp_dat;
                    $inp_prv = '';
                }

                $inp_fin = 0;
                last;
            }
            default {
                die "Internal error: type = '$inp_typ' (not 'f', 'a' or 'i')";
            }
        }
    }

    unless ($inp_dat =~ m{\S}xms) {
        push @commands, [1, 1, '']; # generate an empty line
        return;
    }

    # here we translate 'any occurrence of ';' or '#' inside quotes into dummy characters
    # in fact, inside quotes character ';' becomes \x{01}, character '#' becomes \x{02}

    my $line = '';

    while (1) {
        my ($extracted, $new_dat, $prefix) = extract_delimited $inp_dat, q{'"}, q{[^'"]*};

        unless (defined $extracted) {
            $line .= $inp_dat;
            last;
        }

        $inp_dat = $new_dat;
        $extracted =~ tr{;\#}{\x{01}\x{02}}; # inside quotes: convert ';' into \x{01} and '#' into \x{02}
        $line .= $prefix.$extracted;
    }

    if ($line =~ m{\A ([^\#]*) \#}xms) { $line = $1; } # remove comments

    $line =~ s{\s+ \z}''xms; # remove trailing spaces

    # here we find out if there is a trailing, half open command:
    unless ($inp_fin) {
        if ($inp_typ eq 'f' or ($inp_typ eq 'i' and !$tty_in)) {
            my $rest;
            if ($line =~ s{; ([^;]*) \z}';'xms) {
                $rest = $1;
            }
            else {
                $rest = $line; $line = '';
            }
            $rest =~ s{\A \s+}''xms;
            $rest =~ s{\s+ \z}''xms;
            $inp_prv = $rest;
        }
    }

    # split up $line by ';' into @dat
    my @dat;
    for (split m{;}xms, $line) {
        s{\A \s+}''xms;
        tr{\x{01}\x{02}}{;\#}; # re-convert the dummy characters back into ';' and '#'
        push @dat, $_ if m{\S}xms;
    }

    my $last = $#dat;
    for my $i (0..$last) {
        my $open  = $i == 0     ? 1 : 0;
        my $close = $i == $last ? 1 : 0;

        push @commands, [$open, $close, $dat[$i]];
    }
}

sub get_candidates {
    my $word = lc $_[0];

    return $word if grep {$_ eq $word} @cmd_available;

    my $len  = length $word;

    my @cdt;

    for my $c (@cmd_available) {
        if (substr($c, 0, $len) eq $word) {
            push @cdt, $c;
        }
    }

    return @cdt;
}

open my $page_fh, '+>', undef or die "Error: Can't open '+>' undef because $!";

sub fh { $page_fh; }

sub page_open {
    seek $page_fh, 0, SEEK_SET or die "Error: Can't seek tempfile to 0 for writing because $!";
    truncate $page_fh, 0 or die "Error: Can't truncate tempfile to 0 because $!";
}

sub page_close {
    seek $page_fh, 0, SEEK_SET or die "Error: Can't seek tempfile to 0 for reading because $!";

    my $out_fh;

    if ($inp_typ eq 'i' and $tty_in) {
        open $out_fh, '|-', 'more' or die "Error: Can't open '|-' 'more' because $!";
    }
    elsif (!$opt_quiet) {
        open $out_fh, '>&STDOUT' or die "Error: duplicate STDOUT because $!";
    }

    if (defined $out_fh) {
        while (my $_ = <$page_fh>) {
            print {$out_fh} $_;
        }

        close $out_fh;
    }
}

1;

__END__