view release on metacpan or  search on metacpan

lib/Net/DirectConnect.pm  view on Meta::CPAN

sub connect {    #$self->{'connect'} ||= sub {
  my $self = shift;
  #$self->log( 'c', 'connect0 inited', "MT:$self->{'message_type'}", ' with', $self->{'host'} );
  if ( $_[0] or $self->{'host'} =~ /:/ ) {
    $self->{'host'} = $_[0] if $_[0];
    $self->{'host'} =~ s{^(.*?)://}{};
    my $p = lc $1;
    $self->module_load('adcs') if $p eq 'adcs';
    #$self->protocol_init($p) if $p =~ /^adc/;
    $self->{'host'} =~ s{/.*}{}g;
    ( $self->{'host'}, $self->{'port'} ) = ( $1, $2 ) if $self->{'host'} =~ m{^\[(\S+)\]:(\d+)};     # [::1]:411
    ( $self->{'host'}, $self->{'port'} ) = ( $1, $2 ) if $self->{'host'} =~ s{^([^:]+):(\d+)$}{};    # 1.2.3.4:411
  }
  #$self->log('dev', 'host, port =', $self->{'host'}, $self->{'port'} );
  #$self->log( 'H:', ((),$self->{'host'} =~ /(:)/g)>1 );
  #$self->module_load('ipv6') if @{ [ $self->{'host'} =~ /(:)/g ] } > 1;
  #$self->{'port'} = $_[1] if $_[1];
  #print "Hhohohhhh" ,$self->{'protocol'},$self->{'host'};
  return 0
    if ( $self->{'socket'} and $self->{'socket'}->connected() )
    or grep { $self->{'status'} eq $_ } qw(destroy);    #connected
  $self->log(
    'info',
    "connecting to $self->{'protocol'}://[$self->{'host'}]:$self->{'port'} via $self->{'Proto'} class $self->{'socket_class'}",
    %{ $self->{'socket_options'} || {} }
  );
  #$self->{'status'}   = 'connecting';
  $self->{'status'}   = 'connecting_tcp';
  $self->{'outgoing'} = 1;
  #$self->{'port'}     = $1 if $self->{'host'} =~ s/:(\d+)//;
  delete $self->{'recv_buf'};
  #$self->log('dev', 'conn strt', $self->{'Timeout'}, $self->{'Proto'}, Socket::SOCK_STREAM);
  eval {
    $self->{'socket'} ||= $self->{'socket_class'}->new(
      'PeerAddr' => $self->{'host'},
      ( $self->{'port'}  ? ( 'PeerPort' => $self->{'port'} )  : () ),
      ( $self->{'Proto'} ? ( 'Proto'    => $self->{'Proto'} ) : () ),
      #( $self->{'Proto'} eq 'sctp' ? ( 'Type' => Socket::SOCK_STREAM ) : () ),
      #'Timeout'  => $self->{'Timeout'},
      #(
      #$self->{'nonblocking'} ? (
      'Blocking'   => 0,
      #'MultiHomed' => 1,    #del
                            #) : ()
                            #),
      %{ $self->{'socket_options'} },
      %{ $self->{'socket_options_connect'} },
    );
  };
  #$self->log('dev', 'connect end');
  $self->log(
    'err',
    "connect socket  error: $@,",
    Encode::decode( $self->{charset_fs}, $!, Encode::FB_WARN ),
    "[$self->{'socket'}]"
    ),
    return 1
    if !$self->{'socket'};
  #$self->log( 'dev',  'timeout to', $self->{'Timeout'});
  $self->{'socket'}->timeout( $self->{'Timeout'} ) if $self->{'Timeout'};    #timeout must be after new, ifyou want nonblocking
       #$self->log( 'dev',  'ssltry'), IO::Socket::SSL->start_SSL($self->{'socket'}) if $self->{'protocol'} eq 'adcs';
       #$self->log( 'err', "connect socket  error: $@, $! [$self->{'socket'}]" ), return 1 if !$self->{'socket'};
       #$self->{'socket'}->binmode(":encoding($self->{charset_protocol})");
       #$self->{charset_protocol} = 'utf8';
       #$self->log( 'dev', "set encoding of socket to [$self->{charset_protocol}]");
       #    binmode($self->{'socket'}, ":encoding($self->{charset_protocol})");
       #    binmode($self->{'socket'}, ":raw:encoding($self->{charset_protocol})");
       #    binmode($self->{'socket'}, ":encoding($self->{charset_protocol}):bytes");
       #    binmode($self->{'socket'}, ":$self->{charset_protocol}");
       #eval {$self->{'socket'}->fcntl( Fcntl::O_ASYNC,1);};    $self->log('warn', "cant Fcntl::O_ASYNC : $@") if $@;
       #eval {$self->{'socket'}->fcntl( Fcntl::O_NONBLOCK,1);};    $self->log('warn', "cant Fcntl::O_NONBLOCK : $@") if $@;
  $self->select_add();
  $self->{time_start} = time;
  #$self->log($self, 'connected2 inited',"MT:$self->{'message_type'}", ' with');
  #$self->log( 'dev', "connect_aft after", );
  #!!$self->select();
  #$self->log( 'dev', "connect after", );
  return 0;
}

sub connected {    #$self->{'connected'} ||= sub {
  my $self = shift;
  $self->get_my_addr();
  #$self->log( 'info', 'broken socket, cant get my ip'),
  #$self->destroy(),
  return unless $self->{'myip'};
  $self->{'status'} = 'connecting';
#$self->log( 'dev', "connected0", "[$self->{'socket'}] c=", $self->{'socket'}->connected(), 'p=', $self->{'socket'}->protocol() );
#$self->log( 'dev',  'timeout to', $self->{'Timeout_connected'});
  $self->{'socket'}->timeout( $self->{'Timeout_connected'} ) if $self->{'Timeout_connected'};
  $self->get_peer_addr();
  #$self->get_my_addr();
  #!$self->{'hostip'} ||= $self->{'host'};
  #my $localmask ||= join '|', @{ $self->{'local_mask_rfc'} || [] }, @{ $self->{'local_mask'} || [] };
  my $localmask ||= join '|', map { ref $_ eq 'ARRAY' ? @$_ : $_ }
    grep { $_ } $self->{'local_mask_rfc'},
    $self->{'local_mask'};
  my $is_local_ip = sub ($) {
    #$self->log( 'info', "test ip [$_[0]] in [$localmask] ");
    return $_[0] =~ /^(?:$localmask)\./;
  };
  $self->log( 'info', "my internal ip detected, using passive mode", $self->{'myip'}, $self->{'hostip'}, $localmask ),
    $self->{'M'} = 'P'
    if !$self->{'M'}
    and $is_local_ip->( $self->{'myip'} )
    and !$is_local_ip->( $self->{'hostip'} );
  $self->{'M'} ||= 'A';
  #$self->log( 'info', "mode set [$self->{'M'}] ");
  $self->log( 'info', "connect to $self->{'host'}($self->{'hostip'}):$self->{'port'} [me=$self->{'myip'}] ok ", );
  #$self->log( $self, 'connected1 inited', "MT:$self->{'message_type'}", ' with' );
  #$self->log( 'dev',  'ssltry'),IO::Socket::SSL->start_SSL($self->{'socket'}) if $self->{'protocol'} eq 'adcs';
  $self->connect_aft();
}

sub reconnect {    #$self->{'reconnect'} ||= sub {
  my $self = shift;
  #$self->log(          'dev', 'reconnect');
  $self->disconnect();
  $self->{'status'} = 'reconnecting';
  #!sleep $self->{'reconnect_sleep'};
  #!$self->connect();
}

sub listen {    #$self->{'listen'} ||= sub {
  my $self = shift;
  $self->log( 'err', 'listen off', "[$self->{'Listen'}] [$self->{'M'}] [$self->{'allow_passive_ConnectToMe'}]" ), return
    if !$self->{'Listen'};
  #or ( $self->{'M'} eq 'P' and !$self->{'allow_passive_ConnectToMe'} );    #RENAME
  $self->{'listener'} = 1;
  $self->myport_generate();
  #$self->log( 'dev', 'listen', "p=$self->{'myport'}; proto=$self->{'Proto'} cl=$self->{'socket_class'}",'sockopts', Dumper $self->{'socket_options'}, $self->{'socket_options_listen'} );
  for ( 1 .. $self->{'myport_tries'} ) {
    local @_ = (
      'LocalPort' => $self->{'myport'},
      #'Proto'     => $self->{'Proto'} || 'tcp',
      ( $self->{'Proto'} ? ( 'Proto' => $self->{'Proto'} ) : () ),
      (
        $self->{'Proto'} ne 'udp'
        ? ( 'Listen' => $self->{'Listen'} )
        : ()
      ),
      #( $self->{'Proto'} eq 'sctp' ? ( 'Type' => Socket::SOCK_STREAM ) : () ),
      #( $self->{'nonblocking'} ? ( 'Blocking' => 0 ) : () ),
      Blocking  => 0,
      #ReuseAddr => 1,
      %{ $self->{'socket_options'} },
      %{ $self->{'socket_options_listen'} },
    );
    #$self->log( 'dev', 'listen', $self->{'socket_class'}, @_);
    eval { $self->{'socket'} ||= $self->{'socket_class'}->new(@_); };
    $self->select_add(), last if $self->{'socket'};
    $self->log( 'err', "listen [$_/$self->{'myport_tries'}] ($self->{'Listen'}) $self->{'myport'} socket error: $@" ),
      $self->myport_generate(1),
      unless $self->{'socket'};
  }
  $self->log( 'err', 'cant listen' ), return unless $self->{'socket'};
  eval { $self->{'listener'} = $self->{'socket'}->sockhost; };
  $self->log( 'info', "listening", $self->{'listener'}, "$self->{'myport'} $self->{'Proto'} with $self->{'socket_class'}" );
  $self->{'accept'} = 1 if $self->{'Proto'} ne 'udp';
  $self->{'status'} = 'listening';
  #$self->select();
}

sub disconnect {    #$self->{'disconnect'} ||= sub {
  my $self = shift;
  #$self->log('dev', 'in disconnect', $self->{'status'}, caller);
  #$self->log( 'dev', "[$self->{'number'}] status=",$self->{'status'}, $self->{'destroying'});
  $self->handler('disconnect_bef');
  $self->{'status'} = 'disconnected';
  if ( $self->{'socket'} ) {
    #$self->log( 'dev', "[$self->{'number'}] Closing socket",

lib/Net/DirectConnect.pm  view on Meta::CPAN

}

sub nick_generate {    #'nick_generate' => sub {
  my $self = shift if ref $_[0];
  $self->{'nick_base'} ||= $self->{'Nick'};
  $self->{'Nick'} = $self->{'nick_base'} . int( rand( $self->{'nick_random'} || 100 ) );
}

sub clients_my {       #'clients_my' => sub {
  my $self = shift if ref $_[0];
  grep { $self->{'clients'}{$_} and $self->{'clients'}{$_}{parent} eq $self }
    keys %{ $self->{'clients'} };
}
#);
#$self->{$_} = $_{$_} for keys %_;
#}
#print "N:DC:CALLER=", caller, "\n";
do {
  use lib '../';
  __PACKAGE__->new( auto_work => 1, @ARGV ),;
} unless caller;
1;
__END__

=head1 NAME

Net::DirectConnect - Perl Direct Connect protocol implementation

=head1 SYNOPSIS

  use Net::DirectConnect;
  my $dc = Net::DirectConnect->new(
    'host' => 'dc.mynet.com:4111', #if not 411
    'Nick' => 'Bender', 
    'description' => 'kill all humans',
     #'M'           => 'P', #passive mode, autodetect by default
     #'local_mask'       => [qw(80.240)], #mode=active if hub in this nets and your ip in gray
  );
  $dc->wait_connect();
  $dc->chatline( 'hi all' );

  while ( $dc->active() ) {
    $dc->work();    
  }
  $dc->destroy();

look at examples for handlers


=head1 DESCRIPTION

 Currently NOT supported:
 segmented, multisource download;
 async connect;


=head1 INSTALLATION

 To install this module type the following:

   cpan DBD::SQLite IO::Socket::IP IO::Socket::INET6 IO::Socket::SSL
   perl Makefile.PL && make install clean

 debian:
 apt-get install libdbd-sqlite3-perl libio-socket-ip-perl libjson-xs-perl libjson-perl libmime-base32-perl liblib-abs-perl

=head1 SEE ALSO

 latest snapshot
 svn co svn://svn.setun.net/dcppp/trunk/ dcppp

 http://svn.setun.net/dcppp/timeline/browser/trunk

 usage example:
 used in [and created for] http://sourceforge.net/projects/pro-search http://pro.setun.net/search/
 ( http://svn.setun.net/search/trac.cgi/browser/trunk/crawler.pl )


 protocol info:
 http://en.wikipedia.org/wiki/Direct_Connect_network
 http://www.teamfair.info/DC-Protocol.htm
 http://adc.sourceforge.net/ADC.html

 also useful for creating links from web:
 http://magnet-uri.sourceforge.net/
 http://en.wikipedia.org/wiki/Magnet:_URI_scheme

=head1 TODO
 
 CGET file files.xml.bz2 0 -1 ZL1<<<

 Rewrite better

=head1 AUTHOR

Oleg Alexeenkov, E<lt>pro@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005-2011 Oleg Alexeenkov

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.


=cut