File Coverage

blib/lib/Term/CallEditor.pm

Criterion	Covered	Total	%
statement	58	80	72.5
branch	21	46	45.6
condition	5	11	45.4
subroutine	9	10	90.0
pod	1	1	100.0
total	94	148	63.5

# -*- Perl -*-
#
# Solicits data from an external editor. Run perldoc(1) on this module
# for additional documentation.

package Term::CallEditor;

use strict;
use warnings;

require 5.008;

use vars qw(@EXPORT @ISA $VERSION $errstr);
@EXPORT = qw(solicit);
@ISA    = qw(Exporter);
use Exporter;

use File::Temp qw(tempfile);
use IO::Handle;    # for way olden versions of Perl
use POSIX qw(getpgrp tcgetpgrp);
use Text::ParseWords qw(shellwords);

$VERSION = '1.00';

sub solicit {
    my $message = shift;
    my $params  = shift || {};
    $errstr = '';

    unless (exists $params->{skip_interative} and $params->{skip_interative}) {
        return unless _is_interactive();
    }

    File::Temp->safe_level($params->{safe_level}) if exists $params->{safe_level};
    my ($tfh, $filename) = tempfile(UNLINK => 1);

    unless ($tfh and $filename) {
        $errstr = 'no temporary file';
        return;
    }

    if (exists $params->{binmode_layer}
        and defined $params->{binmode_layer}) {
        binmode($tfh, $params->{binmode_layer});
    } elsif ($params->{BINMODE}) {
        binmode($tfh);
    }

    select((select($tfh), $|++)[0]);

    if (defined $message) {
        my $ref = ref $message;
        if (not $ref) {
            print $tfh $message;
        } elsif ($ref eq 'SCALAR') {
            print $tfh $$message;
        } elsif ($ref eq 'ARRAY') {
            print $tfh "@$message";
        } elsif ($ref eq 'GLOB') {
            while (my $line = readline $message) {
                print $tfh $line;
            }
        } elsif (UNIVERSAL::can($message, 'getlines')) {
            print $tfh $message->getlines;
        }
        # Help the bits reach the disk
        $tfh->flush();
        $params->{NOSYNC} = 1 if $^O =~ m/Win32/;
        if (!$params->{NOSYNC}) {
            $tfh->sync();
        }
    }

    my $ed = defined $params->{DEFAULT_EDITOR} ? $params->{DEFAULT_EDITOR} : 'vi';
    my $status;
    my @errs;
    # new in 2020, support for VISUAL !!
    for my $editor ($ENV{VISUAL}, $ENV{EDITOR}, $ed) {
        next unless length $editor;
        my @cmd = (shellwords($editor), $filename);
        $status = system { $cmd[0] } @cmd;
        if ($status != 0) {
            push @errs,
              ($status != -1)
              ? "external editor failed: editor=$editor, errstr=$?"
              : "could not launch program: editor=$editor, errstr=$!";
        } else {
            last;
        }
    }
    if ($status != 0) {
        $errstr = join ' ', @errs;
        return;
    }

    # Must reopen filename; the editor could pull a rename(2) on us, in
    # which case $tfh is now invalid.
    my $outfh;
    unless (open($outfh, '<', $filename)) {
        $errstr = "could not reopen tmp file: errstr=$!";
        return;
    }

    return wantarray ? ($outfh, $filename) : $outfh;
}

# Perl CookBook code to check whether terminal is interactive
sub _is_interactive {
    my $tty;
    unless (open $tty, '<', '/dev/tty') {
        $errstr = "cannot open /dev/tty: errno=$!";
        return;
    }
    my $tpgrp = tcgetpgrp fileno $tty;
    my $pgrp  = getpgrp();
    close $tty;
    unless ($tpgrp == $pgrp) {
        $errstr = "no exclusive control of tty: pgrp=$pgrp, tpgrp=$tpgrp";
        return;
    }
    return 1;
}

1;
__END__