You can also use this with the 'by' keyword so
eg by W dxcc
+
+ by_dxcc - alternatively you can simply say 'by_dxcc W' instead
+ instead of 'by W dxcc'.
real or rt - Format the output the same as for real time spots. The
formats are deliberately different (so you can tell
#
#
-my ($self, $line) = @_;
-my $lines = 1;
-my $data = ' ';
-my @f = split /\s+/, $line;
-if (@f && $f[0] !~ /^\d+$/) {
- $data = shift @f;
- $data = $data x int(($self->width-1) / length($data));
- $data .= substr $data, 0, int(($self->width-1) % length($data))
-}
-if (@f && $f[0] =~ /^\d+$/) {
- $lines = shift @f;
- $lines = 9 if $lines > 9;
- $lines = 1 if $lines < 1;
+sub this {};
+
+sub that {};
+
+sub another {}
+
+sub handle
+{
+ my ($self, $line) = @_;
+ my $lines = 1;
+ my $data = ' ';
+ my @f = split /\s+/, $line;
+ if (@f && $f[0] !~ /^\d+$/) {
+ $data = shift @f;
+ $data = $data x int(($self->width-1) / length($data));
+ $data .= substr $data, 0, int(($self->width-1) % length($data))
+ }
+ if (@f && $f[0] =~ /^\d+$/) {
+ $lines = shift @f;
+ $lines = 9 if $lines > 9;
+ $lines = 1 if $lines < 1;
+ }
+ my @out;
+ push @out, $data for (1..$lines);
+ return (1, @out);
}
-my @out;
-push @out, $data for (1..$lines);
-return (1, @out);
my @in = <I>;
close(I);
$self->send_now('D', @in);
- sleep(1);
+# Msg->sleep(1);
}
#$self->send_now('Z', "");
return (1, $self->msg('e5')) unless $self->priv >= 9;
my ($fn, $flag) = split /\s+/, $line;
-my $strip = $flag eq 'strip';
+my $strip = defined $flag && $flag eq 'strip';
return (1, DXUser::export($fn, $strip));
#
my $self = shift;
$self->send_now("E", "1");
+$self->conn->echo(1);
$self->user->wantecho(1);
return (1, $self->msg('echoon'));
my @out;
-my $mon;;
+my $mon;
# trying to make the syntax abit more user friendly...
# and yes, I have been here and it *is* all my fault (dirk)
my $url = $Internet::contest_url || "http://www.sk3bg.se/contest/text";
$url .= "/$filename";
-my $t = new Net::Telnet (Telnetmode => 0);
-eval {
- $t->open(Host => $host, Port => $port, Timeout => 15);
- };
-
-if (!$t || $@) {
- push @out, $self->msg('e18','sk3bg.se');
-} else {
- my $s = "GET $url";
- $t->print($s);
- my $notfound = $t->getline(Timeout => 10);
- if ($notfound =~ /404 Object Not Found/) {
- return (1, "there is no contest info for $mon")
- } else {
- push @out, $notfound;
- }
- while (!$t->eof) {
- eval {
- push @out, $t->getline(Timeout => 10);
- };
- if ($@) {
- push @out, $self->msg('e18', 'sk3bg.se');
- last;
- }
- }
-}
-$t->close;
+push @out, $self->msg('http1', 'sk3bg.se', "$filename");
+
+$self->http_get($host, $url, sub
+ {
+ my ($response, $header, $body) = @_;
+ my @out;
+
+ if ($response =~ /^4/) {
+ push @out, "There is no contest info $mon";
+ } elsif ($response =~ /^5/) {
+ push @out, $self->msg('e18','sk3bg.se');
+ } else {
+ push @out, split /\r?\n/, $body;
+ }
+ $self->send_ans(@out);
+ }
+ );
return (1, @out);
$info = shift @list;
next;
}
- if ((lc $f eq 'spotter' || lc $f eq 'by') && $list[0]) {
+ if ((lc $f eq 'spotter' || lc $f eq 'by' || lc $f eq 'by_dxcc') && $list[0]) {
# print "got spotter\n";
$spotter = uc shift @list;
- if ($list[0] && lc $list[0] eq 'dxcc') {
+ if ($f eq 'by_dxcc') {
+ $fromdxcc = 1;
+ } elsif ($list[0] && lc $list[0] eq 'dxcc') {
$fromdxcc = 1;
shift @list;
}
push @out, $self->msg('qsl1');
foreach my $call (@call) {
+ Log('call', "$call: show/dxqsl $call");
my $q = QSL::get($call);
if ($q) {
my $c = $call;
my $target = $Internet::http_proxy || $Internet::qrz_url || 'xml.qrz.com';
my $port = $Internet::http_proxy_port || 80;
my $url = '';
-$url = 'http://' . ($Internet::qrz_url | 'xml.qrz.com') if $Internet::http_proxy;
+$url = 'http://' . ($Internet::qrz_url || 'xml.qrz.com') if $Internet::http_proxy;
+foreach $l (@list) {
-use Net::Telnet;
+ my $host = $url?$url:$target;
+ my $s = "$url/xml?callsign=$l;username=$Internet::qrz_uid;password=$Internet::qrz_pw;agent=dxspider";
+ if (isdbg('qrz')) {
+ dbg("qrz: $host");
+ dbg("qrz: $s");
+ }
-my $t = new Net::Telnet;
+ Log('call', "$call: show/qrz \U$l");
+ push @out, $self->msg('http1', 'qrz.com', "\U$l");
-foreach $l (@list) {
- eval {
- $t->open(Host => $target,
- Port => $port,
- Timeout => 15);
- };
+ $self->http_get($host, $s, sub
+ {
+ my ($response, $header, $body) = @_;
+ my @out;
- if (!$t || $@) {
- push @out, $self->msg('e18', 'QRZ.com');
- } else {
- my $s = "GET /xml?callsign=$l;username=$Internet::qrz_uid;password=$Internet::qrz_pw;agent=dxspider HTTP/1.0\n\n";
- dbg($s) if isdbg('qrz');
- $t->print($s);
- Log('call', "$call: show/qrz \U$l");
- my $state = "blank";
- while (my $result = eval { $t->getline(Timeout => 30) } || $@) {
- dbg($result) if isdbg('qrz') && $result;
- if ($@) {
- push @out, $self->msg('e18', 'QRZ.com');
- last;
- }
- if ($state eq 'blank' && $result =~ /^<Callsign>/i) {
- $state = 'go';
- } elsif ($state eq 'go') {
- next if $result =~ m|<user>|;
- next if $result =~ m|<u_views>|;
- next if $result =~ m|<locref>|;
- next if $result =~ m|<ccode>|;
- next if $result =~ m|<dxcc>|;
- last if $result =~ m|</Callsign>|;
- my ($tag, $data) = $result =~ m|^\s*<(\w+)>(.*)</|;
- push @out, sprintf "%10s: $data", $tag;
- }
- }
- $t->close;
- push @out, $self->msg('e3', 'qrz.com', uc $l) unless @out;
- }
+ if (isdbg('qrz')) {
+ dbg("qrz response: $response");
+ dbg("qrz body: $body");
+ }
+ if ($response =~ /^5/) {
+ push @out, $self->msg('e18',"qrz.com $!");
+ } else {
+ Log('call', "$call: show/qrz \U$body");
+ my $state = "blank";
+ foreach my $result (split /\r?\n/, $body) {
+ dbg("qrz: $result") if isdbg('qrz') && $result;
+ if ($state eq 'blank' && $result =~ /^<Callsign>/i) {
+ $state = 'go';
+ } elsif ($state eq 'go') {
+ next if $result =~ m|<user>|;
+ next if $result =~ m|<u_views>|;
+ next if $result =~ m|<locref>|;
+ next if $result =~ m|<ccode>|;
+ next if $result =~ m|<dxcc>|;
+ last if $result =~ m|</Callsign>|;
+ my ($tag, $data) = $result =~ m|^\s*<(\w+)>(.*)</|;
+ push @out, sprintf "%10s: $data", $tag;
+ }
+ }
+ if (@out) {
+ unshift @out, $self->msg('http2', "show/qrz \U$l");
+ } else {
+ push @out, $self->msg('e3', 'show/qrz', uc $l);
+ }
+ }
+ $self->send_ans(@out);
+ }
+ );
}
return (1, @out);
push @f, $self->call unless @f;
if (@f <= 2 && uc $f[0] eq 'ALL') {
- return (1, $self->msg('e6')) if @f == 1 && $self->priv < 6;
- return (1, $self->msg('e6')) if $self->priv < 5 || $f[1] eq '*';
+ return (1, $self->msg('e6')) if $self->remotecmd && $self->priv < 6;
+ return (1, $self->msg('e6')) if $self->priv < 5;
shift @f;
my $exp = shellregex(uc shift @f) if @f;
my @calls;
my $cmdprompt = '/query->.*$/';
my($info, $t);
-
+
+use Net::Telnet;
$t = new Net::Telnet;
$info = $t->open(Host => $target,
Port => $port,
}
# give some time for the buffers to empty and then shutdown (see cluster.pl)
-$main::decease = 25;
+$main::decease->send;
return (1);
#
my $self = shift;
$self->send_now("E", "0");
+$self->conn->echo(0);
$self->user->wantecho(0);
return (1, $self->msg('echooff'));
pmr => [qw( pmrlow pmrmid pmrhigh pmruhf )],
spe => [qw( 10m 6m 4m 2m )],
warc => [qw( 60m 30m 17m 12m )],
- all => [qw( 73khz 136khz 160m 80m 60m 40m 30m 20m 17m 15m 12m 10m 6m 4m 2m 220 70cm 23cm 9cm 6cm 3cm 12mm 6mm )],
+ all => [qw( 73khz 136khz 160m 80m 60m 40m 30m 20m 17m 15m 12m 10m 6m 4m 2m 220 70cm 23cm 9cm 6cm 3cm 12mm 6mm 4mm )],
);
package main;
+use vars qw($maxkhist $maxshist $foreground $background $mycallcolor @colors );
+use Curses;
+
$maxkhist = 100;
$maxshist = 500;
if ($ENV{'TERM'} =~ /(xterm|ansi)/) {
inqueue => '9,Input Queue,parray',
next_pc92_update => '9,Next PC92 Update,atime',
next_pc92_keepalive => '9,Next PC92 KeepAlive,atime',
+ anyevents => '9,outstanding AnyEvent handles,parray',
);
$maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection
{
my ($pkg, $call, $conn, $user) = @_;
my $self = {};
-
+
die "trying to create a duplicate channel for $call" if $channels{$call};
+ bless $self, $pkg;
+
$self->{call} = $call;
$self->{priv} = 0;
- $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list
+ if (defined $conn && ref $conn) { # if this isn't defined then it must be a list
+ $self->{conn} = $conn;
+ $conn->set_on_eof(sub {$self->disconnect});
+ }
if (defined $user) {
$self->{user} = $user;
$self->{lang} = $user->lang;
$self->{cq} = $dxcc[1]->cq;
}
$self->{inqueue} = [];
+ $self->{anyevents} = [];
$count++;
dbg("DXChannel $self->{call} created ($count)") if isdbg('chan');
- bless $self, $pkg;
return $channels{$call} = $self;
}
{
my $self = shift;
my $class = shift;
- return $channels{$self->{call}} = bless $self, $class;
+ my $new = bless $self, $class;
+ $new->{conn}->on_eof(sub {$new->disconnect});
+ return $channels{$self->{call}} = $new;
}
sub rec
# chomp;
my @lines = split /\n/;
for (@lines) {
+ dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan');
$conn->send_now("$sort$call|$_");
# debug log it, but not if it is a log message
- dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan');
}
}
$self->{t} = time;
# chomp;
my @lines = split /\n/;
for (@lines) {
+ dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan');
$conn->send_later("$sort$call|$_");
# debug log it, but not if it is a log message
- dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan');
}
}
$self->{t} = time;
for (ref $l ? @$l : $l) {
my @lines = split /\n/;
for (@lines) {
- $conn->send_later("D$call|$_");
dbg("-> D $call $_") if isdbg('chan');
+ $conn->send_later("D$call|$_");
}
}
}
my $user = $self->{user};
$user->close() if defined $user;
- $self->{conn}->disconnect if $self->{conn};
+ $self->{conn}->close_on_empty if $self->{conn};
$self->del();
}
sub process
{
- foreach my $dxchan (get_all()) {
-
+ foreach my $dxchan (values %channels) {
+
+ next if $dxchan->{disconnecting};
+
while (my $data = shift @{$dxchan->{inqueue}}) {
my ($sort, $call, $line) = $dxchan->decode_input($data);
next unless defined $sort;
# do the really sexy console interface bit! (Who is going to do the TK interface then?)
dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan');
- if ($dxchan->{disconnecting}) {
- dbg('In disconnection, ignored');
- next;
- }
# handle A records
my $user = $dxchan->user;
return $r;
}
+sub anyevent_add
+{
+ my $self = shift;
+ my $handle = shift;
+ my $sort = shift || "unknown";
+
+ push @{$self->{anyevents}}, $handle;
+ dbg("anyevent: add $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent');
+}
+
+sub anyevent_del
+{
+ my $self = shift;
+ my $handle = shift;
+ my $sort = shift || "unknown";
+ $self->{anyevents} = [ grep {$_ != $handle} @{$self->{anyevents}} ];
+ dbg("anyevent: delete $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent');
+}
+
#no strict;
sub AUTOLOAD
{
@ISA = qw(DXChannel);
+use AnyEvent;
+use AnyEvent::Handle;
+use AnyEvent::Socket;
+
use POSIX qw(:math_h);
use DXUtil;
use DXChannel;
use Sun;
use Internet;
use Script;
-use Net::Telnet;
use QSL;
use DB_File;
use VE7CC;
$msgpolltime = 3600; # the time between polls for new messages
$cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts
# this does not exist as default, you need to create it manually
- #
+#
#
# obtain a new connection this is derived from dxchannel
my $package = find_cmd_name($path, $fcmd);
return ($@) if $@;
- if ($package && DXCommandmode->can($package)) {
+ if ($package && $self->can("${package}::handle")) {
no strict 'refs';
dbg("cmd: package $package") if isdbg('command');
- eval { @ans = &$package($self, $args) };
+ eval { @ans = &{"${package}::handle"}($self, $args) };
return (DXDebug::shortmess($@)) if $@;
} else {
dbg("cmd: $package not present") if isdbg('command');
{
no strict 'refs';
- for (keys %Cache) {
- undef *{$_} unless /cmd_cache/;
- dbg("Undefining cmd $_") if isdbg('command');
+ for my $k (keys %Cache) {
+ unless ($k =~ /cmd_cache/) {
+ dbg("Undefining cmd $k") if isdbg('command');
+ undef $DXCommandmode::{"${k}::"};
+ }
}
%cmd_cache = ();
- %Cache = ();
+ %Cache = ( cmd_clear_cmd_cache => $Cache{cmd_clear_cmd_cache} );
}
#
#
# This has been nicked directly from the perlembed pages
#
-
#require Devel::Symdump;
sub valid_package_name {
- my($string) = @_;
+ my $string = shift;
$string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
$string =~ s|/|_|g;
return undef;
}
- if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
+ if(exists $Cache{$package} && exists $Cache{$package}->{mtime} && $Cache{$package}->{mtime} <= $mtime) {
#we have compiled this subroutine already,
#it has not been updated on disk, nothing left to do
#print STDERR "already compiled $package->handler\n";
- ;
+ dbg("find_cmd_name: $package cached") if isdbg('command');
} else {
my $sub = readfilestr($filename);
};
#wrap the code into a subroutine inside our unique package
- my $eval = qq( sub $package { $sub } );
+ my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; our \@ISA = qw{DXCommandmode}; );
+
+
+ if ($sub =~ m|\s*sub\s+handle\n|) {
+ $eval .= $sub;
+ } else {
+ $eval .= qq(sub handle { $sub });
+ }
if (isdbg('eval')) {
my @list = split /\n/, $eval;
if (exists $Cache{$package}) {
dbg("find_cmd_name: Redefining $package") if isdbg('command');
- undef *$package;
+ undef $DXCommandmode::{"${package}::"};
+ delete $Cache{$package};
} else {
dbg("find_cmd_name: Defining $package") if isdbg('command');
}
eval $eval;
$Cache{$package} = {mtime => $mtime } unless $@;
-
}
- return $package;
+ return "DXCommandmode::$package";
}
sub send
}
$self->send_file($motd) if -e $motd;
}
+
+sub http_get
+{
+ my $self = shift;
+ my ($host, $uri, $cb) = @_;
+
+ # store results here
+ my ($response, $header, $body);
+
+ my $handle;
+ $handle = AnyEvent::Handle->new(
+ connect => [$host => 'http'],
+ on_error => sub {
+ $cb->("HTTP/1.0 500 $!");
+ $self->anyevent_del($handle);
+ $handle->destroy; # explicitly destroy handle
+ },
+ on_eof => sub {
+ $cb->($response, $header, $body);
+ $self->anyevent_del($handle);
+ $handle->destroy; # explicitly destroy handle
+ }
+ );
+ $self->anyevent_add($handle);
+ $handle->push_write ("GET $uri HTTP/1.0\015\012\015\012");
+
+ # now fetch response status line
+ $handle->push_read (line => sub {
+ my ($handle, $line) = @_;
+ $response = $line;
+ });
+
+ # then the headers
+ $handle->push_read (line => "\015\012\015\012", sub {
+ my ($handle, $line) = @_;
+ $header = $line;
+ });
+
+ # and finally handle any remaining data as body
+ $handle->on_read (sub {
+ $body .= $_[0]->rbuf;
+ $_[0]->rbuf = "";
+ });
+}
+
1;
__END__
my $to = shift || 10;
my $jdate = $fcb->unixtoj(shift);
my $pattern = shift;
- my $who = uc shift;
+ my $who = shift;
my $search;
my @in;
my @out = ();
my $tot = $from + $to;
my $hint = "";
+ $who = uc $who if defined $who;
+
if ($pattern) {
$hint = "m{\\Q$pattern\\E}i";
} else {
package DXUser;
use DXLog;
-use DB_File;
use Data::Dumper;
use Fcntl;
use IO::File;
use strict;
-use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3);
+use vars qw(%u $dbm $dbh $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4);
%u = ();
$dbm = undef;
+$dbh = undef;
$filename = undef;
$lastoperinterval = 60*24*60*60;
$lasttime = 0;
$tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful
$v3 = 0;
+my $dbh_working;
+
# hash of valid elements and a simple prompt
%valid = (
call => '0,Callsign',
my $ufn;
my $convert;
-
+
eval {
- require Storable;
+ require DBI;
+ require DBD::SQLite;
+ require JSON;
};
-
-# eval "use Storable qw(nfreeze thaw)";
if ($@) {
- $ufn = "$fn.v2";
- $v3 = $convert = 0;
- dbg("the module Storable appears to be missing!!");
+
+ $ufn = "$fn.v3";
+ $v3 = 1; $convert = 0;
+ dbg("One of more of the modules DBI, DBD::SQLite and JSON appear to be missing!!");
dbg("trying to continue in compatibility mode (this may fail)");
- dbg("please install Storable from CPAN as soon as possible");
+ dbg("please install DBI, DBD::SQLite and JSON from CPAN as soon as possible");
+
+ eval {
+ require DB_File;
+ require Storable;
+ };
+
+ if ($@) {
+ $ufn = "$fn.v2";
+ $v3 = $convert = 0;
+ dbg("One of the modules DB_File and Storable appears to be missing!!");
+ dbg("trying to continue in compatibility mode (this may fail)");
+ dbg("please install Storable from CPAN as soon as possible");
+ } else {
+ import DB_File;
+ import Storable qw(nfreeze thaw);
+
+ $ufn = "$fn.v3";
+ $v3 = 1;
+ $convert++ if -e "$fn.v2" && !-e $ufn;
+ }
} else {
- import Storable qw(nfreeze thaw);
+ import DBI;
+ import DBD::SQLite;
+ import JSON qw(-convert_blessed_universally);
+
+ $ufn = "$fn.v4";
+ $v4 = 1;
+ $convert++ if -e "$fn.v3" && !-e $ufn;
+ }
- $ufn = "$fn.v3";
- $v3 = 1;
- $convert++ if -e "$fn.v2" && !-e $ufn;
+ $main::systime ||= time; # becuase user_asc doesn't set it
+
+ # open "database" files
+ if ($v3) {
+ if ($mode) {
+ $dbm = tie (%u, 'DB_File', "$fn.v3", O_CREAT|O_RDWR, 0666, $DB::File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
+ } else {
+ $dbm = tie (%u, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
+ }
+ die "Cannot open $fn.v3 ($!)\n" unless $dbm;
}
-
- if ($mode) {
- $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
- } else {
- $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
+ if ($v4) {
+ my $new = ! -e $ufn;
+ $dbh = DBI->connect("dbi:SQLite:dbname=$ufn","","") or die "Cannot open $ufn ($!)\n";
+ if ($new) {
+ # create the table
+ my $table = q{create table user(
+call text not null unique,
+lastseen int not null,
+data text not null
+)};
+ $dbh->do($table) or die "cannot create user table in $ufn " . $dbh->errstr;
+
+ # Add indexes
+ $dbh->do(q(create index x1 on user(lastseen))) or die $dbh->errstr;
+ }
+ $dbh->do(q{PRAGMA cache_size = 8000});
+ $dbh->do(q{PRAGMA synchronous = OFF});
}
- die "Cannot open $ufn ($!)\n" unless $dbm;
- $lru = LRU->newbase("DXUser", $lrusize);
-
# do a conversion if required
- if ($dbm && $convert) {
+ if ($dbm && $v3 && $convert) {
my ($key, $val, $action, $count, $err) = ('','',0,0,0);
+
+ require DB_File;
+ require Storable;
+ import DB_File;
+ import Storable qw(nfreeze thaw);
my %oldu;
dbg("Converting the User File to V3 ");
- dbg("This will take a while, I suggest you go and have cup of strong tea");
- my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
- for ($action = R_FIRST; !$odbm->seq($key, $val, $action); $action = R_NEXT) {
+ dbg("This will take a while, I suggest you go and have a cup of strong tea");
+ my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
+ for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
my $ref = asc_decode($val);
if ($ref) {
$ref->put;
untie %oldu;
dbg("Conversion completed $count records $err errors");
}
+
+ if ($dbh && $v4 && $convert) {
+ my ($key, $val, $action, $count, $err) = ('','',0,0,0);
+
+
+ my %oldu;
+ dbg("Converting the User File to V4 ");
+ dbg("This will take a while, I suggest you go and have a cup of strong tea");
+ require DB_File;
+ require Storable;
+ import DB_File;
+ import Storable qw(nfreeze thaw);
+ my $odbm = tie (%oldu, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v3 ($!) [rebuild it from user_asc?]";
+ $dbh->begin_work;
+ $dbh_working++;
+ for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
+ my $ref = thaw($val);
+ if ($ref) {
+ my $r = _insert($ref);
+ if ($r) {
+ $count++;
+ } else {
+ $err++;
+ dbg("error converting call $ref->{call} - " . $dbh->errstr);
+ }
+ } else {
+ $err++
+ }
+ }
+ sync();
+ undef $odbm;
+ untie %oldu;
+ dbg("Conversion completed $count records $err errors");
+
+ }
+
+ $lru = LRU->newbase("DXUser", $lrusize);
+
$filename = $ufn;
}
my ($pkg, $fn) = @_;
confess "need a filename in User" if !$fn;
- $fn .= $v3 ? ".v3" : ".v2";
+ my $suffix;
+ $suffix = '.v4' if $v4;
+ $suffix ||= '.v3' if $v3;
+ $suffix ||= '.v2';
+ $fn .= $suffix;
unlink $fn;
}
#
sub process
{
- if ($main::systime > $lasttime + 15) {
- $dbm->sync;
+ if ($main::systime > $lasttime + 5) {
+ sync();
$lasttime = $main::systime;
}
}
sub finish
{
- undef $dbm;
- untie %u;
+ if ($dbm) {
+ undef $dbm;
+ untie %u;
+ }
+ $dbh->disconnect if $dbh;
}
#
my $pkg = shift;
my $call = uc shift;
my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
+ _insert($self) or confess($dbh->errstr) if $v4;
return $self;
}
+sub _insert
+{
+ my $self = shift;
+ my $json = JSON->new->allow_blessed->convert_blessed->encode($self);
+ $dbh->begin_work unless $dbh_working++;
+ my $r = $dbh->do(q{replace into user values(?,?,?)}, undef, $self->{call}, $main::systime, $json);
+ return $r;
+}
+
+sub _select
+{
+ my $call = shift;
+ my $sth = $dbh->prepare(qq{select data from user where call = ?}) or confess($dbh->errstr);
+ my $rv = $sth->execute($call);
+ if ($rv) {
+ my @row = $sth->fetchrow_array;
+ return $row[0];
+ }
+ return undef;
+}
+
+sub _delete
+{
+ my $call =shift;
+ my $r = $dbh->do(q{delete from user where call = ?}, undef, $call);
+ return $r;
+}
+
sub new
{
my $pkg = shift;
# confess "can't create existing call $call in User\n!" if $u{$call};
my $self = $pkg->alloc($call);
- $self->put;
+ $self->put unless $v4;
return $self;
}
# is it in the LRU cache?
my $ref = $lru->get($call);
- return $ref if $ref && ref $ref eq 'DXUser';
+ return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
# search for it
- unless ($dbm->get($call, $data)) {
- $ref = decode($data);
- if ($ref) {
- if (!UNIVERSAL::isa($ref, 'DXUser')) {
- dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
+ if ($v4) {
+ if ($data = _select($call)) {
+ $ref = bless decode_json($data), 'DXUser';
+ unless ($ref) {
+ dbg("DXUser::get: no reference returned from decode of $call $!");
return undef;
}
- # we have a reference and it *is* a DXUser
- } else {
- dbg("DXUser::get: no reference returned from decode of $call $!");
+ }
+ } else {
+ unless ($dbm->get($call, $data)) {
+ $ref = decode($data);
+ unless ($ref) {
+ dbg("DXUser::get: no reference returned from decode of $call $!");
+ return undef;
+ }
+ }
+ }
+
+ if ($ref) {
+ if (!UNIVERSAL::isa($ref, 'DXUser')) {
+ dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
return undef;
}
+
+ # we have a reference and it *is* a DXUser
$lru->put($call, $ref);
return $ref;
}
sub get_all_calls
{
- return (sort keys %u);
+ if ($v4) {
+ my $sth = $dbh->prepare(qq{select call from user}) or confess($dbh->errstr);
+ my $rv = $sth->execute();
+ if ($rv) {
+ my @row;
+ my @r;
+ while (my @r = $sth->fetchrow_array) {
+ push @row, @r;
+ }
+ return @row; # 'cos it's already sorted
+ }
+ } else {
+ return (sort keys %u);
+ }
}
#
confess "Trying to put nothing!" unless $self && ref $self;
my $call = $self->{call};
- $dbm->del($call);
delete $self->{annok} if $self->{annok};
delete $self->{dxok} if $self->{dxok};
$lru->put($call, $self);
- my $ref = $self->encode;
- $dbm->put($call, $ref);
+ if ($v4) {
+ _insert($self);
+ } else {
+ $dbm->del($call);
+ my $ref = $self->encode;
+ $dbm->put($call, $ref);
+ }
}
# freeze the user
sub del
{
my $self = shift;
- my $call = $self->{call};
- $lru->remove($call);
- $dbm->del($call);
+ if ($v4) {
+ _delete($self)
+ } else {
+ my $call = $self->{call};
+ $lru->remove($call);
+ $dbm->del($call);
+ }
}
#
{
my $self = shift;
$self->{lastin} = time;
- $self->put();
+ $self->put;
}
#
sub sync
{
- $dbm->sync;
+ if ($v4) {
+ $dbh->commit if $dbh_working;
+ $dbh_working = 0;
+ } else {
+ $dbm->sync;
+ }
}
#
my $del = 0;
my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
if ($fh) {
- my $key = 0;
- my $val = undef;
- my $action;
my $t = scalar localtime;
print $fh q{#!/usr/bin/perl
#
};
print $fh "__DATA__\n";
- for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
- if (!is_callsign($key) || $key =~ /^0/) {
- my $eval = $val;
- my $ekey = $key;
- $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
- $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
- LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
- eval {$dbm->del($key)};
- dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
- ++$err;
- next;
- }
- my $ref = decode($val);
- if ($ref) {
- my $t = $ref->{lastin} || 0;
- if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
- unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
- eval {$dbm->del($key)};
- dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
- LogDbg('DXCommand', "$ref->{call} deleted, too old");
- $del++;
+ if ($v4) {
+ my $sth = $dbh->prepare(q{select call,data from user}) or confess($dbh->errstr);
+ my $rv = $sth->execute;
+ if ($rv) {
+ while (my @row = $sth->fetchrow_array) {
+ my $call = shift @row;
+ my $data = shift @row;
+ if (!is_callsign($call) || $call =~ /^0/) {
+ LogDbg('DXCommand', "Export Error1: $call\t$data");
+ _delete($call);
+ ++$err;
next;
}
+ my $ref = bless decode_json($data), __PACKAGE__;
+ my $t = $ref->{lastin} || 0;
+ if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
+ unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
+ LogDbg('DXCommand', "$ref->{call} deleted, too old");
+ _delete($call);
+ $del++;
+ next;
+ }
+ }
+
+ # only store users that are reasonably active or have useful information
+ print $fh "$call\t" . $ref->asc_encode($basic_info_only) . "\n";
+ ++$count;
}
- # only store users that are reasonably active or have useful information
- print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
- ++$count;
} else {
- LogDbg('DXCommand', "Export Error3: $key\t$val");
- eval {$dbm->del($key)};
- dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
- ++$err;
+ dbg(carp($dbh->errstr));
}
- }
+ } else {
+ my $key = 0;
+ my $val = undef;
+ my $action;
+ for ($action = DB_File::R_FIRST(); !$dbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
+ if (!is_callsign($key) || $key =~ /^0/) {
+ my $eval = $val;
+ my $ekey = $key;
+ $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
+ $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
+ LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
+ eval {$dbm->del($key)};
+ dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
+ ++$err;
+ next;
+ }
+ my $ref = decode($val);
+ if ($ref) {
+ my $t = $ref->{lastin} || 0;
+ if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
+ unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
+ eval {$dbm->del($key)};
+ dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
+ LogDbg('DXCommand', "$ref->{call} deleted, too old");
+ $del++;
+ next;
+ }
+ }
+ # only store users that are reasonably active or have useful information
+ print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
+ ++$count;
+ } else {
+ LogDbg('DXCommand', "Export Error3: $key\t$val");
+ eval {$dbm->del($key)};
+ dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
+ ++$err;
+ }
+ }
+ }
$fh->close;
}
return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";
use strict;
-use vars qw(@month %patmap @ISA @EXPORT);
+use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT);
require Exporter;
@ISA = qw(Exporter);
filecopy ptimelist
print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong
is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem
- is_prefix dd is_ipaddr
+ is_prefix dd is_ipaddr $pi $d2r $r2d
);
']' => ']'
);
+$pi = 3.141592653589;
+$d2r = ($pi/180);
+$r2d = (180/$pi);
+
+
# a full time for logging and other purposes
sub atime
{
sub send_raw
{
my ($conn, $msg) = @_;
- my $sock = $conn->{sock};
- return unless defined($sock);
- push (@{$conn->{outqueue}}, $msg);
dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
- Msg::set_event_handler ($sock, "write" => sub {$conn->_send(0)});
+ $conn->SUPER::send_raw($msg);
}
sub echo
delete $conn->{timeout};
$conn->{csort} = $sort;
unless ($conn->ax25) {
- eval {$conn->{peerhost} = $conn->{sock}->peerhost};
- $conn->nolinger;
+# eval {$conn->{peerhost} = $conn->{sock}->{fh}->peerhost};
}
&{$conn->{rproc}}($conn, "$dir$call|$sort");
$conn->_send_file("$main::data/connected") unless $conn->{outgoing};
sub new_client {
my $server_conn = shift;
- my $sock = $server_conn->{sock}->accept();
+ my $sock = shift;
+ my $peerhost = shift;
+ my $peerport = shift;
if ($sock) {
my $conn = $server_conn->new($server_conn->{rproc});
- $conn->{sock} = $sock;
- $conn->nolinger;
- Msg::blocking($sock, 0);
+ $conn->{sock} = AnyEvent::Handle->new(
+
+ fh => $sock,
+
+ on_eof => sub {$conn->disconnect},
+
+ on_error => sub {$conn->disconnect},
+
+ keepalive => 1,
+
+ linger => 0,
+ );
$conn->{blocking} = 0;
- eval {$conn->{peerhost} = $sock->peerhost};
- if ($@) {
- dbg($@) if isdbg('connll');
- $conn->disconnect;
+ my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $peerhost, $conn->{peerport} = $peerport);
+ dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
+ $conn->{sock}->on_read(sub{$conn->_rcv});
+ if ($eproc) {
+ $conn->{eproc} = $eproc;
+ }
+ if ($rproc) {
+ $conn->{rproc} = $rproc;
+ # send login prompt
+ $conn->{state} = 'WL';
+ # $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
+ # $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
+ # $conn->send_raw("\xFF\xFC\x01");
+ $conn->_send_file("$main::data/issue");
+ $conn->send_raw("login: ");
+ $conn->_dotimeout(60);
+ $conn->{echo} = 1;
} else {
- eval {$conn->{peerport} = $sock->peerport};
- $conn->{peerport} = 0 if $@;
- my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost}, $conn->{peerport});
- dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
- if ($eproc) {
- $conn->{eproc} = $eproc;
- Msg::set_event_handler ($sock, "error" => $eproc);
- }
- if ($rproc) {
- $conn->{rproc} = $rproc;
- my $callback = sub {$conn->_rcv};
- Msg::set_event_handler ($sock, "read" => $callback);
- # send login prompt
- $conn->{state} = 'WL';
- # $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
- # $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
- # $conn->send_raw("\xFF\xFC\x01");
- $conn->_send_file("$main::data/issue");
- $conn->send_raw("login: ");
- $conn->_dotimeout(60);
- $conn->{echo} = 1;
- } else {
- &{$conn->{eproc}}() if $conn->{eproc};
- $conn->disconnect();
- }
+ &{$conn->{eproc}}() if $conn->{eproc};
+ $conn->disconnect();
}
} else {
dbg("ExtMsg: error on accept ($!)") if isdbg('err');
hnodee1 => 'Please enter your Home Node, set/homenode <your home DX Cluster>',
hnodee2 => 'Failed to set homenode on $_[0]',
hnode => 'Your Homenode is now \"$_[0]\"',
+ http1 => 'Searching $_[0] for $_[1] ...',
+ http2 => '$_[0] returned:',
init1 => 'sent initialisation message to $_[0]',
iso => '$_[0] Isolated',
isou => '$_[0] UnIsolated',
use DXUtil;
-use IO::Select;
+use AnyEvent;
+use AnyEvent::Handle;
+use AnyEvent::Socket;
+
use DXDebug;
use Timer;
-use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum $total_in $total_out $io_socket);
+use vars qw(%conns $noconns $cnum $total_in $total_out);
-%rd_callbacks = ();
-%wt_callbacks = ();
-%er_callbacks = ();
-$rd_handles = IO::Select->new();
-$wt_handles = IO::Select->new();
-$er_handles = IO::Select->new();
$total_in = $total_out = 0;
-
-$now = time;
-
-BEGIN {
- # Checks if blocking is supported
- eval {
- local $^W;
- require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL))
- };
-
- eval {
- local $^W;
- require IO::Socket::INET6;
- };
-
- if ($@) {
- dbg($@);
- require IO::Socket;
- $io_socket = 'IO::Socket::INET';
- } else {
- $io_socket = 'IO::Socket::INET6';
- }
- $io_socket->import;
-
- if ($@ || $main::is_win) {
- $blocking_supported = $io_socket->can('blocking') ? 2 : 0;
- } else {
- $blocking_supported = $io_socket->can('blocking') ? 2 : 1;
- }
-
-
- # import as many of these errno values as are available
- eval {
- local $^W;
- require Errno; Errno->import(qw(EAGAIN EINPROGRESS EWOULDBLOCK));
- };
-
- unless ($^O eq 'MSWin32') {
- if ($] >= 5.6) {
- eval {
- local $^W;
- require Socket; Socket->import(qw(IPPROTO_TCP TCP_NODELAY));
- };
- } else {
- dbg("IPPROTO_TCP and TCP_NODELAY manually defined");
- eval 'sub IPPROTO_TCP { 6 };';
- eval 'sub TCP_NODELAY { 1 };';
- }
- }
- # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
- # defines EINPROGRESS as 10035. We provide it here because some
- # Win32 users report POSIX::EINPROGRESS is not vendor-supported.
- if ($^O eq 'MSWin32') {
- eval '*EINPROGRESS = sub { 10036 };' unless defined *EINPROGRESS;
- eval '*EWOULDBLOCK = *EAGAIN = sub { 10035 };' unless defined *EWOULDBLOCK;
- eval '*F_GETFL = sub { 0 };' unless defined *F_GETFL;
- eval '*F_SETFL = sub { 0 };' unless defined *F_SETFL;
- eval 'sub IPPROTO_TCP { 6 };';
- eval 'sub TCP_NODELAY { 1 };';
- $blocking_supported = 0; # it appears that this DOESN'T work :-(
- }
-}
-
-my $w = $^W;
-$^W = 0;
-my $eagain = eval {EAGAIN()};
-my $einprogress = eval {EINPROGRESS()};
-my $ewouldblock = eval {EWOULDBLOCK()};
-$^W = $w;
$cnum = 0;
-
#
#-----------------------------------------------------------------
# Generalised initializer
my $conn = shift;
my $callback = shift;
$conn->{eproc} = $callback;
- set_event_handler($conn->{sock}, error => $callback) if exists $conn->{sock};
}
-sub set_rproc
+sub set_on_eof
{
my $conn = shift;
my $callback = shift;
- $conn->{rproc} = $callback;
+ $conn->{sock}->on_eof($callback);
+ $conn->{sock}->on_error($callback);
}
-sub blocking
+sub set_rproc
{
- return unless $blocking_supported;
-
- # Make the handle stop blocking, the Windows way.
- if ($blocking_supported) {
- $_[0]->blocking($_[1]);
- } else {
- my $flags = fcntl ($_[0], F_GETFL, 0);
- if ($_[1]) {
- $flags &= ~O_NONBLOCK;
- } else {
- $flags |= O_NONBLOCK;
- }
- fcntl ($_[0], F_SETFL, $flags);
- }
+ my $conn = shift;
+ my $callback = shift;
+ $conn->{rproc} = $callback;
}
# save it
$conn->{peerport} = $to_port;
$conn->{sort} = 'Outgoing';
- my $sock;
- if ($blocking_supported) {
- $sock = $io_socket->new(PeerAddr => $to_host, PeerPort => $to_port, Proto => 'tcp', Blocking =>0) or return undef;
- } else {
- # Create a new internet socket
- $sock = $io_socket->new();
- return undef unless $sock;
+ my $sock = AnyEvent::Handle->new(
- my $proto = getprotobyname('tcp');
- $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef;
+ connect => [$to_host, $to_port],
- blocking($sock, 0);
- $conn->{blocking} = 0;
+ on_connect => sub {my $h = shift; $conn->{peerhost} = shift;},
- # does the host resolve?
- my $ip = gethostbyname($to_host);
- return undef unless $ip;
+ on_eof => sub {$conn->disconnect},
- my $r = connect($sock, pack_sockaddr_in($to_port, $ip));
- return undef unless $r || _err_will_block($!);
- }
+ on_error => sub {$conn->disconnect},
+
+ keepalive => 1,
+
+ linger => 0,
+ );
$conn->{sock} = $sock;
- $conn->{peerhost} = $sock->peerhost; # for consistency
+ $sock->on_read(sub{$conn->_rcv});
- if ($conn->{rproc}) {
- my $callback = sub {$conn->_rcv};
- set_event_handler ($sock, read => $callback);
- }
return $conn;
}
my ($conn, $line, $sort) = @_;
my $pid;
- local $^F = 10000; # make sure it ain't closed on exec
- my ($a, $b) = $io_socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
- if ($a && $b) {
- $a->autoflush(1);
- $b->autoflush(1);
- $pid = fork;
- if (defined $pid) {
- if ($pid) {
- close $b;
- $conn->{sock} = $a;
- $conn->{csort} = $sort;
- $conn->{lineend} = "\cM" if $sort eq 'ax25';
- $conn->{pid} = $pid;
- if ($conn->{rproc}) {
- my $callback = sub {$conn->_rcv};
- Msg::set_event_handler ($a, read => $callback);
- }
- dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect');
- } else {
- $^W = 0;
- dbgclose();
- STDIN->close;
- STDOUT->close;
- STDOUT->close;
- *STDIN = IO::File->new_from_fd($b, 'r') or die;
- *STDOUT = IO::File->new_from_fd($b, 'w') or die;
- *STDERR = IO::File->new_from_fd($b, 'w') or die;
- close $a;
- unless ($main::is_win) {
- # $SIG{HUP} = 'IGNORE';
- $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
- alarm(0);
- }
- exec "$line" or dbg("exec '$line' failed $!");
- }
- } else {
- dbg("cannot fork for $line");
- }
- } else {
- dbg("no socket pair $! for $line");
- }
+# local $^F = 10000; # make sure it ain't closed on exec
+# my ($a, $b) = $io_socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+# if ($a && $b) {
+# $a->autoflush(1);
+# $b->autoflush(1);
+# $pid = fork;
+# if (defined $pid) {
+# if ($pid) {
+# close $b;
+# $conn->{sock} = $a;
+# $conn->{csort} = $sort;
+# $conn->{lineend} = "\cM" if $sort eq 'ax25';
+# $conn->{pid} = $pid;
+# if ($conn->{rproc}) {
+# my $callback = sub {$conn->_rcv};
+# Msg::set_event_handler ($a, read => $callback);
+# }
+# dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect');
+# } else {
+# $^W = 0;
+# dbgclose();
+# STDIN->close;
+# STDOUT->close;
+# STDOUT->close;
+# *STDIN = IO::File->new_from_fd($b, 'r') or die;
+# *STDOUT = IO::File->new_from_fd($b, 'w') or die;
+# *STDERR = IO::File->new_from_fd($b, 'w') or die;
+# close $a;
+# unless ($main::is_win) {
+# # $SIG{HUP} = 'IGNORE';
+# $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
+# alarm(0);
+# }
+# exec "$line" or dbg("exec '$line' failed $!");
+# }
+# } else {
+# dbg("cannot fork for $line");
+# }
+# } else {
+# dbg("no socket pair $! for $line");
+# }
return $pid;
}
}
}
- if (defined($sock)) {
- set_event_handler ($sock, read => undef, write => undef, error => undef);
- shutdown($sock, 2);
- close($sock);
+ if (ref $sock && $sock->isa('AnyEvent::Handle') && exists $sock->{fh}) {
+ shutdown($sock->{fh}, 2);
+ $sock->destroy;
+ } else {
+ my $s;
+ $s = "already destroyed" unless exists $sock->{fh};
+ $s ||= ref $sock || $sock || "undefined";
+ dbg("Msg::disconnect trying to disconnect a $s socket") if isdbg('chan');
}
unless ($main::is_win) {
}
}
-sub send_now {
- my ($conn, $msg) = @_;
- $conn->enqueue($msg);
- $conn->_send (1); # 1 ==> flush
+sub _send_stuff
+{
+ my $conn = shift;
+ my $rq = $conn->{outqueue};
+ my $sock = $conn->{sock};
+
+ while (@$rq) {
+ my $data = shift @$rq;
+ my $lth = length $data;
+ my $call = $conn->{call} || 'none';
+ if (isdbg('raw')) {
+ if (isdbg('raw')) {
+ dbgdump('raw', "$call send $lth: ", $lth);
+ }
+ }
+ if (defined $sock && !$sock->destroyed) {
+ $sock->push_write($data);
+ $total_out = $lth;
+ } else {
+ dbg("_send_stuff $call ending data ignored: $data");
+ }
+ }
}
sub send_later {
my ($conn, $msg) = @_;
- $conn->enqueue($msg);
- my $sock = $conn->{sock};
- return unless defined($sock);
- set_event_handler ($sock, write => sub {$conn->_send(0)});
-}
+ my $rq = $conn->{outqueue};
+ my $sock = $conn->{sock};
-sub enqueue {
- my $conn = shift;
- push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : '');
+ # this is done like this because enqueueing may be going on independently of
+ # sending (whether later or now)
+ $conn->enqueue($msg);
+ _send_stuff($conn)
}
-sub _send {
- my ($conn, $flush) = @_;
- my $sock = $conn->{sock};
- return unless defined($sock);
- my $rq = $conn->{outqueue};
-
- # If $flush is set, set the socket to blocking, and send all
- # messages in the queue - return only if there's an error
- # If $flush is 0 (deferred mode) make the socket non-blocking, and
- # return to the event loop only after every message, or if it
- # is likely to block in the middle of a message.
+sub send_now { goto &send_later; }
-# if ($conn->{blocking} != $flush) {
-# blocking($sock, $flush);
-# $conn->{blocking} = $flush;
-# }
- my $offset = (exists $conn->{send_offset}) ? $conn->{send_offset} : 0;
-
- while (@$rq) {
- my $msg = $rq->[0];
- my $mlth = length($msg);
- my $bytes_to_write = $mlth - $offset;
- my $bytes_written = 0;
- confess("Negative Length! msg: '$msg' lth: $mlth offset: $offset") if $bytes_to_write < 0;
- while ($bytes_to_write > 0) {
- $bytes_written = syswrite ($sock, $msg,
- $bytes_to_write, $offset);
- if (!defined($bytes_written)) {
- if (_err_will_block($!)) {
- # Should happen only in deferred mode. Record how
- # much we have already sent.
- $conn->{send_offset} = $offset;
- # Event handler should already be set, so we will
- # be called back eventually, and will resume sending
- return 1;
- } else { # Uh, oh
- &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
- $conn->disconnect;
- return 0; # fail. Message remains in queue ..
- }
- } elsif (isdbg('raw')) {
- my $call = $conn->{call} || 'none';
- dbgdump('raw', "$call send $bytes_written: ", $msg);
- }
- $total_out += $bytes_written;
- $offset += $bytes_written;
- $bytes_to_write -= $bytes_written;
- }
- delete $conn->{send_offset};
- $offset = 0;
- shift @$rq;
- #last unless $flush; # Go back to select and wait
- # for it to fire again.
- }
- # Call me back if queue has not been drained.
- unless (@$rq) {
- set_event_handler ($sock, write => undef);
- if (exists $conn->{close_on_empty}) {
- &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
- $conn->disconnect;
- }
- }
- 1; # Success
+sub send_raw
+{
+ my ($conn, $msg) = @_;
+ push @{$conn->{outqueue}}, $msg;
+ _send_stuff($conn);
}
-sub dup_sock
-{
- my $conn = shift;
- my $oldsock = $conn->{sock};
- my $rc = $rd_callbacks{$oldsock};
- my $wc = $wt_callbacks{$oldsock};
- my $ec = $er_callbacks{$oldsock};
- my $sock = $oldsock->new_from_fd($oldsock, "w+");
- if ($sock) {
- set_event_handler($oldsock, read=>undef, write=>undef, error=>undef);
- $conn->{sock} = $sock;
- set_event_handler($sock, read=>$rc, write=>$wc, error=>$ec);
- $oldsock->close;
- }
+sub enqueue {
+ my $conn = shift;
+ push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : '');
}
sub _err_will_block {
- return 0 unless $blocking_supported;
- return ($_[0] == $eagain || $_[0] == $ewouldblock || $_[0] == $einprogress);
+ return 0;
}
sub close_on_empty
{
my $conn = shift;
- $conn->{close_on_empty} = 1;
+ $conn->{sock}->on_drain(sub {$conn->disconnect;});
}
#-----------------------------------------------------------------
my ($pkg, $my_host, $my_port, $login_proc) = @_;
my $self = $pkg->new($login_proc);
- $self->{sock} = $io_socket->new (
- LocalAddr => "$my_host:$my_port",
-# LocalPort => $my_port,
- Listen => SOMAXCONN,
- Proto => 'tcp',
- Reuse => 1);
+ $self->{sock} = tcp_server $my_host, $my_port, sub { $self->new_client(@_); };
die "Could not create socket: $! \n" unless $self->{sock};
- set_event_handler ($self->{sock}, read => sub { $self->new_client } );
return $self;
}
sub nolinger
{
my $conn = shift;
-
- unless ($main::is_win) {
- if (isdbg('sock')) {
- my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER);
- my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE);
- my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY);
- dbg("Linger is: $l $t, keepalive: $k, nagle: $n");
- }
-
- eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE, 1)} or dbg("setsockopt keepalive: $!");
- eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER, pack("ll", 0, 0))} or dbg("setsockopt linger: $!");
- eval {setsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY, 1)} or eval {setsockopt($conn->{sock}, SOL_SOCKET, TCP_NODELAY, 1)} or dbg("setsockopt tcp_nodelay: $!");
- $conn->{sock}->autoflush(0);
-
- if (isdbg('sock')) {
- my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER);
- my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE);
- my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY);
- dbg("Linger is: $l $t, keepalive: $k, nagle: $n");
- }
- }
+ my $sock = $conn->{sock};
+# $sock->linger(0);
+# $sock->keepalive(1);
}
sub dequeue
return unless defined($sock);
my @lines;
-# if ($conn->{blocking}) {
-# blocking($sock, 0);
-# $conn->{blocking} = 0;
-# }
- $bytes_read = sysread ($sock, $msg, 1024, 0);
- if (defined ($bytes_read)) {
- if ($bytes_read > 0) {
- $total_in += $bytes_read;
- if (isdbg('raw')) {
- my $call = $conn->{call} || 'none';
- dbgdump('raw', "$call read $bytes_read: ", $msg);
- }
- if ($conn->{echo}) {
- my @ch = split //, $msg;
- my $out;
- for (@ch) {
- if (/[\cH\x7f]/) {
- $out .= "\cH \cH";
- $conn->{msg} =~ s/.$//;
- } else {
- $out .= $_;
- $conn->{msg} .= $_;
- }
- }
- if (defined $out) {
- set_event_handler ($sock, write => sub{$conn->_send(0)});
- push @{$conn->{outqueue}}, $out;
+ $msg = $sock->{rbuf};
+ $bytes_read = length $msg || 0;
+ $sock->{rbuf} = '';
+
+ if ($bytes_read > 0) {
+ $total_in += $bytes_read;
+ if (isdbg('raw')) {
+ my $call = $conn->{call} || 'none';
+ dbgdump('raw', "$call read $bytes_read: ", $msg);
+ }
+ if ($conn->{echo}) {
+ my @ch = split //, $msg;
+ my $out;
+ for (@ch) {
+ if (/[\cH\x7f]/) {
+ $out .= "\cH \cH";
+ $conn->{msg} =~ s/.$//;
+ } else {
+ $out .= $_;
+ $conn->{msg} .= $_;
}
- } else {
- $conn->{msg} .= $msg;
}
- }
- } else {
- if (_err_will_block($!)) {
- return ;
+ if (defined $out) {
+ $conn->send_now($out);
+ }
} else {
- $bytes_read = 0;
+ $conn->{msg} .= $msg;
}
- }
+ }
-FINISH:
- if (defined $bytes_read && $bytes_read == 0) {
- &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
- $conn->disconnect;
- } else {
- unless ($conn->{disable_read}) {
- $conn->dequeue if exists $conn->{msg};
- }
+ unless ($conn->{disable_read}) {
+ $conn->dequeue if exists $conn->{msg};
}
}
sub new_client {
my $server_conn = shift;
- my $sock = $server_conn->{sock}->accept();
+ my $sock = shift;
+ my $peerhost = shift;
+ my $peerport = shift;
if ($sock) {
my $conn = $server_conn->new($server_conn->{rproc});
- $conn->{sock} = $sock;
- blocking($sock, 0);
- $conn->nolinger;
+ $conn->{sock} = AnyEvent::Handle->new(
+
+ fh => $sock,
+
+ on_eof => sub {$conn->disconnect},
+
+ on_error => sub {$conn->disconnect},
+
+ keepalive => 1,
+
+ linger => 0,
+ );
$conn->{blocking} = 0;
- my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport());
+ my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $peerhost, $conn->{peerport} = $peerport);
+ dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
$conn->{sort} = 'Incoming';
+ $conn->{sock}->on_read(sub {$conn->_rcv});
if ($eproc) {
$conn->{eproc} = $eproc;
- set_event_handler ($sock, error => $eproc);
}
if ($rproc) {
$conn->{rproc} = $rproc;
- my $callback = sub {$conn->_rcv};
- set_event_handler ($sock, read => $callback);
} else { # Login failed
&{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
$conn->disconnect();
sub close_server
{
my $conn = shift;
- set_event_handler ($conn->{sock}, read => undef, write => undef, error => undef );
- $conn->{sock}->close;
+ undef $conn->{sock};
}
# close all clients (this is for forking really)
sub disable_read
{
my $conn = shift;
- set_event_handler ($conn->{sock}, read => undef);
- return $_[0] ? $conn->{disable_read} = $_[0] : $_[0];
+ return defined $_[0] ? $conn->{disable_read} = $_[0] : $_[0];
}
-#
-#----------------------------------------------------
-# Event loop routines used by both client and server
-
-sub set_event_handler {
- shift unless ref($_[0]); # shift if first arg is package name
- my ($handle, %args) = @_;
- my $callback;
- if (exists $args{'write'}) {
- $callback = $args{'write'};
- if ($callback) {
- $wt_callbacks{$handle} = $callback;
- $wt_handles->add($handle);
- } else {
- delete $wt_callbacks{$handle};
- $wt_handles->remove($handle);
- }
- }
- if (exists $args{'read'}) {
- $callback = $args{'read'};
- if ($callback) {
- $rd_callbacks{$handle} = $callback;
- $rd_handles->add($handle);
- } else {
- delete $rd_callbacks{$handle};
- $rd_handles->remove($handle);
- }
- }
- if (exists $args{'error'}) {
- $callback = $args{'error'};
- if ($callback) {
- $er_callbacks{$handle} = $callback;
- $er_handles->add($handle);
- } else {
- delete $er_callbacks{$handle};
- $er_handles->remove($handle);
- }
- }
+sub sleep
+{
+ my ($pkg, $interval) = @_;
+ my $cv = AnyEvent->condvar;
+ my $wait_a_bit = AnyEvent->timer(
+ after => $interval,
+ cb => sub {$cv->send},
+ );
+ $cv->recv;
}
-sub event_loop {
- my ($pkg, $loop_count, $timeout, $wronly) = @_; # event_loop(1) to process events once
- my ($conn, $r, $w, $e, $rset, $wset, $eset);
- while (1) {
-
- # Quit the loop if no handles left to process
- if ($wronly) {
- last unless $wt_handles->count();
-
- ($rset, $wset, $eset) = IO::Select->select(undef, $wt_handles, undef, $timeout);
-
- foreach $w (@$wset) {
- &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w};
- }
- } else {
-
- last unless ($rd_handles->count() || $wt_handles->count());
-
- ($rset, $wset, $eset) = IO::Select->select($rd_handles, $wt_handles, $er_handles, $timeout);
-
- foreach $e (@$eset) {
- &{$er_callbacks{$e}}($e) if exists $er_callbacks{$e};
- }
- foreach $r (@$rset) {
- &{$rd_callbacks{$r}}($r) if exists $rd_callbacks{$r};
- }
- foreach $w (@$wset) {
- &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w};
- }
- }
-
- Timer::handler;
-
- if (defined($loop_count)) {
- last unless --$loop_count;
- }
- }
+sub set_event_handler
+{
+ my $sock = shift;
+ my %args = @_;
+ my ($pkg, $fn, $line) = caller;
+ my $s;
+ foreach (my ($k,$v) = each %args) {
+ $s .= "$k => $v, ";
+ }
+ $s =~ s/[\s,]$//;
+ dbg("Msg::set_event_handler called from ${pkg}::${fn} line $line doing $s");
}
-sub sleep
+sub echo
{
- my ($pkg, $interval) = @_;
- my $now = time;
- while (time - $now < $interval) {
- $pkg->event_loop(10, 0.01);
- }
+ my $conn = shift;
+ return defined $_[0] ? $conn->{echo} = $_[0] : $_[0];
}
sub DESTROY
use strict;
-use vars qw($pi $d2r $r2d);
-
-$pi = 3.141592653589;
-$d2r = ($pi/180);
-$r2d = (180/$pi);
-
use vars qw(%keps);
use Keps;
use DXVars;
use vars qw($version $subversion $build $gitversion);
-$version = '1.55';
+$version = '1.56';
$subversion = '0';
-$build = '115';
-$gitversion = '2321d9d';
+$build = '36';
+$gitversion = '0e89669';
1;
$systime = time;
}
+use AnyEvent;
+
use DXVars;
use Msg;
use IntMsg;
$zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr
$clusterport $mycall $decease $is_win $routeroot $me $reqreg $bumpexisting
$allowdxby $dbh $dsn $dbuser $dbpass $do_xml $systime_days $systime_daystart
- $can_encode $maxconnect_user $maxconnect_node
+ $can_encode $maxconnect_user $maxconnect_node $idle_interval
);
@inqueue = (); # the main input queue, an array of hashes
$maxconnect_node = 0; # Ditto but for nodes. In either case if a new incoming connection
# takes the no of references in the routing table above these numbers
# then the connection is refused. This only affects INCOMING connections.
+$idle_interval = 0.100; # the wait between invocations of the main idle loop processing.
# send a message to call on conn and disconnect
sub already_conn
{
my ($conn, $call, $mess) = @_;
- $conn->disable_read(1);
dbg("-> D $call $mess\n") if isdbg('chan');
+ $conn->disable_read(1);
$conn->send_now("D$call|$mess");
- sleep(2);
$conn->disconnect;
}
foreach $dxchan (DXChannel::get_all_nodes) {
$dxchan->disconnect(2) unless $dxchan == $main::me;
}
- Msg->event_loop(100, 0.01);
# disconnect users
foreach $dxchan (DXChannel::get_all_users) {
UDPMsg::finish();
# end everything else
- Msg->event_loop(100, 0.01);
DXUser::finish();
DXDupe::finish();
}
LogDbg('cluster', "DXSpider V$version, build $subversion.$build (git: $gitversion) ended");
+ dbg("bye bye everyone - bye bye");
+
dbgclose();
Logclose();
AGWMsg::init(\&new_channel);
}
+sub idle_loop
+{
+ my $timenow = time;
+
+ DXChannel::process();
+
+# $DB::trace = 0;
+
+ # do timed stuff, ongoing processing happens one a second
+ if ($timenow != $systime) {
+ reap() if $zombies;
+ $systime = $timenow;
+ my $days = int ($systime / 86400);
+ if ($systime_days != $days) {
+ $systime_days = $days;
+ $systime_daystart = $days * 86400;
+ }
+ IsoTime::update($systime);
+ DXCron::process(); # do cron jobs
+ DXCommandmode::process(); # process ongoing command mode stuff
+ DXXml::process();
+ DXProt::process(); # process ongoing ak1a pcxx stuff
+ DXConnect::process();
+ DXMsg::process();
+ DXDb::process();
+ DXUser::process();
+ DXDupe::process();
+ AGWMsg::process();
+ BPQMsg::process();
+
+ Timer::handler();
+
+ if (defined &Local::process) {
+ eval {
+ Local::process(); # do any localised processing
+ };
+ dbg("Local::process error $@") if $@;
+ }
+ }
+}
+
#############################################################
#
# The start of the main line of code
# load bad words
dbg("load badwords: " . (BadWords::load or "Ok"));
+# create end condvar
+$decease = AnyEvent->condvar;
+
# prime some signals
+my ($sigint, $sigterm);
unless ($DB::VERSION) {
- $SIG{INT} = $SIG{TERM} = sub { $decease = 1 };
+ $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{$decease->send});
+ $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{$decease->send});
+# $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{AnyEvent->unloop});
+# $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{AnyEvent->unloop});
}
unless ($is_win) {
#open(DB::OUT, "|tee /tmp/aa");
-for (;;) {
-# $DB::trace = 1;
-
- Msg->event_loop(10, 0.010);
- my $timenow = time;
-
- DXChannel::process();
-
-# $DB::trace = 0;
+my $per_sec = AnyEvent->timer(after => 0, interval => $idle_interval, cb => sub{idle_loop()});
- # do timed stuff, ongoing processing happens one a second
- if ($timenow != $systime) {
- reap() if $zombies;
- $systime = $timenow;
- my $days = int ($systime / 86400);
- if ($systime_days != $days) {
- $systime_days = $days;
- $systime_daystart = $days * 86400;
- }
- IsoTime::update($systime);
- DXCron::process(); # do cron jobs
- DXCommandmode::process(); # process ongoing command mode stuff
- DXXml::process();
- DXProt::process(); # process ongoing ak1a pcxx stuff
- DXConnect::process();
- DXMsg::process();
- DXDb::process();
- DXUser::process();
- DXDupe::process();
- AGWMsg::process();
- BPQMsg::process();
+# main loop
+$decease->recv;
- if (defined &Local::process) {
- eval {
- Local::process(); # do any localised processing
- };
- dbg("Local::process error $@") if $@;
- }
- }
- if ($decease) {
- last if --$decease <= 0;
- }
-}
+idle_loop() for (1..25);
cease(0);
exit(0);
$is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows?
}
+use strict;
+
+use AnyEvent;
use Msg;
use IntMsg;
use DXVars;
use Console;
+use vars qw($maxkhist $maxshist $foreground $background $mycallcolor @colors );
+
#
# initialisation
#
-$call = ""; # the callsign being used
-$conn = 0; # the connection object for the cluster
-$lasttime = time; # lasttime something happened on the interface
+my $call = ""; # the callsign being used
+my $conn = 0; # the connection object for the cluster
+my $lasttime = time; # lasttime something happened on the interface
+
+my $connsort = "local";
+my @khistory = ();
+my @shistory = ();
+my $khistpos = 0;
+my $pos;
+my $lth;
+my $bot;
+my $top;
+my $pagel = 25;
+my $cols = 80;
+my $lines = 25;
+my $scr;
+my $spos = $pos = $lth = 0;
+my $inbuf = "";
+my @time = ();
-$connsort = "local";
-@khistory = ();
-@shistory = ();
-$khistpos = 0;
-$spos = $pos = $lth = 0;
-$inbuf = "";
-@time = ();
+my $lastmin = 0;
+my $sigint;
+my $sigterm;
+my $decease;
#$SIG{WINCH} = sub {@time = gettimeofday};
sub do_initscr
{
$scr = new Curses;
- if ($has_colors) {
+ if ($main::has_colors) {
start_color();
- init_pair("0", $foreground, $background);
-# init_pair(0, $background, $foreground);
- init_pair(1, COLOR_RED, $background);
- init_pair(2, COLOR_YELLOW, $background);
- init_pair(3, COLOR_GREEN, $background);
- init_pair(4, COLOR_CYAN, $background);
- init_pair(5, COLOR_BLUE, $background);
- init_pair(6, COLOR_MAGENTA, $background);
+ init_pair("0", $main::foreground, $main::background);
+# init_pair(0, $main::background, $main::foreground);
+ init_pair(1, COLOR_RED, $main::background);
+ init_pair(2, COLOR_YELLOW, $main::background);
+ init_pair(3, COLOR_GREEN, $main::background);
+ init_pair(4, COLOR_CYAN, $main::background);
+ init_pair(5, COLOR_BLUE, $main::background);
+ init_pair(6, COLOR_MAGENTA, $main::background);
init_pair(7, COLOR_RED, COLOR_BLUE);
init_pair(8, COLOR_YELLOW, COLOR_BLUE);
init_pair(9, COLOR_GREEN, COLOR_BLUE);
init_pair(12, COLOR_MAGENTA, COLOR_BLUE);
init_pair(13, COLOR_YELLOW, COLOR_GREEN);
init_pair(14, COLOR_RED, COLOR_GREEN);
- eval { assume_default_colors($foreground, $background) } unless $is_win;
+ eval { assume_default_colors($main::foreground, $main::background) } unless $main::is_win;
}
$top = $scr->subwin($lines-4, $cols, 0, 0);
nonl();
$lines = LINES;
$cols = COLS;
- $has_colors = has_colors();
+ $main::has_colors = has_colors();
do_initscr();
show_screen();
}
+my $ceasing = 0;
+
# cease communications
sub cease
{
my $sendz = shift;
+
+ print "ceasing ($ceasing)\r\n";
+
+ return if $ceasing;
+ ++$ceasing;
+
$conn->disconnect if $conn;
- endwin();
dbgclose();
+ endwin();
+ $decease->send;
+
print @_ if @_;
exit(0);
}
# determine the colour of the line
sub setattr
{
- if ($has_colors) {
+ if ($main::has_colors) {
foreach my $ref (@colors) {
if ($_[0] =~ m{$$ref[0]}) {
$top->attrset($$ref[1]);
setattr($line);
$top->addstr($line);
# $top->addstr("\n");
- $top->attrset(COLOR_PAIR(0)) if $has_colors;
+ $top->attrset(COLOR_PAIR(0)) if $main::has_colors;
$spos = @shistory;
} else {
$p = 0 if $p < 0;
$top->move(0, 0);
- $top->attrset(COLOR_PAIR(0)) if $has_colors;
+ $top->attrset(COLOR_PAIR(0)) if $main::has_colors;
$top->clrtobot();
for ($i = 0; $i < $pagel && $p < @shistory; $p++) {
my $line = $shistory[$p];
$top->addstr("\n") if $i;
setattr($line);
$top->addstr($line);
- $top->attrset(COLOR_PAIR(0)) if $has_colors;
+ $top->attrset(COLOR_PAIR(0)) if $main::has_colors;
$i += $lines;
}
$spos = $p;
$scr->addstr($lines-4, 0, $str);
$scr->addstr($size);
- $scr->attrset($mycallcolor) if $has_colors;
+ $scr->attrset($mycallcolor) if $main::has_colors;
$scr->addstr($call);
- $scr->attrset(COLOR_PAIR(0)) if $has_colors;
+ $scr->attrset(COLOR_PAIR(0)) if $main::has_colors;
$scr->addstr($add);
$scr->refresh();
# $top->refresh();
$bot->refresh();
}
+sub idle_loop
+{
+ my $t;
+ $t = time;
+ if ($t > $lasttime) {
+ my ($min)= (gmtime($t))[1];
+ if ($min != $lastmin) {
+ show_screen();
+ $lastmin = $min;
+ }
+ $lasttime = $t;
+ }
+ my $ch = $bot->getch();
+ if (@time && tv_interval(\@time, [gettimeofday]) >= 1) {
+# mydbg("Got Resize");
+# do_resize();
+ next;
+ }
+ if (defined $ch) {
+ if ($ch ne '-1') {
+ rec_stdin($ch);
+ }
+ }
+ $top->refresh() if $top->is_wintouched;
+ $bot->refresh();
+}
#
# deal with args
#
$call = uc shift @ARGV if @ARGV;
-$call = uc $myalias if !$call;
+$call = uc $main::myalias if !$call;
my ($scall, $ssid) = split /-/, $call;
$ssid = undef unless $ssid && $ssid =~ /^\d+$/;
if ($ssid) {
$call = "$scall-$ssid";
}
-if ($call eq $mycall) {
- print "You cannot connect as your cluster callsign ($mycall)\n";
+if ($call eq $main::mycall) {
+ print "You cannot connect as your cluster callsign ($main::mycall)\n";
exit(0);
}
+# create end condvar
+$decease = AnyEvent->condvar;
+
dbginit();
-$conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket);
+$conn = IntMsg->connect("$main::clusteraddr", $main::clusterport, \&rec_socket);
if (! $conn) {
- if (-r "$data/offline") {
- open IN, "$data/offline" or die;
+ if (-r "$main::root/data/offline") {
+ open IN, "$main::root/data/offline" or die;
while (<IN>) {
print $_;
}
close IN;
} else {
- print "Sorry, the cluster $mycall is currently off-line\n";
+ print "Sorry, the cluster $main::mycall is currently off-line\n";
}
exit(0);
}
-$conn->set_error(sub{cease(0)});
-
unless ($DB::VERSION) {
- $SIG{'INT'} = \&sig_term;
- $SIG{'TERM'} = \&sig_term;
+ $sigint = AnyEvent->signal(signal=>'INT', cb=> sub{$decease->send});
+ $sigterm = AnyEvent->signal(signal=>'TERM', cb=> sub{$decease->send});
}
-$SIG{'HUP'} = \&sig_term;
+#$SIG{'HUP'} = \&sig_term;
+my $sighup = AnyEvent->signal(signal=>'HUP', cb=> sub{$decease->send});
+$conn->{sock}->on_eof(sub{$decease->send});
+$conn->{sock}->on_error(sub{$decease->send});
# start up
do_resize();
-$SIG{__DIE__} = \&sig_term;
+#$SIG{__DIE__} = \&sig_term;
+#my $sigdie = AnyEvent->signal(signal=>'__DIE__', cb=> sub{$decease->send});
$conn->send_later("A$call|$connsort width=$cols");
$conn->send_later("I$call|set/page $maxshist");
$Text::Wrap::Columns = $cols;
-my $lastmin = 0;
-for (;;) {
- my $t;
- Msg->event_loop(1, 0.01);
- $t = time;
- if ($t > $lasttime) {
- my ($min)= (gmtime($t))[1];
- if ($min != $lastmin) {
- show_screen();
- $lastmin = $min;
- }
- $lasttime = $t;
- }
- my $ch = $bot->getch();
- if (@time && tv_interval(\@time, [gettimeofday]) >= 1) {
-# mydbg("Got Resize");
-# do_resize();
- next;
- }
- if (defined $ch) {
- if ($ch ne '-1') {
- rec_stdin($ch);
- }
- }
- $top->refresh() if $top->is_wintouched;
- $bot->refresh();
-}
+my $event_loop = AnyEvent->timer(after => 0, interval => 0.010, cb => sub{idle_loop()});
+
+$decease->recv;
-exit(0);
+cease(0);
unshift @INC, "$root/local";
}
+package main;
+
use DXVars;
use DXUser;
close CLLOCK;
}
-$DXUser::v3 = 1;
+$DXUser::v4 = 1;
-if (-e "$userfn.v2" || -e "$userfn.v3") {
+if (-e "$userfn.v2" || -e "$userfn.v3" ||-e "$userfn.v4") {
print "Do you wish to destroy your user database (THINK!!!) [y/N]: ";
$ans = <STDIN>;
if ($ans =~ /^[Yy]/) {
DXUser->init($userfn, 1);
create_it();
}
+DXUser->sync;
DXUser->finish();
exit(0);
projects / spider.git / commitdiff