view release on metacpan or  search on metacpan

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

# Copyright (C) 2011-2024 A S Lewis
#
# This program is free software: you can redistribute it and/or modify it under the terms of the GNU
# Lesser Public License as published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without
# even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser Public License for more details.
#
# You should have received a copy of the GNU Lesser Public License along with this program.  If not,
# see <http://www.gnu.org/licenses/>.
#
# Games::Axmud::Obj::Telnet, a modification of Net::Telnet (v3.04) by Jay Rogers
#
# List of changes (besides cosmetic ones):
#   - Removed user documentation
#   - 'use warnings' and 'use diagnostics' added
#   - Fixed apparent problem in ->_optimal_blksize, which caused a warning
#   - Fixed apparent problem in ->_negotiate_recv_disable and ->_negotiate_recv_enable, which causes
#       errors when the $$state argument was 'undef'
#   - Removed 'require 5.002', since Axmud requires 5.008 anyway
#   - Removed 'require FileHandle' for the same reason
#   - Implemented MCCP (Mud Client Compression Protocol, http://tintin.sourceforge.io/mccp/)
#       - Added 'use Compress::Zlib'
#       - Added new IVs to ->new() : ->axmud_mccp_mode, ->axmud_zlib_obj and ->axmud_session
#       - Modified _>_fillbuf to decompress text when MCCP enabled
#       - Added new function ->_disable_mccp, called by ->_fillbuf
#       - Added new function ->axmud_session, called by ->new
#   - In ->new, commented out automatic handling of TELOPT_ECHO and TELOPT_SGA, which are now
#       handled by Axmud itself
#   - Added some new constants to @EXPORT_OK and %Axmud_Telopts describing various MUD protocols,
#       and modified ->_log_option to use them
#   - Modified ->localfamily, ->_parse_family and ->_parse_localfamily to cope with the error seen
#       on Debian/Ubuntu:
#           'WARNING: Argument "2.020_03" isn't numeric in numeric ge (>=)'
#   - Commented out $VERSION as it causes Kwalitee errors
#   - Modified ->open to enable TCP keepalive packets on all connections
#   - Modified ->_interpret_tcmd so it doesn't gobble up IAC GA

{ package Games::Axmud::Obj::Telnet;

    use strict;
    use warnings;
#   use diagnostics;

    ## Module export.
    use vars qw(@EXPORT_OK);
    @EXPORT_OK = qw(
        TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL
        TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO
        TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE
        TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH
        TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS
        TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP
        TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD
        TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII
        TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP
        TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR
        TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME
        TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW
        TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON
        TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON
        TELOPT_TN3270E TELOPT_CHARSET TELOPT_COMPORT TELOPT_KERMIT
        TELOPT_EXOPL

        TELOPT_MSDP TELOPT_MSSP TELOPT_MCCP1 TELOPT_MCCP2 TELOPT_MSP
        TELOPT_MXP TELOPT_ZMP TELOPT_AARD102 TELOPT_ATCP TELOPT_GMCP
    );

    ## Module import.
    use Exporter ();
    use Compress::Zlib;
#    use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in);
    use Socket qw(AF_INET SOCK_STREAM SOL_SOCKET SO_KEEPALIVE inet_aton sockaddr_in);
    use Symbol qw(qualify);

    ## Base classes.
    use vars qw(@ISA);
    @ISA = qw(Exporter);
    if (&_io_socket_include) {  # successfully required module IO::Socket
        push @ISA, "IO::Socket::INET";
    }
    my $AF_INET6 = &_import_af_inet6();
    my $AF_UNSPEC = &_import_af_unspec() || 0;
    my $AI_ADDRCONFIG = &_import_ai_addrconfig() || 0;
    my $EAI_BADFLAGS = &_import_eai_badflags() || -1;
    my $EINTR = &_import_eintr();

    ## Global variables.
#    use vars qw($VERSION @Telopts %Axmud_Telopts);
#    $VERSION = "3.04";
    use vars qw(@Telopts %Axmud_Telopts);
    @Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAMS", "STATUS",
            "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS",
            "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII",
            "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP",
            "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD",

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

        eval {
            ## Turn on timer.
            local $SIG{"__DIE__"} = "DEFAULT";
            local $SIG{ALRM} = sub { die "timed-out\n" };
            alarm $timeout;

            if ($family eq "ipv4") {
            ## Lookup server's IP address.
            $ip_addr = inet_aton $host
                or die "unknown remote host: $host\n";
            $af = AF_INET;
            $remote_addr = sockaddr_in($port, $ip_addr);
            }
            else {  # family is "ipv6" or "any"
            ## Lookup server's IP address.
            $flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0;
            ($err, @ai) = Socket::getaddrinfo($host, $port,
                              { socktype => SOCK_STREAM,
                                "family" => $af{$family},
                                "flags" => $flags_hint });
            if ($err == $EAI_BADFLAGS) {
                ## Try again with no flags.
                ($err, @ai) = Socket::getaddrinfo($host, $port,
                                  {socktype => SOCK_STREAM,
                                   "family"=> $af{$family},
                                   "flags" => 0 });
            }
            die "unknown remote host: $host: $err\n"
                if $err or !@ai;
            $af = $ai[0]{"family"};
            $remote_addr = $ai[0]{addr};
            }

            ## Create a socket and attach the filehandle to it.
            socket $self, $af, SOCK_STREAM, 0
            or die "problem creating socket: $!\n";

            ## Bind to a local network interface.
            if (length $localhost) {
            if ($lfamily eq "ipv4") {
                ## Lookup server's IP address.
                $ip_addr = inet_aton $localhost
                or die "unknown local host: $localhost\n";
                $local_addr = sockaddr_in(0, $ip_addr);
            }
            else {  # local family is "ipv6" or "any"
                ## Lookup local IP address.
                ($err, @ai) = Socket::getaddrinfo($localhost, 0,
                                  {socktype => SOCK_STREAM,
                                   "family"=>$af{$lfamily},
                                   "flags" => 0 });
                die "unknown local host: $localhost: $err\n"
                if $err or !@ai;
                $local_addr = $ai[0]{addr};
            }

            bind $self, $local_addr
                or die "problem binding to \"$localhost\": $!\n";
            }

            ## Enable keepalive packets
            setsockopt($self, SOL_SOCKET, SO_KEEPALIVE, 1);

            ## Open connection to server.
            connect $self, $remote_addr
            or die "problem connecting to \"$host\", port $port: $!\n";
        };
        alarm 0;

        ## Check for error.
        if ($@ =~ /^timed-out$/) {  # time out failure
            $s->{timedout} = 1;
            $self->close;
            if (!$remote_addr) {
            return $self->error("unknown remote host: $host: ",
                        "name lookup timed-out");
            }
            elsif (length($localhost) and !$local_addr) {
            return $self->error("unknown local host: $localhost: ",
                        "name lookup timed-out");
            }
            else {
            return $self->error("problem connecting to \"$host\", ",
                        "port $port: connect timed-out");
            }
        }
        elsif ($@) {  # hostname lookup or connect failure
            $self->close;
            chomp $@;
            return $self->error($@);
        }
        }
        else {  # don't use a timeout
        $timeout = undef;

        if ($family eq "ipv4") {
            ## Lookup server's IP address.
            $ip_addr = inet_aton $host
            or return $self->error("unknown remote host: $host");
            $af = AF_INET;
            $remote_addr = sockaddr_in($port, $ip_addr);
        }
        else {  # family is "ipv6" or "any"
            ## Lookup server's IP address.
            $flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0;
            ($err, @ai) = Socket::getaddrinfo($host, $port,
                              { socktype => SOCK_STREAM,
                            "family" => $af{$family},
                            "flags" => $flags_hint });
            if ($err == $EAI_BADFLAGS) {
            ## Try again with no flags.
            ($err, @ai) = Socket::getaddrinfo($host, $port,
                              { socktype => SOCK_STREAM,
                                "family"=> $af{$family},
                                "flags" => 0 });
            }
            return $self->error("unknown remote host: $host")
            if $err or !@ai;
            $af = $ai[0]{"family"};
            $remote_addr = $ai[0]{addr};
        }