File Coverage

blib/lib/Net/DirectConnect/nmdc.pm

Criterion	Covered	Total	%
statement	27	92	29.3
branch	0	26	0.0
condition	0	37	0.0
subroutine	9	18	50.0
pod	0	1	0.0
total	36	174	20.6

#$Id: adc.pm 594 2010-01-30 23:10:17Z pro $ $URL: svn://svn.setun.net/dcppp/trunk/lib/Net/DirectConnect/adc.pm $
#UNFINISHED
package    #hide from cpan
  Net::DirectConnect::nmdc;
use strict;
no strict qw(refs);
use warnings "NONFATAL" => "all";
no warnings qw(uninitialized);
no if $] >= 5.017011, warnings => 'experimental::smartmatch';
use utf8;
#use Time::HiRes qw(time sleep);
use Data::Dumper;    #dev only
$Data::Dumper::Sortkeys = $Data::Dumper::Useqq = $Data::Dumper::Indent = 1;
use Net::DirectConnect;
#use Net::DirectConnect::clicli;
#use Net::DirectConnect::http;
#use Net::DirectConnect::httpcli;
our $VERSION = ( split( ' ', '$Revision: 594 $' ) )[1];
use base 'Net::DirectConnect';

sub init {
  my $self = shift;
  #shift if $_[0] eq __PACKAGE__;
  #print "nmdcinit SELF=", $self, "REF=", ref $self, "  P=", @_, "package=", __PACKAGE__, "\n\n";
  #$self->SUPER::new();
  #%$self = (
  #%$self,
  local %_ = (
    'Nick'     => 'NetDCBot',
    'port'     => 411,
    'host'     => 'localhost',
    'protocol' => 'nmdc',
    'nmdc'     => 1,
    #'Pass' => '',
    #'key'  => 'zzz',
    #'auto_wait'        => 1,
    #'search_every' => 10, 'search_every_min' => 10, 'auto_connect' => 1,
    #ADC
    #'connect_protocol' => 'ADC/0.10', 'message_type' => 'H',
    #@_,
    'incomingclass' => 'Net::DirectConnect::clicli',
    #'incomingclass' => __PACKAGE__,    #'Net::DirectConnect::adc',
    #no_print => { 'INF' => 1, 'QUI' => 1, 'SCH' => 1, },
    #http://www.dcpp.net/wiki/index.php/%24MyINFO
    'description' => 'perl ' . __PACKAGE__ . ' bot',
    #====MOVE TO NMDC
    'connection' => 'LAN(T3)',
    #NMDC1: 28.8Kbps, 33.6Kbps, 56Kbps, Satellite, ISDN, DSL, Cable, LAN(T1), LAN(T3)
    #NMDC2: Modem, DSL, Cable, Satellite, LAN(T1), LAN(T3)
    'flag' => '1',    # User status as ascii char (byte)
                      #1 normal
                      #2, 3 away
                      #4, 5 server               The server icon is used when the client has
                      #6, 7 server away          uptime > 2 hours, > 2 GB shared, upload > 200 MB.
                      #8, 9 fireball             The fireball icon is used when the client
                      #10, 11 fireball away      has had an upload > 100 kB/s.
    'email' => '[e-mail]', 'sharesize' => 10 * 1024 * 1024 * 1024 + int rand( 1024 * 1024 ),    #10GB
    'client' => 'perl',    #'dcp++',                                                              #++: indicates the client
                           #'protocol' => 'nmdc',    # or 'adc'
    'V' => $Net::DirectConnect::VERSION,   #. '_' . ( split( ' ', '$Revision: 656 $' ) )[1],    #V: tells you the version number
         #'M' => 'A',      #M: tells if the user is in active (A), passive (P), or SOCKS5 (5) mode
    'H' => '0/1/0'
    , #H: tells how many hubs the user is on and what is his status on the hubs. The first number means a normal user, second means VIP/registered hubs and the last one operator hubs (separated by the forward slash ['/']).
    'S' => '3',      #S: tells the number of slots user has opened
    'O' => undef,    #O: shows the value of the "Automatically open slot if speed is below xx KiB/s" setting, if non-zero
    'lock'         => 'EXTENDEDPROTOCOLABCABCABCABCABCABC Pk=DCPLUSPLUS0.668ABCABC',
    'cmd_bef'      => '$',
    'cmd_aft'      => '|',
    'auto_say_cmd' => [qw(welcome chatline To)],
  );
  #$self->{$_} ||= $_{$_} for keys %_;
  #$self->log('dev', 's0',$self->{'sharesize'});
  !exists $self->{$_} ? $self->{$_} ||= $_{$_} : () for keys %_;
  #$self->log('dev', 's1',$self->{'sharesize'});
  %_ = (
    #charset_chat => 'cp1251',
    #charset_nick => 'cp1251',
    charset_protocol => 'cp1251',
  );
  $self->{$_} = $_{$_} for keys %_;
#$self->log('dev', 'chPROTO:',$self->{'charset_protocol'});
#print 'adc init now=',Dumper $self;
#$self->{'periodic'}{ __FILE__ . __LINE__ } = sub {      my $self = shift if ref $_[0]; $self->cmd( 'search_buffer', ) if $self->{'socket'}; };
#http://www.dcpp.net/wiki/index.php/LockToKey :
  $self->{'lock2key'} ||= sub {
    my $self = shift if ref $_[0];
    #return $self->{lock};
    my ($lock) = @_;
    #$self->{'log'}->( 'dev', 'making lock from', $lock );
    $lock = Encode::encode $self->{charset_protocol}, $lock, Encode::FB_WARN if $self->{charset_protocol};
    #$self->{'log'}->( 'dev', 'making lock from2:', $lock );
    my @lock = split( //, $lock );
    my $i;
    my @key = ();
    foreach (@lock) { $_ = ord; }
    push( @key, $lock[0] ^ 5 );
    for ( $i = 1 ; $i < @lock ; $i++ ) { push( @key, ( $lock[$i] ^ $lock[ $i - 1 ] ) ); }
    for ( $i = 0 ; $i < @key ; $i++ ) { $key[$i] = ( ( ( $key[$i] << 4 ) & 240 ) | ( ( $key[$i] >> 4 ) & 15 ) ) & 0xff; }
    $key[0] = $key[0] ^ $key[ @key - 1 ];

    foreach (@key) {
      if ( $_ == 0 || $_ == 5 || $_ == 36 || $_ == 96 || $_ == 124 || $_ == 126 ) { $_ = sprintf( '/%%DCN%03i%%/', $_ ); }
      else                                                                        { $_ = chr; }
    }
    local $_ = join( '', @key );
    $_ = Encode::decode $self->{charset_protocol}, $_ if $self->{charset_protocol};
    return $_;
  };
  $self->{'tag'} ||= sub {
    my $self = shift;
    $self->{'client'} . ' ' . join( ',', map $_ . ':' . $self->{$_}, grep defined( $self->{$_} ), qw(V M H S O) );
  };
  $self->{'myinfo'} ||= sub {
    my $self = shift;
    return
        $self->{'Nick'} . ' '
      . $self->{'description'} . '<'
      . $self->tag() . '>' . '$' . ' ' . '$'
      . $self->{'connection'}
      . ( length( $self->{'flag'} ) ? chr( $self->{'flag'} ) : '' ) . '$'
      . $self->{'email'} . '$'
      . $self->{'sharesize'} . '$';
  };
  $self->{'supports'} ||= sub {
    my $self = shift;
    return join ' ', grep $self->{$_}, @{ $self->{'supports_avail'} };
  };
  $self->{'supports_parse'} ||= sub {
    my $self = shift;
    my ( $str, $save ) = @_;
    $save->{$_} = 1 for split /\s+/, $str;
    delete $save->{$_} for grep !length $save->{$_}, keys %$save;
    return wantarray ? %$save : $save;
  };
  $self->{'info_parse'} ||= sub {
    my $self = shift;
    my ( $info, $save ) = @_;
    $save->{'info'} = $info;
    $save->{'description'} = $1 if $info =~ s/^([^<\$]+)(<|\$)/$2/;
    ( $save->{'tag'}, $save->{'M'}, $save->{'connection'}, $save->{'email'}, $save->{'sharesize'} ) = split /\s*\$\s*/, $info;
    $save->{'flag'} = ord($1) if $save->{'connection'} =~ s/([\x00-\x1F])$//e;
    $self->tag_parse( $save->{'tag'}, $save );
    delete $save->{$_} for grep !length $save->{$_}, keys %$save;
    return wantarray ? %$save : $save;
  };
  $self->{'tag_parse'} ||= sub {
    my $self = shift;
    my ( $tag, $save ) = @_;
    $save->{'tag'} = $tag;
    $tag =~ s/(^\s*<\s*)|(\s*>\s*$)//g;
    $save->{'client'} = $1 if $tag =~ s/^(\S+)\s*//;
    /(.+):(.+)/, $save->{$1} = $2 for split /,/, $tag;
    return wantarray ? %$save : $save;
  };
  $self->{'make_hub'} ||= sub {
    my $self = shift if ref $_[0];
    $self->{'hub_name'} ||=
      $self->{'host'};    # . ( ( $self->{'port'} and $self->{'port'} != 411 ) ? ':' . $self->{'port'} : '' );
    $self->{'hub_name'} =~ s/:411$//;
    #$self->log('dev', $self->{'hub_name'});
  },;
}
1;