view release on metacpan or  search on metacpan

lib/Net/Clacks/Client.pm  view on Meta::CPAN

package Net::Clacks::Client;
#---AUTOPRAGMASTART---
use v5.36;
use strict;
use diagnostics;
use mro 'c3';
use English qw(-no_match_vars);
use Carp qw[carp croak confess cluck longmess shortmess];
our $VERSION = 35;
use autodie qw( close );
use Array::Contains;
use utf8;
use Encode qw(is_utf8 encode_utf8 decode_utf8);
use Data::Dumper;
use builtin qw[true false is_bool];
no warnings qw(experimental::builtin); ## no critic (TestingAndDebugging::ProhibitNoWarnings)
#---AUTOPRAGMAEND---

use IO::Socket::IP;
#use IO::Socket::UNIX;
use Time::HiRes qw[sleep usleep time];
use Sys::Hostname;
use IO::Select;
use IO::Socket::SSL;
use MIME::Base64;

sub new($class, $server, $port, $username, $password, $clientname, $iscaching = 0) {
    my $self = bless {}, $class;

    if(!defined($server) || !length($server)) {
        croak("server not defined!");
    }
    if(!defined($port) || !length($port)) {
        croak("port not defined!");
    }
    if(!defined($username) || !length($username)) {
        croak("username not defined!");
    }
    if(!defined($password) || !length($password)) {
        croak("password not defined!");
    }
    if(!defined($clientname) || !length($clientname)) {
        croak("clientname not defined!");
    }

    $self->{server} = $server;
    $self->{port} = $port;

    $self->init($username, $password, $clientname, $iscaching);

    return $self;
}

sub newSocket($class, $socketpath, $username, $password, $clientname, $iscaching = 0) {
    my $self = bless {}, $class;

    if(!defined($socketpath) || !length($socketpath)) {
        croak("socketpath not defined!");
    }
    if(!defined($username) || !length($username)) {
        croak("username not defined!");
    }
    if(!defined($password) || !length($password)) {
        croak("password not defined!");
    }
    if(!defined($clientname) || !length($clientname)) {
        croak("clientname not defined!");
    }

    my $udsloaded = 0;
    eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
        require IO::Socket::UNIX;
        $udsloaded = 1;
    };
    if(!$udsloaded) {
        croak("Specified a unix domain socket, but i couldn't load IO::Socket::UNIX!");
    }

    $self->{socketpath} = $socketpath;

    $self->init($username, $password, $clientname, $iscaching);

    return $self;
}

lib/Net/Clacks/Client.pm  view on Meta::CPAN

    $self->{memcached_compatibility} = 0;

    $self->{remembrancenames} = [
        'Ivy Bdubs',
        'Terry Pratchett',
        'Sven Guckes',
        'Sheila', # faithful four-legged family member of @NightStorm_KPC
    ];
    $self->{remembranceinterval} = 3600; # One hour
    $self->{nextremembrance} = time + $self->{remembranceinterval};

    $self->reconnect();

    return;
}

sub reconnect($self) {
    # Clean up old selector before deleting socket
    if(defined($self->{selector}) && defined($self->{socket})) {
        eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
            $self->{selector}->remove($self->{socket});
        };
    }
    if(defined($self->{socket})) {
        delete $self->{socket};
    }
    undef $self->{selector};

    if(!$self->{firstconnect}) {
        # Not our first connection (=real reconnect).
        # wait a short random time before reconnecting. In case all
        # clients got disconnected, we want to avoid having all clients reconnect
        # at the exact same time
        my $waittime = rand(4000)/1000;
        sleep($waittime);
    }

    my $socket;
    if(defined($self->{server}) && defined($self->{port})) {
        $socket = IO::Socket::IP->new(
            PeerHost => $self->{server},
            PeerPort => $self->{port},
            Type => SOCK_STREAM,
        ) or croak("Failed to connect to Clacks TCP message service: $ERRNO");
    } elsif(defined($self->{socketpath})) {
        $socket = IO::Socket::UNIX->new(
            Peer => $self->{socketpath},
            Type => SOCK_STREAM,
        ) or croak("Failed to connect to Clacks Unix Domain Socket message service: $ERRNO");
    } else {
        croak("Neither TCP nor Unix domain socket specified. Don't know where to connect to.");
    }

    #binmode($socket, ':bytes');
    $socket->blocking(0);


    if(ref $socket ne 'IO::Socket::UNIX') {
        # ONLY USE SSL WHEN RUNNING OVER THE NETWORK
        # There is simply no point in running it over a local socket.
        IO::Socket::SSL->start_SSL($socket,
                                   SSL_verify_mode => SSL_VERIFY_NONE,
                                   ) or croak("Can't use SSL: " . $SSL_ERROR);
    }

    $self->{socket} = $socket;
    $self->{selector} = IO::Select->new($self->{socket});
    $self->{failcount} = 0;
    $self->{lastping} = time;
    $self->{inbuffer} = '';
    $self->{incharbuffer} = [];
    $self->{outbuffer} = '';
    $self->{serverinfo} = 'UNKNOWN';
    $self->{needreconnect} = 0;
    $self->{firstline} = 1;
    $self->{headertimeout} = time + 15;

    # Do *not* nuke "inlines" array, since it may hold "QUIT" messages that the client wants to handle, for example, to re-issue
    # "LISTEN" commands.
    # $self->{inlines} = ();

    if($self->{firstconnect}) {
        $self->{firstconnect} = 0;
    } else {
        push @{$self->{inlines}}, "RECONNECTED";
    }

    # Startup "handshake". As everything else, this is asyncronous, both server and
    # client send their respective version strings and then wait to recieve their counterparts
    # Also, this part is REQUIRED, just to make sure we actually speek to CLACKS protocol
    $self->{outbuffer} .= 'CLACKS ' . $self->{clientname} . "\r\n";
    $self->{outbuffer} .= 'OVERHEAD A ' . $self->{authtoken} . "\r\n";
    $self->doNetwork();

    return;
}

sub activate_memcached_compat($self) {
    $self->{memcached_compatibility} = 1;
    return;
}

sub getRawSocket($self) {
    if($self->{needreconnect}) {
        $self->reconnect();
    }

    return $self->{socket};
}

sub doNetwork($self, $readtimeout = 0) {
    if(!defined($readtimeout)) {
        # Don't wait
        $readtimeout = 0;
    }

    # Negative read timeout means "send only"

    if($self->{needreconnect}) {
        $self->reconnect();
    }