File Coverage

blib/lib/Term/Detect/Software.pm

Criterion	Covered	Total	%
statement	11	173	6.3
branch	0	74	0.0
condition	0	28	0.0
subroutine	4	8	50.0
pod	2	2	100.0
total	17	285	5.9

package Term::Detect::Software;

use 5.010001;
use strict;
use warnings;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-02-10'; # DATE
our $DIST = 'Term-Detect-Software'; # DIST
our $VERSION = '0.227'; # VERSION

our @EXPORT_OK = qw(detect_terminal detect_terminal_cached);

my $dt_cache;
sub detect_terminal_cached {
    if (!$dt_cache) {
        $dt_cache = detect_terminal(@_);
    }
    $dt_cache;
}

sub _set_engine {
    my ($info, $engine) = @_;
    if ($engine eq 'konsole') {
        $info->{emulator_engine} = 'konsole';
        $info->{color_depth}     = 2**24;
        $info->{default_bgcolor} = '000000';
        $info->{unicode}         = 1;
        $info->{box_chars}       = 1;
    } elsif ($engine eq 'xterm') {
        $info->{emulator_engine} = 'xterm';
        $info->{color_depth}     = 256;
        $info->{default_bgcolor} = 'ffffff';
        $info->{unicode}         = 0;
        $info->{box_chars}       = 1;
    } elsif ($engine eq 'cygwin') {
        $info->{emulator_engine} = 'cygwin';
        $info->{color_depth}     = 16;
        $info->{default_bgcolor} = '000000';
        $info->{unicode}         = 0; # CONFIRM?
        $info->{box_chars}       = 1;
    } elsif ($engine eq 'linux') {
        # Linux virtual console
        $info->{emulator_engine} = 'linux';
        $info->{color_depth}     = 16;
        $info->{default_bgcolor} = '000000';
        # actually it can show a few Unicode characters like single borders
        $info->{unicode}         = 0;
        $info->{box_chars}       = 0;
    } elsif ($engine eq 'gnome-terminal') {
        $info->{emulator_engine} = 'gnome-terminal';
        $info->{unicode}           = 1;
        $info->{box_chars} = 1;
        # color_depth and default_bgcolor vary
    } elsif ($engine eq 'windows') {
        $info->{emulator_software} = 'windows';
        $info->{emulator_engine}   = 'windows';
        $info->{color_depth}       = 16;
        $info->{unicode}           = 0;
        $info->{default_bgcolor}   = '000000';
        $info->{box_chars}         = 0;
    } elsif ($engine eq 'dumb') {
        # run under CGI or something like that
        $info->{emulator_software} = 'dumb';
        $info->{emulator_engine}   = 'dumb';
        $info->{color_depth}       = 0;
        # XXX how to determine unicode support?
        $info->{default_bgcolor}   = '000000';
        $info->{box_chars}         = 0;
    } elsif ($engine eq 'rxvt') {
        $info->{emulator_engine}   = 'rxvt';
        $info->{color_depth}       = 16;
        $info->{unicode}           = 0;
        $info->{default_bgcolor}   = 'd6d2d0';
        $info->{box_chars}         = 1;
    } elsif ($engine eq 'st') {
        $info->{emulator_software} = 'st';
        $info->{emulator_engine}   = 'st';
        $info->{color_depth}       = 256;
        $info->{unicode}           = 1;
        $info->{default_bgcolor}   = '000000';
        $info->{box_chars}         = 1; # some characters are currently flawed though as of 0.6
    } elsif ($engine eq 'putty') {
        $info->{emulator_engine}   = 'putty';
        $info->{color_depth}       = 256;
        $info->{unicode}           = 0;
        $info->{default_bgcolor}   = '000000';
    } elsif ($engine eq 'xvt') {
        $info->{emulator_engine}   = 'xvt';
        $info->{color_depth}       = 0; # only support bold
        $info->{unicode}           = 0;
        $info->{default_bgcolor}   = 'd6d2d0';
    } else {
        die "Unknown engine '$engine'";
    }
}

sub detect_terminal {
    my @dbg;
    my $info = {_debug_info=>\@dbg};

  DETECT:
    {
        if (defined $ENV{PERL_TERM_DETECT_SOFTWARE_ENGINE}) {
            push @dbg, "skip detect, set to '$ENV{PERL_TERM_DETECT_SOFTWARE_ENGINE}' via PERL_TERM_DETECT_SOFTWARE_ENGINE env";
            _set_engine($info, $ENV{PERL_TERM_DETECT_SOFTWARE_ENGINE});
            last DETECT;
        }

        unless (defined $ENV{TERM}) {
            push @dbg, "skip: TERM env undefined";
            $info->{emulator_engine}   = '';
            $info->{emulator_software} = '';
            last DETECT;
        }

        if ($ENV{KONSOLE_DBUS_SERVICE} || $ENV{KONSOLE_DBUS_SESSION}) {
            push @dbg, "detect: konsole via KONSOLE_DBUS_{SERVICE,SESSION} env";
            _set_engine($info, 'konsole');
            last DETECT;
        }

        if ($ENV{XTERM_VERSION}) {
            push @dbg, "detect: xterm via XTERM_VERSION env";
            _set_engine($info, 'xterm');
            last DETECT;
        }

        if ($ENV{TERM} eq 'xterm' && ($ENV{OSTYPE} // '') eq 'cygwin') {
            push @dbg, "detect: xterm via TERM env (cygwin)";
            _set_engine($info, 'cygwin');
            last DETECT;
        }

        if ($ENV{TERM} eq 'linux') {
            push @dbg, "detect: linux via TERM env";
            _set_engine($info, 'linux');
            last DETECT;
        }

        my $gnome_terminal_terms = [qw/gnome-terminal guake xfce4-terminal
                                       mlterm lxterminal/];

        my $set_gnome_terminal_term = sub {
            _set_engine($info, 'gnome-terminal');
            $info->{emulator_software} = $_[0];

            # xfce4-terminal only shows 16 color, despite being
            # gnome-terminal-based?
            $info->{color_depth}       = $_[0] =~ /xfce4/ ? 16 : 256;

            if (grep { $_ eq $_[0] } (qw/mlterm/)) {
                $info->{default_bgcolor} = 'ffffff';
            } else {
                $info->{default_bgcolor} = '000000';
            }
        };

        if (grep { $_ eq ($ENV{COLORTERM} // '') } @$gnome_terminal_terms) {
            push @dbg, "detect: gnome-terminal via COLORTERM";
            $set_gnome_terminal_term->($ENV{COLORTERM});
            last DETECT;
        }

        if ($ENV{TERM} eq 'dumb' && $ENV{windir}) {
            push @dbg, "detect: windows via TERM & windir env";
            _set_engine($info, 'windows');
            last DETECT;
        }

        if ($ENV{TERM} eq 'dumb') {
            push @dbg, "detect: dumb via TERM env";
            _set_engine($info, 'dumb');
            last DETECT;
        }

      DETECT_VIA_PS:
        {
            # TODO: check under windows, because Proc::ProcessTable also works
            # under windows
            last if $^O =~ /Win/;

            last unless $ENV{PERL_TERM_DETECT_SOFTWARE_CHECK_PS};

            require Proc::Find::Parents;
            my $ppids = Proc::Find::Parents::get_parent_processes();
            unless (defined $ppids) {
                push @dbg, "skip: get_parent_processes returns undef";
                last;
            }

            # [0] is shell
            my $proc = @$ppids >= 2 ? $ppids->[1]{name} : '';
            #say "D:proc=$proc";
            if (grep { $_ eq $proc } @$gnome_terminal_terms) {
                push @dbg, "detect: gnome-terminal via procname ($proc)";
                $set_gnome_terminal_term->($proc);
                last DETECT;
            } elsif (grep { $_ eq $proc } (qw/rxvt mrxvt/)) {
                push @dbg, "detect: rxvt via procname ($proc)";
                $info->{emulator_software} = $proc;
                _set_engine($info, 'rxvt');
                last DETECT;
            } elsif ($proc eq 'st' && $ENV{TERM} eq 'xterm-256color') {
                push @dbg, "detect: st via procname";
                _set_engine($info, 'st');
                last DETECT;
            } elsif (grep { $_ eq $proc } (qw/pterm/)) {
                push @dbg, "detect: pterm via procname ($proc)";
                $info->{emulator_software} = $proc;
                _set_engine($info, 'putty');
                last DETECT;
            } elsif (grep { $_ eq $proc } (qw/xvt/)) {
                push @dbg, "detect: xvt via procname ($proc)";
                $info->{emulator_software} = $proc;
                _set_engine($info, 'xvt');
                last DETECT;
            }
        }

      DETECT_GENERIC:
        {
            unless (exists $info->{color_depth}) {
                if ($ENV{TERM} =~ /256color/) {
                    push @dbg, "detect color_depth: 256 via TERM env";
                    $info->{color_depth} = 256;
                } else {
                    require File::Which;
                    if (File::Which::which("tput")) {
                        my $res = `tput colors` + 0;
                        push @dbg, "detect color_depth: $res via tput";
                        $res = 16 if $res == 8; # 8 is basically 16 (8 low-intensity + 8 high-intensity)
                        $info->{color_depth} = $res;
                    }
                }
            }

            $info->{emulator_software} //= '(generic)';
            $info->{emulator_engine} //= '(generic)';
            $info->{unicode} //= 0;
            $info->{color_depth} //= 0;
            $info->{box_chars} //= 0;
            $info->{default_bgcolor} //= '000000';
        }

    } # DETECT

    # some additional detections

    # we're running under emacs, it doesn't support box chars
    if ($ENV{INSIDE_EMACS}) {
        $info->{inside_emacs} = 1;
        $info->{box_chars} = 0;
    }

    $info;
}

1;
# ABSTRACT: Detect terminal (emulator) software and its capabilities

__END__