view release on metacpan or  search on metacpan

src/Universal.pm  view on Meta::CPAN

    SOH         => chr(0x01),
    STX         => chr(0x02),
    EOT         => chr(0x04),
    ACK         => chr(0x06),
    NAK         => chr(0x15),
    CAN         => chr(0x18),
    C_CHAR      => 'C',

    SUPPRESS_GO_AHEAD => 3,
    LINEMODE          => 34,
    SE                => 240,
    NOP               => 214,
    DATA_MARK         => 242,
    BREAK             => 243,
    INTERRUPT_PROCESS => 244,
    ABORT_OUTPUT      => 245,
    ARE_YOU_THERE     => 246,
    ERASE_CHARACTER   => 247,
    ERASE_LINE        => 248,
    GO_AHEAD          => 249,
    SB                => 250,
    WILL              => 251,
    WONT              => 252,
    DO                => 253,
    DONT              => 254,
    IAC               => 255,

    PI           => (4 * atan2(1, 1)),
    MENU_CHOICES => ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', '1', '2', '3', '4', '5', '6', '7', '8', '9', '=', '-', '+', '*', '!', '@', '#', '$', '%', '^', '&'],

    SPEEDS       => {    # This depends on the granularity of Time::HiRes
        'FULL'   => 0,
        '300'    => 1 / (300 / 8),
        '600'    => 1 / (600 / 8),
        '1200'   => 1 / (1200 / 8),
        '2400'   => 1 / (2400 / 8),
        '4800'   => 1 / (4800 / 8),
        '9600'   => 1 / (9600 / 8),
        '19200'  => 1 / (19200 / 8),
        '38400'  => 1 / (38400 / 8),
        '57600'  => 1 / (57600 / 8),
        '115200' => 1 / (115200 / 8),
    },
};
use open qw(:std :utf8);

# Modules
use Exporter 'import';
use threads (
    'yield',
    'exit' => 'threads_only',
    'stringify',
);
use Debug::Easy;
use DateTime;
use DBI;
use DBD::mysql;
use File::Basename;
use Time::HiRes qw(time sleep);
use Term::ReadKey;
use Term::ANSIScreen qw( :cursor :screen );
use Term::ANSIColor;
use Text::Format;
use Text::SimpleTable;
use List::Util qw(min max);
use IO::Socket qw(AF_INET SOCK_STREAM SHUT_WR SHUT_RDWR SHUT_RD);
use Cache::Memcached::Fast;
use Number::Format 'format_number';
use XML::RSS::LibXML;
use File::Path;
use File::Which;
use Fcntl qw(:DEFAULT :flock);
use IO::Select;
use POSIX qw(:sys_wait_h);
# use Carp::Always;

BEGIN {
    our @ISA    = qw(Exporter);
    our @EXPORT = qw(
      TRUE
      FALSE
      YES
      NO
      BLOCKING
      NONBLOCKING
      PASSWORD
      ECHO
      SILENT
      NUMERIC

      ANSI
      ASCII
      ATASCII
      PETSCII

      SUPPRESS_GO_AHEAD
      SE
      LINEMODE
      NOP
      DATA_MARK
      BREAK
      INTERRUPT_PROCESS
      ABORT_OUTPUT
      ARE_YOU_THERE
      ERASE_CHARACTER
      ERASE_LINE
      GO_AHEAD
      SB
      WILL
      WONT
      DO
      DONT
      IAC
    );
    our @EXPORT_OK = qw();
    binmode(STDOUT, ":encoding(UTF-8)");

    # VERSIONS #
} ## end BEGIN

sub DESTROY { # Disconnects from the database

src/Universal.pm  view on Meta::CPAN

    }
    $self->{'debug'}->DEBUG(['End Parse Telnet Escape']);
    return (TRUE);
} ## end sub parse_telnet_escape

sub flush_input {
    my $self = shift;

    my $key;
    unless ($self->{'sysop'} || $self->{'local_mode'}) {
        my $handle = $self->{'cl_socket'};
        ReadMode 'noecho', $handle;
        do {
            $key = ReadKey(-1, $handle);
        } until (!defined($key) || $key eq '');
        ReadMode 'restore', $handle;
    } else {
        ReadMode 'ultra-raw';
        do {
            $key = ReadKey(-1);
        } until (!defined($key) || $key eq '');
        ReadMode 'restore';
    } ## end else
    return (TRUE);
} ## end sub flush_input

sub get_key {
    my $self     = shift;
    my $echo     = shift;
    my $blocking = shift;

    my $key     = undef;
    my $mode    = $self->{'USER'}->{'text_mode'};
    my $timeout = $self->{'USER'}->{'timeout'} * 60;
    local $/ = "\x{00}";
    if ($self->{'sysop'} || $self->{'local_mode'}) {
        ReadMode 'ultra-raw';
        $key = ($blocking) ? ReadKey($timeout) : ReadKey(-1);
        ReadMode 'restore';
        threads->yield;
    } elsif ($self->is_connected()) {
        my $handle = $self->{'cl_socket'};
        ReadMode 'ultra-raw', $self->{'cl_socket'};
        my $escape;
        do {
            $escape = FALSE;
            $key    = ($blocking) ? ReadKey($timeout, $handle) : ReadKey(-1, $handle);
            if ($key eq chr(255)) {    # IAC sequence
                my $command = ReadKey($timeout, $handle);
                my $option  = ReadKey($timeout, $handle);
                $self->parse_telnet_escape(ord($command), ord($option));
                $escape = TRUE;
            } ## end if ($key eq chr(255))
        } until (!$escape || $self->is_connected());
        ReadMode 'restore', $self->{'cl_socket'};
        threads->yield;
    } ## end elsif ($self->is_connected...)
    return ($key) if ($key eq chr(13));
    if ($key eq chr(127) or $key eq chr(7)) {
        if ($mode eq 'ANSI') {
            $key = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
        } elsif ($mode eq 'ATASCII') {
            $key = $self->{'atascii_meta'}->{'BACKSPACE'}->{'out'};
        } elsif ($mode eq 'PETSCII') {
            $key = $self->{'petscii_meta'}->{'BACKSPACE'}->{'out'};
        } else {
            $key = $self->{'ascii_meta'}->{'BACKSPACE'}->{'out'};
        }
        $self->output("$key $key") if ($echo);
    } ## end if ($key eq chr(127) or...)
    threads->yield;
    return ($key);
} ## end sub get_key


sub get_line {
    my $self = shift;
    my $type = shift;
    my $line = shift;

    my $echo    = $type->{'type'};
    my $limit   = $type->{'max'};
    my $choices = $type->{'choices'} if (exists($type->{'choices'}));
    if (exists($type->{'default'})) {
        $line = $type->{'default'};
    }

    $self->{'debug'}->DEBUG(['Start Get Line']);
    $self->flush_input();

    my $key;

    $self->output($line) if ($line ne '');
    my $mode = $self->{'USER'}->{'text_mode'};
    my $backspace;
    if ($mode eq 'ANSI') {
        $backspace = $self->{'ansi_meta'}->{'cursor'}->{'BACKSPACE'}->{'out'};
    } elsif ($mode eq 'ATASCII') {
        $backspace = $self->{'atascii_meta'}->{'BACKSPACE'}->{'out'};
    } elsif ($mode eq 'PETSCII') {
        $backspace = $self->{'petscii_meta'}->{'BACKSPACE'}->{'out'};
    } else {
        $backspace = $self->{'ascii_meta'}->{'BACKSPACE'}->{'out'};
    }

    if ($echo == PASSWORD) {
        $self->{'debug'}->DEBUG(['  Mode:  PASSWORD']);
        while (($self->is_connected() || $self->{'local_mode'}) && $key ne chr(13) && $key ne chr(3)) {
            if (length($line) <= $limit) {
                $key = $self->get_key(SILENT, BLOCKING);
                return ('') if (defined($key) && $key eq chr(3));
                if (defined($key) && $key ne '') {
                    if ($key eq $backspace) {
                        my $len = length($line);
                        if ($len > 0) {
                            $self->output("$key $key");
                            chop($line);
                        }
                    } elsif ($key ne chr(13) && $key ne chr(3) && $key ne chr(10) && ord($key) > 31 && ord($key) < 127) {
                        $self->output('*');
                        $line .= $key;
                    } else {
                        $self->output('[% RING BELL %]');
                    }
                } ## end if (defined($key) && $key...)
            } else {
                $key = $self->get_key(SILENT, BLOCKING);
                if (defined($key) && $key eq chr(3)) {
                    return ('');
                }
                if (defined($key) && ($key eq $backspace)) {
                    $key = $backspace;
                    $self->output("$key $key");
                    chop($line);
                } else {
                    $self->output('[% RING BELL %]');
                }
            } ## end else [ if (length($line) <= $limit)]
        } ## end while (($self->is_connected...))
    } elsif ($echo == RADIO) {
        $self->{'debug'}->DEBUG(['  Mode:  RADIO']);

        my $mapping;
        my @menu_choices = @{$self->{'MENU CHOICES'}};

        foreach my $choice (@{$choices}) {
            $mapping->{ shift(@menu_choices) } = {
                'command'      => $choice,
                'color'        => 'WHITE',
                'access_level' => 'USER',
                'text'         => $choice,
            }
        }
        $self->output("\n\n");
        $self->show_choices($mapping);
        $self->prompt('Choose');
        my $key;